Generalizing the Crease Length Problem
Generalizing the Crease Length Problem
rect[a_,b_]:={{0,0},{a,0},{a,b},{0,b},{0,0}}
tri[a_,b_]:={{0,0},{a,0},{0,b},{0,0}}
linfun[{x1_,y1_},{x2_,y2_}][{x_,y_}]:=If[x1==x2,x-x1,y-y1-(y2-y1)(x-x1)/(x2-x1)]
linfuns[Ps_]:=Table[linfun[Ps[[i]],Ps[[i+1]]],{i,1,Length[Ps]-1}]
bnd[Ps_,k_][t_]:=Module[{n=Length[Ps]-1},If[t<=k/n,Ps[[k]]+n(t-(k-1)/n)(Ps[[k+1]]-Ps[[k]]),bnd[Ps,k+1][t]]]
bnd[Ps_][t_]:=bnd[Ps,1][t]
envP[Ps_,P0_][t_]:=Module[{p,x,y,mat1,mat,s},p=bnd[Ps];mat1={Cross[p'[t]],Cross[p[t]-P0]};s=If[Det[mat1]0,0,mat=Inverse[Transpose[mat1]];s=-mat[[1]].p'[t]/2];(p[t]+P0)/2+sCross[p[t]-P0]]//Quiet
maxarg[f_,c_,d_,n_]:=Module[{max,lst,lst1,,pos,eps=.00001},lst=Table[f[c+eps+(i/n)(d-c)],{i,0,n-1}];max=Max[lst];lst1=Map[#max&,lst];pos=Position[lst1,True][[1,1]];c+(d-c)(pos-1)/n]
minarg[f_,c_,d_,n_]:=Module[{min,lst,lst1,,pos,eps=.00001},lst=Table[f[c+eps+(i/n)(d-c)],{i,0,n-1}];min=Min[lst];lst1=Map[#min&,lst];pos=Position[lst1,True][[1,1]];c+(d-c)(pos-1)/n]
inpoly[lfs_,Pin_][P_]:=Apply[And,Map[(#[P]#[Pin]≥-.000001)&,lfs]]
perpbis[P_,P0_,Q_]:=(P-P0).Q(P.P-P0.P0)/2
perpbisfn[P_,P0_][Q_]:=(P-P0).Q-(P.P-P0.P0)/2
foldfn[p0_,p_][q_]:=q-2((q-(p+p0)/2).(p-p0)/(p-p0).(p-p0))(p-p0)
criteria[{u_,v_}]:=u=!=ComplexInfinity&&v=!=ComplexInfinity&&u=!=Indeterminate&&v=!=Indeterminate&&Head[u]=!=Complex&&Head[v]=!=Complex
crease[P_,P0_,Pin_,lfs_]:=Module[{sols,u,v,Qs},sols=Quiet[Map[Solve[{#[{u,v}]0,perpbis[P,P0,{u,v}]},{u,v}]&,lfs]];sols=Select[sols,(#=!={})&];Qs=Quiet[{u,v}/.Map[First,sols]];Qs=Select[Qs,criteria];Select[Qs,inpoly[lfs,Pin]]]
posQ[q_,lfs_]:=Module[{vals,pos},vals=Map[#[q]&,lfs];pos=Flatten[Position[Map[(-.000001<#<.000001)&,vals],True]];pos];
posQs[qs_,lfs_]:=If[Length[qs]>1,Map[posQ[#,lfs]&,qs],{}]
cc[p_,q_,r_]:=Cross[Append[q-p,0],Append[r-p,0]][[3]]>0
orderqs[qs_,p_]:=If[cc[qs[[1]],qs[[2]],p],qs,Reverse[qs]]
psabove[qs_,ps_]:=Select[ps,cc[qs[[1]],qs[[2]],#]&]
flap[P_,P0_,Ps_]:=Module[{n,sfns,qs,ff,pb,i1,i2,psflipped,part,flip},n=Length[Ps]-1;sfns=linfuns[Ps];ff=foldfn[P,P0];pb=perpbisfn[P,P0];qs=crease[P,P0,Mean[Ps],sfns];psflipped=Which[qs=={},{},True,qs=orderqs[qs,P];posqs=posQs[qs,sfns];{i1,i2}=Which[Length[posqs]<2||posqs[[1]]{}||posqs[[2]]{},{0,0},True,{posqs[[1,1]],posqs[[2,1]]}];psabove[qs,Table[Ps[[Mod[i2+j,n,1]]],{j,1,n}]]];part=Join[qs,psflipped];If[qs≠{},part=Append[part,qs[[1]]]];flip=Map[ff,part];{{FaceForm[White],Polygon[part]},{FaceForm[Red],Polygon[flip]}}]
creasefn[p_,P0_,Pin_,lfs_][s_]:=crease[p[s],P0,Pin,lfs]
creaselen[P_,P0_,Pin_,lfs_]:=Module[{Qs},Qs=crease[P,P0,Pin,lfs];If[Qs{},0,Norm[Qs[[1]]-Qs[[2]]]//N]]
creaselenfn[p_,P0_,Pin_,lfs_][s_]:=creaselen[p[s],P0,Pin,lfs]
vertfn[p_,P0_,Pin_,lfs_][s_]:=Line[{{s,0},{s,creaselen[p[s],P0,Pin,lfs]}}]
paper[R_,bndR_,t_,P0_,u_,crs_,n_,showenv_,env_,fldorcrs_,p_,part_,flip_,problem_,c_,d_,tminmax_]:=Module[{Qs,crses,crsmin,crsmax},Qs=crs[t];crses=Table[crs[c+(d-c)i/(n+1)],{i,1,n}];Show[{ParametricPlot[{0,0},{s,.001,.999},AxesTrue,PlotRange{{-17,17},{-17,17}},PlotLabelColumn[{Row[{," = (",NumberForm[P0[[1]],{6,2}],",",NumberForm[P0[[2]],{6,2}],")"}],Row[{"P = ",Style["p",Italic],"(",NumberForm[t,{5,3}],") = (",PaddedForm[p[t][[1]],{5,2}],",",PaddedForm[p[t][[2]],{5,2}],")"}]}]],Graphics[{R,bndR}],If[fldorcrs"fold",Graphics[{part,flip,Line[Qs]}],Graphics[{Arrow[{p[t],P0}],Thickness[.008],Dashed,Line[Qs]}]],ParametricPlot[p[s],{s,c,d},PlotStyle{Thickness[.015],Purple}],If[showenv,ParametricPlot[env[s],{s,c,d}],Graphics[{}]],If[problem"yes",crsmin=crs[tminmax[[1]]];crsmax=crs[tminmax[[2]]];Graphics[{Thick,Dashed,Red,Line[crsmin],Blue,Line[crsmax]}],Graphics[{}]],Graphics[{Black,Thin,Line[crses],PointSize[.04],Blue,Point[P0],Black,Point[p[t]]}]}]]
"P"
0