-1
$\begingroup$

I have the given letter below. I want to draw it geometrically by using trigonometry and other formulas.Help me draw the letter OR give me the idea to draw the letter of any language using formulas. Just like O,P,G..etc.,. enter image description here

enter image description here

Improve this question
$\endgroup$
5
  • $\begingroup$ Is this related to Mathematica ? Or are you asking just for thecmathematics behind it ? $\endgroup$ Commented Aug 13, 2015 at 6:05
  • 1
    $\begingroup$ Figure out a way to find the shape on the critical strip of the Riemann zeta, encode that, done. Win Fields medal along the way. Otherwise, look into perhaps getting some trig series based on Fourier machinations on the shape. Else, segment it and use compositions of splines/beziers... $\endgroup$ Commented Aug 13, 2015 at 6:06
  • $\begingroup$ Ya thank for your reply. Please give me the basic commands or basic code for any letter in mathematica $\endgroup$ Commented Aug 13, 2015 at 6:11
  • $\begingroup$ FromCharacterCode@2949 - Very fast, no math! $\endgroup$ Commented Aug 13, 2015 at 6:24
  • 2
    $\begingroup$ I wonder ... No, I better don't $\endgroup$ Commented Aug 13, 2015 at 6:31

1 Answer 1

Reset to default
2
$\begingroup$

You should be able to use the code here:

Making Formulas… for Everything—From Pi to the Pink Panther to Sir Isaac Newton

See the function, pointsListToLines, a third of the way down the page.

Here is a copy of the code from the 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]]]
Improve this answer
$\endgroup$
2
  • $\begingroup$ Thank @Chris . I will try now $\endgroup$ Commented Aug 13, 2015 at 6:45
  • 2
    $\begingroup$ I believe you should make this CW or buy Michael Trott a six pack $\endgroup$ Commented Aug 13, 2015 at 7:31

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.