Message Boards Message Boards

[?] Make a formula for this image?

Posted 7 years ago

I'd like to preface this by explaining what I'm trying to accomplish. Essentially I'd like to take my university's logo and generate a formula with the graph resembling this logo. I found a tutorial on how to do so (found here) and despite my complete lack of experience with Mathematica, I was able to follow along fairly easily. My issue occurred when I needed to generate segments using the input:

SeedRandom[2];
hLines = pointListToLines[edgePoints, 16];
Length[hLines] 

However the output in the tutorial

seen Here

was much higher than mine

seen here.

Even after tinkering with the values, changing the original logo, and retyping the input, the output is always 2. Frustrated, I decided to copy each line from the tutorial exactly, using the same image and everything, and yet the output was still 2.Why?

At this point, I am extremely confused and don't know where to go from here. Any suggestions or help in remedying this would be much appreciated.

Link to my project

Attachments:
POSTED BY: gage benham
2 Replies

Welcome to Wolfram Community! Please make sure you know the rules: https://wolfr.am/READ-1ST

  • Do not use CAPITAL letter and words HELP etc. - others people questions as important as yours

  • Do not use images instead of copy-paste code

  • You can attach notebooks to he post, no need for links to external sites

  • Do not select groups randomly, choose only relevant groups

POSTED BY: Moderation Team
Posted 7 years ago

If I start Mathematica fresh and I click on the menu bar Evaluation->Quit Kernel->Local and click yes I really want to quit the kernel, but that doesn't quit Mathematica, and then I evaluate your project notebook one cell/expression at a time then when I get down to where I am about to evaluate

SeedRandom[2];
hLines = pointListToLines [edgePoints, 16];
Length[hLines]

I see that pointListToLines is still colored blue. That slight change in color is really important. That means that function hasn't been defined yet. Unfortunately, based on many observations, that slight change in color isn't enough to be noticed by the new users who really need to notice that and it is ignored by more experienced users who may or may not need that. If that slight change were instead a bright red bouncing hand with a finger pointing at that particular symbol in the code with a little "thought bubble" above it saying "this function hasn't been defined yet and needs to be defined, click here for more information" then that might make more of an impression on the new users that really need it.

If I were to evaluate that line of code without having defined pointListToLines first and then were to look at the value of hLines I would see it is

pointListToLines[{{334, -20}, {335, -20}, {336, -20}, {337, -20},
...
{713, -577}, {714, -577}, {715, -577}, {716, -577}, {717, -577}}, 16]

where I have replaced several thousand lines of output by "..." then there is the still the function name showing that the function hasn't been replaced by the desired result because it hasn't been defined and evaluated yet.

If before I evaluate your three lines of code containing pointListToLines I insert the following code from the MakingCurves_blog.cdf

