Làm thế nào là cốt truyện năng động này có thể với mathematica?

Question

Đây là một hoạt động BBC graphics. Tôi nghĩ rằng có thể tái tạo đồ họa trong Mathematica.

Trong quá trình trả lời chúng ta sẽ thấy một số thủ thuật đồ họa quyến rũ sẵn trong MMA. Đó là lý do duy nhất để đặt câu hỏi ở đây.

Cập nhật:

tôi chỉ kiểm tra rằng BBC đang sử dụng đơn giản JavaScript để làm điều đó. Họ đã tự tạo các ảnh tĩnh và thậm chí không sử dụng xử lý sự kiện dựa trên Flash. Vì vậy, tất cả các hình ảnh là thực thể tĩnh và một khi chúng ta click vào một quốc gia nó tạo ra một hình ảnh độc đáo. Đối với các quốc gia khác, nó hiển thị các hình ảnh khác. Các hình ảnh riêng biệt cho từng trường hợp có thể được tạo ra thông qua PowerPoint, Visio hoặc thậm chí là Photoshop. Người ta có thể kiểm tra điều này chỉ bằng cách vô hiệu hóa JavaScript trong trình duyệt của bạn và bằng cách tải lại trang.

Tôi hiểu rằng những hình ảnh đơn lẻ đó có thể được làm từ MMA. Một số câu trả lời cho thấy đúng hướng như thế nào người ta có thể làm điều đó. Vì vậy, tôi chấp nhận câu trả lời tốt nhất cho đến nay.

Answer 1

Chỉ cần một khởi động:

a = Point[{0, 0}]; 
b = .75 Tuples[{1, -1}, 2][[{3, 1, 2, 4}]]; 
PieChart[ 
{ 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[1]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[2]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[3]], {0, 0}, #}] & /@ b})], 
    Button[1, (a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{b[[4]], {0, 0}, #}] & /@ b})], 
    } 
, 
SectorOrigin -> {Automatic, 1}, 
Epilog -> Dynamic@a] 

Sửa More nhỏ gọn:

a = Point[{0, 0}]; 
b = .75 Tuples[{1, -1}, 2][[{3, 1, 2, 4}]]; 
PieChart[ 
ReleaseHold[Replace[Table[ 
    List[1, 
    ReplaceAll[ 
     Hold[a = {Thickness[.05], Arrowheads[.1], 
     Arrow[BSplineCurve@{k, {0, 0}, #}] & /@ b}], k -> i]], 
    {i, b}], List -> Button, {2}, Heads -> True]] 
, 
SectorOrigin -> {Automatic, 1}, 
Epilog -> Dynamic@a] 

Answer 2

Đây không phải là câu trả lời đầy đủ, nhưng quá dài để nhận xét. Tôi khuyến khích tất cả mọi người để "ăn cắp" từ nó, và hoàn thành nó :-)

g = RandomGraph[{5, 12}, DirectedEdges -> True]; 

SetterBar[Dynamic[v], VertexList[g]] 

Dynamic@HighlightGraph[ 
    g, {Style[Cases[EdgeList[g], v \[DirectedEdge] _], 
    Directive[Thick, Black]], Style[v, Red]}, 
    GraphLayout -> "CircularEmbedding", EdgeStyle -> Lighter@Gray, 
    VertexLabels -> "Name"] 

Bước tiếp theo là sử dụng VertexShapeFunction với các đối tượng được bọc trong EventHandler để thay thế SetterBar.

Answer 3

Một số động tác chân cơ bản hơn cho việc này:

g[\[Alpha]_, \[Beta]_, color_] := Module[{t}, 
t = Graphics[{{Thickness[.03], Arrowheads[{.15}], color, 
    Arrow[ 
    BezierCurve[{{Cos[\[Alpha]], Sin[\[Alpha]]}, {0, 
     0}, {Cos[\[Beta]], Sin[\[Beta]]}}]]}}, 
PlotRange -> 1.5, ImageSize -> 512, Background -> None]; 
ImageCompose[Blur[t, 15], t] 
] 

one = Fold[ImageCompose, 
g[0, \[Pi]/3, Blue], {g[0, \[Pi]/2, Blue], g[0, \[Pi], Blue], 
g[0, 4 \[Pi]/3, Blue]}] 

two = Fold[ImageCompose, 
g[\[Pi]/3, 0, Yellow], {g[\[Pi]/3, \[Pi]/2, Yellow], 
g[\[Pi]/3, \[Pi], Yellow], g[\[Pi]/3, 4 \[Pi]/3, Yellow]}] 

DynamicModule[{pick = 1}, 
ClickPane[ 
    Dynamic@If[pick == 1, one, two], 
    Function[{point}, If[First[point] < 256, pick = 1, pick = 2]]] 
]