Re: Software that makes placemats
Posted: 23:14 Tue 28 Aug 2018
A place for those passionate about port, and for those new to it. We hold lots of Port tastings: please join us!
https://www.theportforum.com/
Or just using a different shape from the options available; I think gman was saying he didn't like that particular fill, and I'm sure we all have our preferences and dislikes in that regard (and false is already the default for /ShapesInTitles in the current placemat.ps anyway, for anyone wondering).
In agreement with the above view, though I realise this is in disagreement with author preference.
Note ‘latter’ of two; ‘last’ of three or more.
/Alternating
/Sideways
/Upright
Code: Select all
/TastingNotesStarsNameColsRowsArrangement % (ASCIIfied Name) NumCols NumRows /Alternating|/Sideways|/Upright
[
(DRT) 5 1 /Upright (Derek T.) 4 copy pop
(WPS) 5 1 /Sideways (Wolfgang S.) 4 copy pop
(PW) 5 1 /Sideways (Phil W.) 4 copy pop
(DJ) 5 1 /Sideways (Daniel J.) 4 copy pop
(IDJ) 5 1 /Alternating (Ian J.) 4 copy pop
(DRL) 5 1 /Alternating (Dave L.) 4 copy pop
(TC) 5 1 /Alternating (Tony C.) 4 copy pop
(MPM) 5 1 /Alternating (Mike M.) 4 copy pop
] def % /TastingNotesStarsNameColsRowsArrangement
Code: Select all
On Open
{
If Today ≤ HardWiredDateConstantBeingDateOfTasting
{
MessageBoxPopUp
string="This version HardWiredStringConstant: check that is latest with a force-reload."
Buttons={"OK, checked"}
}
}
Code: Select all
(* PostScriptForm — this version of Jan 2019. *)
(* \
PostScriptForm[] *)
(*
\
http://mathematica.stackexchange.com/questions/101954/postscriptform-\
or-forthform
http://mathematica.stackexchange.com/questions/102894/multi-case-\
function-many-single-case-delayed-assignments-or-one-which
*)
Remove[PostScriptForm];
PostScriptForm[thing_Rational] :=
If[Abs[Denominator[
thing]/(2^IntegerExponent[Denominator[thing], 2])/(5^
IntegerExponent[Denominator[thing], 5])] == 1,
ToString[N[thing, 20], InputForm, NumberMarks -> False],
PostScriptForm[Numerator[thing]] <> " " <>
PostScriptForm[Denominator[thing]] <> " div"];
PostScriptForm[thing_?AtomQ] := ToString[thing];
PostScriptForm[thing_List] :=
StringJoin @@ Riffle[Map[PostScriptForm, thing], "\r\n"];
PostScriptForm[MatrixForm[thing_]] := PostScriptForm[thing];
PostScriptForm[Times[-1, thing_]] :=
StringJoin[PostScriptForm[thing], " neg"];
PostScriptForm[thing_Power] := (
psExponent := Which[
# > 5 && Divisible[#, 3],
psExponent[#/3] <> " dup dup mul mul",
# >= 5 && OddQ[#],
"dup " <> psExponent[(# - 1)/2] <> " dup mul mul" ,
# >= 4 && EvenQ[#], psExponent[#/2] <> " dup mul",
# == 3, "dup dup mul mul",
# == 2, "dup mul",
# == 1/2, "sqrt",
# == 3/2, "dup sqrt mul",
# < 0, psExponent[-#] <> " 1 exch div",
(Rational === Head[#]) && (Log[2, # // Denominator] //
IntegerQ), psExponent[Simplify[2 #]] <> " sqrt",
Not[IntegerQ[#]], PostScriptForm[#] <> " exp",
# == 1, "",
True,
" !!!\[Bullet]\[Bullet]\[Bullet]Error with exponent = " <>
ToString[#] <> "\[Bullet]\[Bullet]\[Bullet]!!! "
] &;
Which[
thing[[2]] > 0 || Not[IntegerQ[thing[[2]]]],
PostScriptForm[thing[[1]]] <> " " <> psExponent[thing[[2]]],
thing[[2]] == -1, "1 " <> PostScriptForm[thing[[1]]] <> " div",
thing[[2]] == 0, "1",
True,
"1 " <> PostScriptForm[thing[[1]]] <> " " <>
psExponent[-thing[[2]]] <> " div"
]);
PostScriptForm[thing_Times] :=
StringJoin@
Riffle[Reap[
If[MatchQ[thing[[1]],
Power[_,
n_Integer /; n < 0]], (Sow[
"1 " <> PostScriptForm[thing[[1, 1]]] <> " div"];), (Sow[
PostScriptForm[thing[[1]]]];)];
Map[(If[MatchQ[#,
Power[_,
n_Integer /; n < 0]], (Sow[
PostScriptForm[#[[1]]^(-#[[2]])] <> " div"];), (Sow[
PostScriptForm[#] <> " mul"]; )]) &,
Drop[List @@ thing, 1]]][[2, 1]], " "];
PostScriptForm[thing_Plus] :=
StringJoin @@ If[FreeQ[thing, _^n_],
(* Simple expression, no powers,
to be summed one item at a time *)
Module[{i},
i =
Position[thing, Except[Times[-1, _] | (_?Negative)], 1,
Heads -> False];
If[Length[i] > 0,
i = i[[1, 1]], (i =
Position[thing, Not[MatchQ[#, Times[-1, _]]] &, 1,
Heads -> False]; i = If[Length[i] > 0, i[[1, 1]], 1])];
Prepend[
Map[(" " <>
Replace[#, {(n_Integer /; n < 0 :>
ToString[-n] <> " sub"), (Times[-1, _] :>
PostScriptForm[Times @@ Drop[#, 1]] <> " sub"), (Times[
n_ /; n < 0, _] :>
PostScriptForm[Times @@ Drop[#, 1]] <> " " <>
ToString[-#[[1]]] <> " mul sub"), (Times[
n_ /; n > 0, _] :>
PostScriptForm[Times @@ Drop[#, 1]] <> " " <>
ToString[#[[1]]] <> " mul add"), (_ :>
PostScriptForm[#] <> " add")}]) &,
Drop[List @@ thing, {i}]],
Replace[thing[[
i]], {Times[-1, _] :>
PostScriptForm[-thing[[i]]] <> " neg", _ :>
PostScriptForm[thing[[i]]]}]] ],
(* Polynomial *)
Module[{vars, exps, v, rcl, i, firstMul},
vars = Variables[thing];
exps = Exponent[thing, vars];
v =
Select[Transpose[{vars, exps}], (#[[2]] == Max @@ exps) &][[1,
1]];
rcl = Reverse[Map[Factor, CoefficientList[thing, v]]];
Reap[
i = 1; firstMul = True;
If[rcl[[1]] =!= 1, Sow[PostScriptForm[rcl[[1]]]]];
Map[
If[# === 0,
i++, (Sow[
If[firstMul && rcl[[1]] === 1, PostScriptForm[v^i] <> " ",
" " <> PostScriptForm[v^i] <> " mul "] <>
If[MatchQ[#, (Times[_?Negative, _] | (_?Negative))],
PostScriptForm[-#] <> " sub",
PostScriptForm[#] <> " add"]]; i = 1;
firstMul = False)] &, Drop[rcl, 1]];
If[i > 1, Sow[" " <> PostScriptForm[v^(i - 1)] <> " mul "]];
][[2, 1]]
]];
Code: Select all
circlepos = {{1, 1, 1}, {1, 2, -1}, {2, 1, 1}, {2, 2, -1}};
p1 = ListPlot[circlepos, PlotRange -> {{0, 3}, {0, 3}}];
pot[x_, y_, qx_, qy_, q_] := q/Sqrt[(x - qx)^2 + (y - qy)^2]
potgridx[x_, y_] =
D[Total[Table[
pot[x, y, circlepos[[i, 1]], circlepos[[i, 2]],
circlepos[[i, 3]]], {i, 1, Length[circlepos]}]], x];
potgridy[x_, y_] =
D[Total[Table[
pot[x, y, circlepos[[i, 1]], circlepos[[i, 2]],
circlepos[[i, 3]]], {i, 1, Length[circlepos]}]], y];
p2 = StreamPlot[{potgridx[x, y], potgridy[x, y]}, {x, 0, 2.5}, {y, 0,
2.5}];
Show[p1, p2]
Yes. Converts basic expressions to (slightly) idiomatic PostScript. Typical use case is a polynomial to be solved: it converts the CoefficientList, which is then passed to a PostScript polynomial solver.
Code: Select all
circlepos = {
{0, 1, 1},
{Sqrt[3.]/2, 0.5, -1},
{Sqrt[3.]/2, -0.5, 1},
{0, -1, -1},
{-Sqrt[3.]/2, -0.5, 1},
{-Sqrt[3.]/2, 0.5, -1},
{0, 0, 1}
};
Love it.
Fixed.jdaw1 wrote: ↑21:04 Mon 17 Jun 2019
Your approach is well suited to circles in a rectangular grid. Not so much in a hexagonal grid. E.g.:Code: Select all
circlepos = { {0, 1, 1}, {Sqrt[3.]/2, 0.5, -1}, {Sqrt[3.]/2, -0.5, 1}, {0, -1, -1}, {-Sqrt[3.]/2, -0.5, 1}, {-Sqrt[3.]/2, 0.5, -1}, {0, 0, 1} };
Code: Select all
circlevec = {{0, 1, 1}, {Sqrt[3.]/2, 0.5, -1}, {Sqrt[3.]/2, -0.5,
1}, {0, -1, -1}, {-Sqrt[3.]/2, -0.5, 1}, {-Sqrt[3.]/2,
0.5, -1}, {0, 0, 1}};
circlepos =
Table[{circlevec[[i, 1]], circlevec[[i, 2]]}, {i, 1,
Length[circlevec]}];
p1 = ListPlot[circlepos, PlotRange -> {{-2.5, 2.5}, {-2.5, 2.5}},
PlotMarkers -> {Automatic, Large}];
pot[x_, y_, qx_, qy_, q_] := q/Sqrt[(x - qx)^2 + (y - qy)^2]
potgridx[x_, y_] =
D[Total[Table[
pot[x, y, circlevec[[i, 1]], circlevec[[i, 2]],
circlevec[[i, 3]]], {i, 1, Length[circlevec]}]], x];
potgridy[x_, y_] =
D[Total[Table[
pot[x, y, circlevec[[i, 1]], circlevec[[i, 2]],
circlevec[[i, 3]]], {i, 1, Length[circlevec]}]], y];
p2 = StreamPlot[{potgridx[x, y], potgridy[x, y]}, {x, -2.5,
2.5}, {y, -2.5, 2.5}];
Show[p1, p2]
So do I, but perhaps more for its wilful stubbornness than its practicality.
Hmm. Bug or feature?
Ok, I will try zeroing at 2^-23.
Code: Select all
ContourPlot[
Log[Total[
Table[pot[x, y, circlevec[[i, 1]], circlevec[[i, 2]],
circlevec[[i, 3]]], {i, 1, Length[circlevec]}]]], {x, -2.5,
2.5}, {y, -2.5, 2.5}, Contours -> 20]
From the imagery, would I be correct in thinking that each point represents a certain positive or negative charge, and therefore that the reason some points connect to others while others pairs to not is that essentially we are only seeing lines between points of opposite (or different) charge? If so, some variation from binary charge setting would enable alternate maps with all points connecting, though would be potentially difficult to keep regular and symmetrical for all designs without specific rules.
Good idea. I also changed circlepos to a different hexagonal lattice..PhilW wrote: ↑08:20 Tue 18 Jun 2019 From the imagery, would I be correct in thinking that each point represents a certain positive or negative charge, and therefore that the reason some points connect to others while others pairs to not is that essentially we are only seeing lines between points of opposite (or different) charge? If so, some variation from binary charge setting would enable alternate maps with all points connecting, though would be potentially difficult to keep regular and symmetrical for all designs without specific rules.
Based on the above, but varying slightly, would making the centre of all circles could be a positive charge, and then placing negative charges between (either in the spaces or the mid-point between adjacent circles) might provide a more fully-connected and symmetric output, though I can't picture whether that might become too linear.
Code: Select all
{{0, 2 Sqrt[2], -1}, {Sqrt[2], Sqrt[2], -1}, {-Sqrt[2],
Sqrt[2], -1}, {0, -2 Sqrt[2], -1}, {-Sqrt[2], -Sqrt[2], -1}, {Sqrt[
2], -Sqrt[2], -1}, {0, 0, 1}}
Charges good. Because circles touch, hexagonal was better.
For this type of layout, might a triangle tesselation with charges {⅓,⅔,1} be correct?
Code: Select all
circlevec = {
{0, 1, 1},
{Sqrt[3.]/2, 0.5, 1/3},
{Sqrt[3.]/2, -0.5, 1},
{0, -1, 1/3},
{-Sqrt[3.]/2, -0.5, 1},
{-Sqrt[3.]/2, 0.5, 1/3},
{0, 0, 2/3}
};
p1 = Map[Graphics[{Red, Thick, Circle[{#[[1]], #[[2]]}, 0.5]}] &, circlevec[[All, 1 ;; 2]]];
pot[x_, y_, qx_, qy_, q_] := q/Sqrt[(x - qx)^2 + (y - qy)^2];
potgridx[x_, y_] =
D[Total[Table[
pot[x, y, circlevec[[i, 1]], circlevec[[i, 2]],
circlevec[[i, 3]]], {i, 1, Length[circlevec]}]], x];
potgridy[x_, y_] =
D[Total[Table[
pot[x, y, circlevec[[i, 1]], circlevec[[i, 2]],
circlevec[[i, 3]]], {i, 1, Length[circlevec]}]], y];
p2 = StreamPlot[{potgridx[x, y], potgridy[x, y]}, {x, -1.6,
1.6}, {y, -1.6, 1.6}];
Show[p1, p2, AspectRatio -> 1]