pointListToLines[pointList_, neighborhoodSize_: 6] := 
 Module[{L = DeleteDuplicates[pointList], NF, \[Lambda], lineBag, counter, seenQ, sLB, nearest, nearest1,
   nextPoint, couldReverseQ,  \[ScriptD], \[ScriptN], \[ScriptS]},
  NF = Nearest[L] ;
  \[Lambda] = Length[L];
  Monitor[ (* list of segments *)
   lineBag = {};
   counter = 0; 
   While[counter < \[Lambda], (* new segment *)
    sLB = {RandomChoice[DeleteCases[L, _?seenQ]]}; 
    seenQ[sLB[[1]]] = True;
    counter++;
    couldReverseQ = True; (* complete segment *)
    While[(nearest = NF[Last[sLB], {Infinity, neighborhoodSize}];
      nearest1 = SortBy[DeleteCases[nearest, _?seenQ], 
        1. EuclideanDistance[Last[sLB], #] &];
        nearest1 =!= {} || couldReverseQ),
        If[nearest1 === {}, (* extend the other end; penalize sharp edges *)
           sLB = Reverse[sLB]; couldReverseQ = False, (* prefer straight continuation *)
           nextPoint = If[Length[sLB] <= 3, nearest1[[1]], \[ScriptD] = 
         1. Normalize[(sLB[[-1]] - sLB[[-2]]) + 1/2 (sLB[[-2]] - sLB[[-3]])];
          \[ScriptN] = {-1, 1} Reverse[\[ScriptD]];
          \[ScriptS] = Sort[{Sqrt[(\[ScriptD].(# - sLB[[-1]]))^2 + (* perpendicular *)
          2 (\[ScriptN].(# - sLB[[-1]]))^2], # } & /@ nearest1]; 
          \[ScriptS][[1, 2]]];
          AppendTo[sLB, nextPoint];
          seenQ[nextPoint] = True;
          counter++ ]];
    AppendTo[lineBag, sLB]]; (* return segments sorted by length *)
   Reverse[SortBy[Select[lineBag , Length[#] > 12 &], Length]], (* monitor progress *)
   Grid[{{Text[Style["progress point joining", Darker[Green, 0.66]]], 
      ProgressIndicator[counter/\[Lambda]]},
          {Text[ Style["number of segments", Darker[Green, 0.66]]], Length[lineBag] + 1}},
          Alignment -> Left, Dividers -> Center]]]

that then defines pointListToLines before I use it. After this defines the function then your blue pointListToLines changes to black letting me know that this function has now been defined.

Then I can evaluate your three lines and I get a cute little bar growing across the screen as it finishes and it finally tells me that the Length[hlines] is now 14, not 2. If I wanted to peek at the value of hLines I see it no longer has a pointListToLines in it.

Next I evaluate your

Graphics[{ColorData["DarkRainbow"][RandomReal[]], Line[#]} &  /@ hLines]

and it shows me the outline of your logo.

Next I am about to evaluate

fCs = fourierComponents[hLines];

but again this is blue telling me that fourierComponents has not yet been defined.

I look for the definition of that in the same MakingCurves_blog.cdf and find this

(* Fourier coefficients of a single curve *)
fourierComponentData[pointList_, nMax_, op_] := 
 Module[{\[CurlyEpsilon] = 10^-3, \[Mu] = 2^14, M = 10000, s, scale, \[CapitalDelta], L , nds, sMax, 
   if, \[ScriptX]\[ScriptY]Function, X, Y, XFT, YFT, type},
  (* prepare curve *)
  scale = 
   1. Mean[Table[ Max[ fl /@ pointList] - Min[fl /@ pointList], {fl, {First, Last}}]];
   \[CapitalDelta] = EuclideanDistance[First[pointList], Last[pointList]];
   L = Which[op === "Closed", type = "Closed";
    If[First[pointList] === Last[pointList], 
     pointList, Append[pointList, First[pointList]]], 
     op === "Open", type = "Open"; pointList,
     \[CapitalDelta] == 0., type = "Closed";  pointList,
     \[CapitalDelta]/scale < op, type = "Closed"; 
    Append[pointList, First[pointList]],True,  type = "Open"; 
    Join[pointList, Rest[Reverse[pointList]]]]; (* re-parametrize curve by arclength *)
  \[ScriptX]\[ScriptY]Function = BSplineFunction[L, SplineDegree -> 4];
  nds = NDSolve[{s'[t] == Sqrt[\[ScriptX]\[ScriptY]Function'[t].\[ScriptX]\[ScriptY]Function'[t]],
      s[0] == 0}, s, {t, 0, 1}, MaxSteps -> 10^5, PrecisionGoal -> 4]; (* total curve length *)
       sMax = s[1] /. nds[[1]];
  if = Interpolation[Table[{s[\[Sigma]] /. nds[[1]], \[Sigma]}, {\[Sigma], 0, 1, 1/M}]];
  X[t_Real] :=  BSplineFunction[L][Max[Min[1, if[(t + Pi)/(2 Pi) sMax]] , 0]][[1]];
  Y[t_Real] :=  BSplineFunction[L][Max[Min[1, if[(t + Pi)/(2 Pi) sMax]] , 0]][[2]];
  (* extract Fourier coefficients *)
  {XFT, YFT} = Fourier[Table[#[N @ t], {t, -Pi + \[CurlyEpsilon], 
  Pi - \[CurlyEpsilon], (2 Pi - 2 \[CurlyEpsilon])/\[Mu]}]] & /@ {X, Y};   
  {type, 2 Pi/Sqrt[\[Mu]] *((Transpose[Table[{Re[#], Im[#]} &[Exp[I k Pi]  #[[k + 1]]],
  {k, 0,  nMax}]] & /@ {XFT, YFT}))}  ]
Options[fourierComponents] = {"MaxOrder" -> 180, "OpenClose" -> 0.025};
fourierComponents[pointLists_, OptionsPattern[]] :=
     Monitor[Table[fourierComponentData[pointLists[[k]],                           
     If[Head[#] === List, #[[k]], #] &[ OptionValue["MaxOrder"]],
     If[Head[#] === List, #[[k]], #] &[ OptionValue["OpenClose"]]],{k, Length[pointLists]}],
   Grid[{{Text[Style["progress calculating Fourier coefficients", Darker[Green, 0.66]]], 
      ProgressIndicator[k/Length[pointLists]]} }, Alignment -> Left, Dividers -> Center]] /;
      Depth[pointLists] === 4

and I paste that into your project notebook and evaluate that to define it. Then your fourierComponents[hLines] turns black to let me know it is defined.

Next evaluate your

fCs = fourierComponents[hLines];

and it takes a while for the green progress bar to finish.

Next makeFourierSeriesApproximationManipulate is still blue and I have to find that in the blog file.

From that insert this into your project

makeFourierSeriesApproximationManipulate[fCs_, maxOrder_: 60] :=
 Manipulate[
  With[{opts = Sequence[PlotStyle -> Black, Frame -> True, Axes -> False, FrameTicks -> None, 
      PlotRange -> All, ImagePadding -> 12]},
   Show[{
      ParametricPlot[Evaluate[ makeFourierSeries[#,t,n]&/@Cases[fCs,{"Closed",_}]], {t,-Pi,Pi},opts],
      ParametricPlot[Evaluate[ makeFourierSeries[#, t, n] & /@ Cases[fCs, {"Open", _}]],
         {t, -Pi, 0}, opts]}] // Quiet], 
  {{n, 1, "max series order"}, 1, maxOrder, 1, Appearance -> "Labeled"},TrackedSymbols :> True,
     SaveDefinitions -> True]

and evaluate that and your makeFourierSeriesApproximationManipulate turns black to show it has been defined.

Then evaluate your code and I get an odd assortment of a few ellipses and lines inside the manipulate box.

If I click inside the Manipulate box on the little grey line and near the left end I can bump up the max series order a little at a time. It isn't perfect, but when I get the order up around 30 or so then I can begin to make out similarities between the graphic in the manipulate and the graphic that you want to approximate.

Next there aren't any names in blue in the GraphicsGrid so nothing is waiting to be defined and I evaluate that. That again shows me approximations of what you are trying to accomplish.

Next makeSegmentOrderManipulate is blue, but that is because the lines after that are about to define it so I don't have to go find that in the blog file. When I evaluate that nothing appears. I am guessing that what is going to follow that is the next step in your project and you haven't gotten that far.

A possible alternative to finding and pasting each of those blocks of code into your notebook might be to open up that blog file in Mathematica and replace his source of his image with your source of your image and then evaluate the whole notebook one step at a time. That might have all the needed functions in place. I haven't tried that so I can't promise that would do everything that is needed, but if you wanted you could try that approach and see what happens.

I hope I correctly understood what your question was and that what I have written helps you understand a little bit about what the problem was and how it was repaired. Please see if you can reproduce each of the steps that I did and that they work for you. Sometimes copy and paste to put code here can scramble things and you need to have all this exactly correct.

POSTED BY: Bill Simpson
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract