(*Программа выводит аналитическое решение и 
  иллюстрации задачи Коши для уравнения колебаний
  при заданных пользователем начальных условиях
  и коэфиициента уравнения*)
bcontinue=True; (*После предыдущего запуска этой программы осталось равным False,
           либо еще вообще не задано, если это первый запуск программы в 
          текущей сессии Mathematica*)
(*Выражение для φ и ψ, установленные по умолчанию*)
φ[x_]:=0.5*(1+Cos[π*x])*(HeavisideTheta[x+1]-HeavisideTheta[x-1]);
ψ[x_]:=(E^(-(x^2)));
tmp=φ[0.5];
tmp=ψ[0.5];

(*Бесконечный цикл, в котором у пользователя запрашиваются начальные условия и
 коэффициент, затем выводится диалог с решением задачи. Это происходит, пока
 пользователь не нажмет кнопку "Конец" в этом диалоге.*)
While[
bcontinue,
(*запрос на ввод начальных условий и коэффициента a*)
a=Input["Введите коэффициент a",1];
ϕexpr=Input[
"Введите функцию φ(x), задающую начальный профиль струны.",
Evaluate[φ[x]]
];
ψexpr=Input[
"Введите функцию ψ(x), задающую начальное рапределение скоростей точек струны. Неопределенный интеграл от введенной функции должен выражаться конечной формулой с использованием элементарных и специальных функций, известных системе Mathematica, в противном случае, результаты непредсказуемы.",
Evaluate[ψ[x]]
];
(*Определение/переопределение функций φ и ψ*)
φ[x_]:=Evaluate[ϕexpr];
ψ[x_]:=Evaluate[ψexpr];
Print[Style["Производятся аналитические преобразования...",Blue,Italic,24]];
Print[Style["это может занять значительное время...",Blue,Italic,24]];
Print["φ(x)=",TraditionalForm[φ[x]]];
Print["ψ(x)=",TraditionalForm[ψ[x]]];
(*Определение/переопределние u(x,t)*)
(*Я сначала присваиваю вычисленное выражение промежуточной перемннной,
  чтобы интегрирование и упрощение происходили не каждый раз при вычислении значения
  u[x,t], а только один раз. Возможно, это можно сделать проще...*)
Ψexpr=Assuming[x∈Reals,(1/a)(∫_0^x)ψ[ξ]\[DifferentialD]ξ];
Print["Ψ(x)=",TraditionalForm[Ψexprsimp=FullSimplify[Ψexpr]/.HeavisideTheta[k_]->UnitStep[k]]];
Ψ=Compile[{{x,_Real}},Evaluate[Ψexprsimp]];
uexpr=((φ[x-a t]+φ[x+a t])/2)+(1/2)Assuming[x∈Reals&&t∈Reals&&t>0,Integrate[ψ[ξ],{ξ,x-a t,x+a t},PrincipalValue->True]];
Print["u(x,t)=",TraditionalForm[
uexprsimp=Replace[FullSimplify[uexpr],HeavisideTheta[k_]->UnitStep[k]]]];
(*u компилируется в предположении действительности аргументов
  (это позволяет ускорить вычисление её значений, а значит, с приемлемой
  скоростью выводить анимацию решения более сложных задач)*)
u=Compile[{{x,_Real},{t,_Real}},Evaluate[uexprsimp]];
(*Волна импульса*)
ImpExprSimp=Replace[FullSimplify[(1/(2a))Assuming[x∈Reals&&t∈Reals&&t>0,Integrate[ψ[ξ],{ξ,x-a t,x+a t},PrincipalValue->True]]],HeavisideTheta[k_]->UnitStep[k]];
ImpulsWave=Compile[{{x,_Real},{t,_Real}},Evaluate[ImpExprSimp]];
(*Волна отклонения*)
DeflExprSimp=FullSimplify[((φ[x-a t]+φ[x+a t])/2)]/.HeavisideTheta[k_]->UnitStep[k];
DeflectionWave=Compile[{{x,_Real},{t,_Real}},Evaluate[DeflExprSimp]];
(*Вывод диалога с решением и иллюстрациями
  диалог возвращает новое значение переменной t,
   в зависимости от которого либо продолжает выполняться цикл, 
   либо его выполнение прекращается*)
bcontinue=DialogInput[
DialogNotebook[
{
(*Заголовок*)
TextCell["Решение задачи Коши для уравнения колебаний струны","Subtitle"],
Row[{
(*Графики φ и ψ*)
Panel[Column[
Table[
Plot[
ReleaseHold[par[[1]]],
{x,-3,3}, 
AspectRatio->2/6, 
(*PlotRange->{-0.7,1.0},*)
PlotStyle->{par[[2]]},       
ImageSize->250,
AxesLabel->{Style["x",Bold,15],Style[par[[3]],Bold,15]}],
{par,{
{φ[x]/.HeavisideTheta[k_]->UnitStep[k],Directive[Blue,Thick],"φ(x)"},
{ψ[x]/.HeavisideTheta[k_]->UnitStep[k],Directive[Green,Thick],"ψ(x)"},
{Hold[Ψ[x]],Directive[Black,Thick],"Ψ(x)"}}}
]
]],
(*График u(x,t)*)
Animate[ 
Plot[
{-0.5Ψ[x-t],0.5Ψ[x+t],ImpulsWave[x,t], DeflectionWave[x,t],u[x,t]},
{x,-3,3}, 
AspectRatio->4.5/6, 
PlotRange->{-0.7,2.0},
PlotStyle->{
Directive[Black,Dashed],
Directive[Black,Dashed],
Directive[Green,Thick,Dashed],
Directive[Blue,Thick,Dashed],
Directive[Red,Thickness[0.01]]},       
ImageSize->500,
AxesLabel->{Style["x",Bold,15],""},			               
Epilog->{
Text[Style["u(x,t), t=",Bold,15],{0.5,1.9}],
Text[Style[NumberForm[t,{2,2}], Bold, 15],{1.1,1.9}]}],
{t,0,5}]
}],
(*Кнопки управления программой*)
Row[{
Button[
"Новый пример",
DialogReturn[True],
Background->Green,
FrameMargins->10], (*Решить следующую задачу*)
Button[
"Конец",
DialogReturn[False],
Background->Red,
FrameMargins->10] (*Прекратить выполнение программы*)
}]
}
]
]
]