Изучаем дифракцию Фраунгофера с помощью Wolfram Language и WLJS Notebook

Дифракционная картинка света и тени, получаема на большом расстоянии от силуэта объекта, находящегося перед источником света, — математически пропорциональна двумерному преобразованию Фурье

Из основ оптики: дифракция — это явление, которое возникает, когда свет (или другая волна) проходит через препятствие или отверстие и отклоняется от "очевидного" прямолинейного пути. Дифракция Фраунгофера относится к особому случаю, когда наблюдение осуществляется на большом расстоянии от объекта (или с использованием линз).

По сути форма объекта находящегося перед источником света (например, отверстия или препятствия) преобразуется в характерную картину света и тени на экране, называемую дифракционной картиной.

Ниже приведен код, который можно вставить в блокнот и попробовать порисовать самому. Это ни что иное, как лишь двумерное фурье-преобразование силуэта в реальном времени

amplidute2D[data_] := Module[{d, fw, nRow, nCol},
  {nRow, nCol} = Dimensions[data];
  d = data;
  d = d (-1)^Table[i + j, {i, nRow}, {j, nCol}];
  fw = Fourier[d, FourierParameters -> {1, 1}];

  (* Используем логарифмическую шкалу для удобства *)
  
  Log[1 + Abs@fw]
]

(* сам виджет *)

LeakyModule[{
  buffer = ImageData[ConstantImage[0, {300,300}], "Real32"],
  shape = InputRaster[ImageSize->{300,300}, "AllowUpdateWhileDrawing"->True]
},

  EventHandler[shape, Function[new, 
    With[{array = ImageData[RemoveAlphaChannel[new, White] // Binarize // ColorNegate, "Real32"]},
      With[{amp = amplidute2D[array]},
        buffer = amp / Max[amp];
      ];
    ]
  ]];
  
  {
    shape,
    Image[buffer // Offload, "Real32"]
  } // Row
]

Ссылки

• Бесплатный интерпретатор Wolfram Language

• Блокнотный интерфейс WLJS Notebook

Never gonna give Differential Calculus up или решаем уравнение Лапласа на теле Рика Эстли в пару строчек 🕺🏼

Пример создания и использования граничной сетки для решения уравнений на её основе в WLJS Notebook

Улыбочку! 📸

img = (* Drag n drop фотографию Рика *);  

Применяем фильтр, чтобы оставить только силуэт

MeanShiftFilter[%, 5, 1] // Binarize // ColorNegate

Делаем сетку для решения уравнения из ч/б изображения

ξ = ImageMesh[%]

Ищем собственные значения и векторы (первые 6) оператора Лапласа aka решаем волновое уравнение

{vals, funs} = NDEigensystem[ {
  -Laplacian[u[x, y], {x, y}], 
  DirichletCondition[u[x, y] == 0, True]
}, 
u[x, y], Element[{x, y}, ξ], 6];

Рисуем первые 6 решений и их "энергии"

Grid@
 Partition[
  Table[ContourPlot[
    funs[[i]], Element[{x, y}, ξ], 
    PlotRange -> All, ImageSize->300, 
    PerformanceGoal->"Speed", PlotLabel -> vals[[i]] 
  ], {i, Length[vals]}], 3]

Результат

Реализация FABRIK на WL в пару строк

Текущая реализация далека от оптимальной, но она хорошо подходит для демонстрации работы алгоритма. Среда исполнения используется WLJS Notebook aka Jupyter + Observable для WL

Мы создадим цепочку из точек и свяжем их в сегментированную линию фиксированной длины

chain = Table[Exp[-ϕ]{-Cos[ϕ], Sin[ϕ]}, {ϕ, 0, π - π/7, π/7.0}];
Graphics[{
    Line[chain // Offload], Black, 
    PointSize[0.04], Point[chain // Offload], Red,
    EventHandler[Graphics`Canvas[], {
      "mousemove" -> handler
    }]
  },
  Axes->True, PlotRange->{{-1,0.2}, {0,0.4}}, ImageSize->400
]

Вы увидите окно с цепью, но цепь не будет реагировать на движение мыши. Нужен сам "решатель". Оригинальная статья опубликована в 2010 году, и алгоритм можно реализовать буквально влоб

handler = Function[target,
  Module[{
    buffer = chain, 
    origin = {-1,0}, 
    prev = chain, 
    lengths = Norm /@ (chain // Reverse // Differences) // Reverse
  },
    buffer = Table[With[{p = chain[[-i]]},
      If[i === 1,
        prev = target;
        target
      ,
    
        prev = prev - Normalize[(prev - p)] lengths[[1-i]];
        prev 
      ]
    ]   
    , {i, chain // Length}] // Reverse;

    buffer = Table[With[{p = buffer[[i]]},
      If[i === 1,
        prev = origin;
        origin
      ,
    
        prev = prev - Normalize[(prev - p)] lengths[[i-1]];
        prev 
      ]
    ]
    , {i, chain // Length}];

    chain = buffer;
   ]
];

После выполнения этой ячейки цепь оживет

Одна линия, чтобы рассказать историю или Bad Apple на графике WL

Сначала получаем видеофайл анимации Bad Apple каким-либо образом и загружаем его в любую ячейку ввода. Извлечем один кадр

video = Import[FileNameJoin[{"attachments", "Touhou - Bad Apple.mp4"}], 
{"ImageList", All}];
img = video[[500]] // Thumbnail

Кстати, удобно, что Bad Apple выполнена в стиле теневой анимации, поэтому мы можем легко преобразовать любое изображение в сетку из 1 и 0. Если знать положение каждого темного пикселя, то не составит труда обойти их всех одной линией

img = img // ImageAdjust // Binarize;
pos = PixelValuePositions[img, 0];
{length, path} = FindShortestTour[pos];

Здесь нам не нужна длина, а только сам путь, который содержит индексы точек из pos, соединённых в нужном порядке для формирования кратчайшего маршрута через все тёмные пиксели

ListLinePlot[pos[[path]]]

Чтобы убрать угловатости, можно сгладить скользящим средним

ListLinePlot[MovingAverage[pos[[path]], 5]]

Если повторить это со всеми кадрами и стащить звук отдельный байт массив, то можно сделать такую анимацию в реальном времени.

Код полной анимации приведен в этой статье (EN).