diff options
Diffstat (limited to 'Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r')
-rwxr-xr-x | Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r | 796 |
1 files changed, 497 insertions, 299 deletions
diff --git a/Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r b/Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r index 840f076cf8e..160710e857b 100755 --- a/Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r +++ b/Master/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r @@ -16,10 +16,54 @@ ######################################### -ThisVersion<- "KeTpic for R v5_2_4(20180615)" +ThisVersion<- "KeTpic for R v5_2_4(20181024)" print(ThisVersion) +# 20181024 +# Wireparadata debugged ( for DuL(DvL)=c(..) ) +# Nohiddenpara2 debugged (for SeL=Null ) +# 20181020 +# Setscaling changed ( Setscaling(scalex,scaley) supported ) +# 20181019 +# Arrowhead changed(debugged) ( for basic1.cs ) +# 20181017 +# Drwxy debugged (Doscaling) +# Arrowhead debugged (Unscaling removed) +# Paramplot debugged (Assign(fun,var,"t")) +# 20181015 +# Listplot debugged ( Unscaling implemented ) +# 20180929 +# Paramplot Plotdata, Spacecurve , Implicitplot changed +# ( Dt,dx not divided by N) +# Shade changed (Kyoukai => Joincrvs) +# 20180928 +# Paramplot changed ( case of stationary point) +# 20180901 +# Objcurve debugged ( Assign rewritten ) +# 20180820,21 +# Drwxy changed ( optional arguments added ) +# Setax changed (ARROWSIZE removed ) +# 20180812 +# Assign debugged ( case nchar(vname)>1) +# 20180808 +# Scalept3pt changed (ratio) +# 20180807 +# Reflect3pt,Reflect3data,Scale3pt,Scale3data added +# 20180717 +# Hatchdata debugged (width option) +# Enclosing debugged ( for closed curve ) +# 20180713 +# Enclosing2 debugged (for Lineplot: distance of pts added) +# 20180711 +# Enclosing2 debugged (length => Length) +# 20180707 +# Enclosing2 debugged (epspara) +# 20180706 +# Enclosing2 debugged (crv => c) +# Hatchdata changed ( Interval > *2 ) +# 20180621 +# Kyoukai debugged (1st point converted to matrix, length=>Length) # 20180615 # Assign changed (Replace function added) # 20180603 @@ -428,8 +472,8 @@ print(ThisVersion) XMIN<- -5 XMAX<- 5 YMIN<- -5 ; YMAX<- 5 -ZIKU<- "line" -ARROWSIZE<- 1 +ZIKU<- "l" +#ARROWSIZE<- 1 XNAME<- "$x$" XPOS<- "e" YNAME<- "$y$" @@ -475,8 +519,8 @@ Ketinit<- function(){ XMIN<<- -5 XMAX<<- 5 YMIN<<- -5 ; YMAX<<- 5 -ZIKU<<- "line" -ARROWSIZE<<- 1 +ZIKU<<- "l" +#ARROWSIZE<<- 1 XNAME<<- "$x$" XPOS<<- "e" YNAME<<- "$y$" @@ -916,11 +960,12 @@ Arrowdata<- function(...) ###################################### +# 2018.10.19 for new basic1.cs # 2013.11.13 No Intersect debugged -Arrowhead<-function(...) -{ ## Scaling is implemented - ## 12.01.08 Kirikomi +Arrowhead<-function(...){ + ## Scaling is implemented + ## 12.01.08 Kirikomi Eps=10^(-3) varargin<-list(...) Nargs<-length(varargin) @@ -959,60 +1004,56 @@ Arrowhead<-function(...) } Ookisa<-1000/2.54/MilliIn*Ookisa Theta<-Hiraki*pi/180 + P<- Doscaling(P) + Houkou<- Doscaling(Houkou) if(Nrow(Houkou)>1){ - P<- Doscaling(P) - Houkou<- Doscaling(Houkou) - Tmp<-Nearestpt(P,Houkou) - A<-Tmp[[1]] + Tmp<-Nearestpt(P,Houkou) #181019 (2lines) + P<- Tmp[[1]] I<-floor(Tmp[[2]]) if(I==1){# 180511 if(Norm(Ptend(Houkou)-Ptstart(Houkou))<Eps){ I=Numptcrv(Houkou) } } - G<-Circledata(c(P,Ookisa*cos(Theta)),N=10) #17.11.29 + G<-Circledata(c(P,Ookisa*cos(Theta)),"Num=10") #181019(2lines) Flg<- 0 # 13.11.13 JL<-seq(I,1,by=-1) for (J in JL){ - B<-Ptcrv(J,Houkou) - Tmp<-IntersectcurvesPp(Listplot(list(A,B)),G) #180510 - if(length(Tmp)>0){ - Flg<- 1 - break + Tmp1=matrix(c(P,Op(J,Houkou)),ncol=2,byrow=TRUE) #181019 +# Tmp<-IntersectcurvesPp(Tmp1,G,0.001,0.01) + Tmp<-IntersectcrvsPp(Tmp1,G) + if(Length(Tmp)>0){ + Houkou<-P-Op(1,Tmp[[1]]) + Flg<- 1 + break } - A<-B } if(Flg==0){ # 13.11.13 print("Arrowhead may be too large (no intersect)") return(P) } - Houkou<-P-Op(1,Tmp[[1]]) - Houkou<- Unscaling(Houkou) - P<- Unscaling(P) } - P<- Doscaling(P) - Houkou<- Doscaling(Houkou) Ev<--1/Norm(Houkou)*Houkou Nv<-c(-Ev[2],Ev[1]) if(length(grep("c",Str))>0){ - P<-P-0.5*Ookisa*cos(Theta)*Ev + P<- P-0.5*Ookisa*cos(Theta)*Ev } if(length(grep("b",Str))>0){ - P<-P-Ookisa*cos(Theta)*Ev + P<- P-Ookisa*cos(Theta)*Ev } - A<-P+Ookisa*cos(Theta)*Ev+Ookisa*sin(Theta)*Nv - B<-P+Ookisa*cos(Theta)*Ev-Ookisa*sin(Theta)*Nv + A<- P+Ookisa*cos(Theta)*Ev+Ookisa*sin(Theta)*Nv + B<- P+Ookisa*cos(Theta)*Ev-Ookisa*sin(Theta)*Nv if(length(grep("l",Str,fixed=TRUE))>0){ - Tmp<-Listplot(list(A,P,B)) + Tmp<- matrix(c(A,P,B),ncol=2,byrow=TRUE)#181019(2lines) Tmp1<- Unscaling(Tmp) Drwline(Tmp1,Futosa) } else{ C<- P+(1-Cut)*((A+B)/2-P) # 12.01.07 - Tmp<- Listplot(list(A,P,B,C,A)) # 12.01.07 + Tmp<- matrix(c(A,P,B,C,A),ncol=2,byrow=TRUE) #181019(2lines) Tmp1<- Unscaling(Tmp) Shade(Tmp1) - Tmp=Listplot(c(A,P,B,C,A,P)) # 15.6.20 + Tmp= matrix(c(A,P,B,C,A,P),ncol=2,byrow=TRUE)#181019(2lines) Tmp1=Unscaling(Tmp) Drwline(Tmp1,0.1) # 15.06.11, 15.06.14 } @@ -1151,14 +1192,17 @@ Arrowline<- function(...) R<- P+Yapos*(Q-P) Tmp=Q-Unscaling(0.2*Ookisa/2*(Q-P)/Norm(Q-P)) # 15.10.24 Drwline(Listplot(c(P,Tmp)),Futosa) + Tmp=SCALEY + Setscaling(1) Arrowhead(R,Q-P,Ookisa,Hiraki,Futosa,Cutstr,Str) + Setscaling(Tmp) } ######################################### Assign<- function(...){ Replace=function (vname,rep,str){#180615from - opv=c("+","-","*","/","(",")","=","<",">",""," ") + opv=c("+","-","*","/","(",")","=","<",">",""," ",",") #180812 out="" start=1 Tmp=gregexpr(vname,str,fixed=TRUE) @@ -1166,15 +1210,16 @@ Assign<- function(...){ if(min(Vp)>0){ for(j in Vp){ if(j==1){bf=""}else{bf=substring(str,j-1,j-1)} - if(j==nchar(str)){af=""}else{af=substring(str,j+1,j+1)} + Tmp=j+nchar(vname)-1 #180812(2lines) + if(Tmp==nchar(str)){af=""}else{af=substring(str,Tmp+1,Tmp+1)} tmp1=length(intersect(bf,opv)) tmp2=length(intersect(af,opv)) - tmp=substring(str,start,j) + tmp=substring(str,start,j+nchar(vname)-1) #180812 if((tmp1>0)&&(tmp2>0)){ tmp=gsub(vname,rep,tmp,fixed=TRUE) } out=paste(out,tmp,sep='') - start=j+1 + start=j+nchar(vname) #180812 } } out=paste(out,substring(str,start,nchar(str)),sep='') @@ -1261,13 +1306,21 @@ Assign<- function(...){ } } } + +FlagL<<- 0 + for (I in seq(1,length(L),by=2)){ Vname<- L[[I]] Val<- L[[I+1]] if(mode(Val)=="numeric"){ - if(Nrow(Val)==1){ + if(Nrow(Val)==1){ for (K in Looprange(1,length(Val))){ - Tmp<- paste(Vname,"[", as.character(K),"]",sep="") + if(length(Val)==1){ + Tmp<- Vname + } + else{ + Tmp<- paste(Vname,"[", as.character(K),"]",sep="") + } if(mode(Val[K])=="numeric"){ Tmp1<- paste("(",as.character(Val[K]),")",sep="") } @@ -2373,24 +2426,69 @@ Drwpt<-function(...) ###################################################### -Drwxy<-function(...) -{ +Drwxy<-function(...){ #180820 varargin<-list(...) Nargs <- length(varargin) - Tmp<-grep("arrow", ZIKU) - if(length(Tmp)>0) - { - Arrowline(c(XMIN,GENTEN[2]),c(XMAX,GENTEN[2]),ARROWSIZE) - Arrowline(c(GENTEN[1],YMIN),c(GENTEN[1],YMAX),ARROWSIZE) + Origin=GENTEN + Origins=Doscaling(Origin) #181016 + Xrng=c(XMIN,XMAX) + Yrng=c(YMIN,YMAX) + Tmp1=Doscaling(c(XMIN,YMIN)) #181017from + Tmp2=Doscaling(c(XMAX,YMAX)) + Xrngs=c(Tmp1[1],Tmp2[1]) + Yrngs=c(Tmp1[2],Tmp2[2]) #181017from + Ziku=ZIKU #180821from + Xname=XNAME + Xpos=XPOS + Yname=YNAME + Ypois=YPOS + Oname=ONAME + Opos=OPOS #180821to + for(J in Looprange(1,Nargs)){ + Tmp=strsplit(varargin[[J]],"=") + Tmp=Tmp[[1]] + Tmp1=toupper(substring(Tmp[1],1,1)) + Tmp2=Tmp[2] + if(Tmp1=="O"){ + Origin=eval(parse(text=Tmp2)) + } + if(Tmp1=="X"){ + Xrng=eval(parse(text=Tmp2)) + } + if(Tmp1=="Y"){ + Yrng=eval(parse(text=Tmp2)) + } + if(Tmp1=="A"){ #180821from + if(substring(Tmp2,1,1)=="c"){ + Tmp2=substring(Tmp2,3,nchar(Tmp2)-1) + } + Tmp2=gsub(",","','",Tmp2,fixed=TRUE) + Tmp2=paste("'",Tmp2,"'",sep="") + Tmp=paste("Setax(",Tmp2,")",sep="") + eval(parse(text=Tmp)) #180821to + } + } + Xrng=Xrng+Origin[1] + Yrng=Yrng+Origin[2] + Xrngs=Xrngs+Origins[1] #181016(2lines) + Yrngs=Yrngs+Origins[2] + Tmp<- substring(ZIKU,1,1) #180821 + if(Tmp=="a") + { + Tmp=substring(ZIKU,2,nchar(ZIKU)) + if(nchar(Tmp)==0){Tmp=1}else{Tmp=eval(parse(text=Tmp))} + Arrowline(c(Xrngs[1],Origins[2]),c(Xrngs[2],Origins[2]),Tmp)#181016(2lines) + Arrowline(c(Origins[1],Yrngs[1]),c(Origins[1],Yrngs[2]),Tmp) } else { - Drwline(Listplot(c(XMIN,GENTEN[2]),c(XMAX,GENTEN[2]))) - Drwline(Listplot(c(GENTEN[1],YMIN),c(GENTEN[1],YMAX))) + Drwline(Listplot(c(Xrngs[1],Origins[2]),c(Xrngs[2],Origins[2])))#181016(2lines) + Drwline(Listplot(c(Origins[1],Yrngs[1]),c(Origins[1],Yrngs[2]))) } - Letter(c(XMAX,GENTEN[2]),XPOS,XNAME) - Letter(c(GENTEN[1],YMAX),YPOS,YNAME) - Letter(GENTEN,OPOS,ONAME); + Letter(c(Xrng[2],Origin[2]),XPOS,XNAME) + Letter(c(Origin[1],Yrng[2]),YPOS,YNAME) + Letter(Origin,OPOS,ONAME) + Setax(Ziku,Xname,Xpos,Yname,Ypois,Oname,Opos) #180821 } ########################################## @@ -3016,7 +3114,8 @@ Hatchdata<- function(...) ShaL<- list() Nargs<- length(varargin) Kakudo<- 45 - Kankaku<- 0.125*1000/2.54/MilliIn +# Kankaku<- 0.125*1000/2.54/MilliIn + Kankaku<- 0.25*1000/2.54/MilliIn #180706 Tmp<- Doscaling(c(XMIN,YMIN)) Xmn<- Tmp[1]; Ymn<- Tmp[2] Tmp<- Doscaling(c(XMAX,YMAX)) @@ -3034,7 +3133,7 @@ Hatchdata<- function(...) Kakudo<- varargin[[N+1]] if(N==Nargs-2) { - Kankaku<- 0.125*varargin[[Nargs]] + Kankaku<- Kankaku*varargin[[Nargs]] #180716 } } NaitenL<- varargin[[1]] @@ -3944,19 +4043,19 @@ Kyoukai<- function(...) Eps<- 10.0^(-4) #17.09.24 PLall<- list() Sflg<- 0 - N<- length(DataL) + N<- Length(DataL) #180621 for (I in Looprange(1,N)){ Data<- Op(I, DataL) - Tmp<- Op(length(Data),Data) - if(mode(Tmp)=="numeric" && Nrow(Tmp)==1 && length(Tmp)>1){ - Rg<-Tmp ; Nd<-length(Data)-1 + Tmp<- Op(Length(Data),Data) + if(mode(Tmp)=="numeric" && Nrow(Tmp)==1 && Length(Tmp)>1){ #180621 + Rg<-Tmp ; Nd<- Length(Data)-1 #180621 } else{ if(mode(Tmp)=="character"){ - Rg<- Tmp ; Nd<-length(Data)-1 + Rg<- Tmp ; Nd<- Length(Data)-1 #180621 } else{ - Rg<- "c" ; Nd<-length(Data) + Rg<- "c" ; Nd<- Length(Data) #180621 } } for (J in Looprange(1,Nd)){ @@ -3977,7 +4076,7 @@ Kyoukai<- function(...) P<- Ptstart(Tmp) Q<- Ptend(Tmp) if(Norm(P2-P)>Eps && Norm(P2-Q)>Eps){ - Tmp< Length(PL) + Tmp< Length(PL) #180621 PL<-PL[Tmp:1,] Pfirst<- Ptstart(PL) Plast<- Ptend(PL) @@ -3986,11 +4085,11 @@ Kyoukai<- function(...) } else{ if(Norm(P1-Plast)<Eps){ - Stp<-1; Ks<-2; Ke=Length(Points) + Stp<-1; Ks<-2; Ke=Length(Points) #180621 } else{ if(Norm(P2-Plast)<Eps) { - Stp<- -1; Ks<-Length(Points)-1; Ke=1 + Stp<- -1; Ks<-Length(Points)-1; Ke=1 #180621 } else{ Tmp<-Appendrow(PL,c(Inf,Inf)) @@ -3998,7 +4097,7 @@ Kyoukai<- function(...) Sflg<- 1 Pfirst<- P1 Plast<- P2 - Stp<- 1; Ks<- Length(Points)-1; Ke<- 1 + Stp<- 1; Ks<- Length(Points)-1; Ke<- 1 #180621 } } for (K in seq(Ks,Ke, by=Stp)){ @@ -4009,7 +4108,7 @@ Kyoukai<- function(...) } } if(Norm(Pfirst-Plast)>Eps){ - Np<- Length(PL) + Np<- Length(PL) #180621 if(Rg=="c"){ Tmp<- Appendrow(PL,Pfirst) PL<- Tmp @@ -4046,7 +4145,7 @@ Kyoukai<- function(...) Tmp<- Appendrow(Tmp,Q) PL<- Appendrow(Tmp,Pfirst) } - else if(mode(Rg)=="numeric" && Nrow(Rg)==1 && length(Rg)>1){ + else if(mode(Rg)=="numeric" && Nrow(Rg)==1 && Length(Rg)>1){ #180621 Tmp<- Kukeiwake(PL) Tmp1<- Op(1,Tmp) Tmp2<- Naigai(Rg,list(Tmp1)) @@ -4058,7 +4157,7 @@ Kyoukai<- function(...) } } } - Tmp<- Ptstart(PL) + Tmp<- matrix(Ptstart(PL),nrow=1) #180621 for (J in Looprange(2,Length(PL))){ P<- Op(J,PL) Q<- Op(Length(Tmp),Tmp) @@ -4070,7 +4169,7 @@ Kyoukai<- function(...) PL<-Tmp PLall<-c(PLall,list(PL)) } - if(length(PLall)==1 && Sflg==0){ + if(Length(PLall)==1 && Sflg==0){ Tmp<- Op(1,PLall) # Tmp<- Op(1,Tmp) if(Norm(Ptstart(Tmp)-Ptend(Tmp))>Eps0){ @@ -4249,34 +4348,27 @@ V<- Mag/Norm(B-A)*(B-A) ## 10.12.04 from here ################################ -Listplot<-function(...) -{ +Listplot<-function(...){ varargin<-list(...); Z<-c(); - for (I in 1:length(varargin)) - { + for (I in 1:length(varargin)){ Data<-varargin[[I]]; - if(mode(Data)=="numeric") - { - if(class(Data)=="numeric") - { - Tmp<-matrix(Data,nrow=2); - Tmp<-t(Tmp); - Z<-Appendrow(Z,Tmp) + if(mode(Data)=="numeric"){ + if(class(Data)=="numeric"){ + Tmp<- matrix(Data,nrow=2); + Tmp<- t(Tmp); + Z<-Appendrow(Z,Unscaling(Tmp)) #181015 + }else{ + Z<-Appendrow(Z,Unscaling(Data)) #181015 } - else - Z<-Appendrow(Z,Data) - } - else - { - for (J in 1:length(Data)) - { + }else{ + for (J in 1:length(Data)){ Tmp<-Data[[J]]; - Z<-Appendrow(Z,Tmp) + Z<-Appendrow(Z,Unscaling(Tmp)) #181015 } } - } - return(Z) + } + return(Z) } ############################## @@ -5124,9 +5216,11 @@ Paramplot<- function(...) Nargs<- length(varargin) Fnflg<- 0 Fnstr<- varargin[[1]]; Is=2 - Fnstr=Assign(Fnstr) #180510(for KeTCindy) Rgstr<- varargin[[Is]]; Is<- Is+1 - Rgstr=Assign(Rgstr) #180510(for KeTCindy) + Tmp=strsplit(Rgstr,"=") #181017from + Var=Tmp[[1]][1] + Fnstr=Assign(Fnstr,Var,"t") + Rgstr=Assign(Rgstr,Var,"t") #181017from Range<- c(0,2*pi) N<- 50 # Numpoints E<-c() # Exclusions @@ -5156,7 +5250,7 @@ Paramplot<- function(...) Rng<- c(0,2*pi) } T1<- Rng[1]; T2<- Rng[2] - Dt<- (T2-T1)/N #17.09.22 + Dt<- (T2-T1) #180929 if(Fnflg==0) { Str<- gsub(Vname,"t",Fnstr) @@ -5176,9 +5270,8 @@ Paramplot<- function(...) Tmp<- sort(E) E<- E[length(Tmp):1] Ke<- 1 -# for (t in seq(T1, T2+Eps, by=Dt)){#18.02.05 for(jj in 1:(N+1)){ - t=T1+(jj-1)*Dt + t=T1+(jj-1)*Dt/N #180929 Pa<- c() if(t-E[Ke]< Eps) { @@ -5210,37 +5303,26 @@ Paramplot<- function(...) } Ke<-Ke+1 } - if(length(Pa)>0) - { - if(Pa[1]==Inf) - { + if(length(Pa)>0){ + if(Pa[1]==Inf){ Tmp<-Appendrow(P,Pa) P<-Tmp - } - else - { - if(Nrow(P)==0) - { + }else{ + if(Nrow(P)==0){ Tmp<- Appendrow(P,Pa) P<-Tmp - } - else - { + }else{ Tmp<- Op(Nrow(P),P) - if(Tmp[1]==Inf) - { + if(Tmp[1]==Inf){ Tmp<- Appendrow(P,Pa) P<- Tmp - } - else - { - if(Norm(Tmp-Pa)<D) - { - Tmp<-Appendrow(P,Pa) - P<-Tmp - } - else - { + }else{ + if(Norm(Tmp-Pa)<D){ + if(Norm(Tmp-Pa)>Eps){ #180928 + Tmp<-Appendrow(P,Pa) + P<-Tmp + } #180928 + }else{ Tmp<- Appendrow(P,c(Inf,Inf),Pa) P<- Tmp } @@ -5375,11 +5457,11 @@ Plotdata<- function(...) } } X1<- Rng[1]; X2<- Rng[2] - dx<- (X2-X1)/N # 17.09.22 + dx<- (X2-X1) #180929 if(Fnflg==0){ Str<- gsub(Vname,"x",Fnstr,fixed=TRUE) } - if(abs(dx)<Eps){ # Scilab 16.12.13 + if(abs(dx/N)<Eps){ #180929 x=X1 P=c(X1,eval(parse(text=Str))) return(P) @@ -5394,7 +5476,9 @@ Plotdata<- function(...) Tmp<- sort(E) E<- E[length(Tmp):1] Ke<- 1 - for (x in seq(X1,X2,by=dx)){ +# for (x in seq(X1,X2,by=dx)){ + for (J in 0:N){ #180929 + x=X1+dx*J/N #180929 if(nchar(Exfun)>0){ Tmp<-eval(parse(text=Exfun)) if(abs(Tmp)<Eps){ @@ -6587,21 +6671,14 @@ Setax<- function(...) { varargin<- list(...) Nargs<- length(varargin) - if(Nargs==0){ - if(ZIKU=="line"){ - Tmp<- "," - } - else{ - Tmp<- paste("(Arrowsize=", as.character(ARROWSIZE),"),",sep="") - } - Str<- paste(ZIKU,Tmp,XNAME,",",XPOS,",",sep="") + if(Nargs==0){ #180821(next 2 lines) + Str<- paste(ZIKU,",",XNAME,",",XPOS,",",sep="") Str<- paste(Str,YNAME,",",YPOS,",",ONAME,",",OPOS,sep="") return(Str) } ArgL<- c() - Is<- 1 Tmp<- varargin[[1]] - if(mode(Tmp)=="numeric" && length(Tmp)==1){ + if(is.numeric(Tmp)){ #180821 Is<- varargin[[1]] ArgL<- c() for (I in Looprange(1,Is-1)){ @@ -6611,50 +6688,18 @@ Setax<- function(...) ArgL<- c(ArgL,varargin[[I]]) } } - else{ - if(Nargs==1){ - ArgL<- c(varargin[[1]]) - } - else{ - Tmp<- varargin[[2]] - if(mode(Tmp)=="numeric" && length(Tmp)==1){ - ARROWSIZE<<-Tmp - ArgL<- c(varargin[[1]]) - for (I in Looprange(3,Nargs)){ - ArgL<- c(ArgL,varargin[[I]]) - } - } - else{ - ArgL<- c() - for (I in 1:Nargs){ - ArgL<- c(ArgL,varargin[[I]]) - } - } + else{ #180821from + for (I in Looprange(1,Nargs)){ + ArgL<- c(ArgL,varargin[[I]]) } } for (I in Looprange(length(ArgL)+1,7)){ ArgL<- c(ArgL,"") - } - Zk<- ArgL[1] - if(nchar(Zk)>0){ - ZL<-substr(Zk,2,nchar(Zk)) - Zk<-substr(Zk,1,1) - if(nchar(ZL)>0){ - ARROWSIZE<<- as.numeric(ZL) - } - } + } #180821to Xn<- ArgL[2]; Xp<- ArgL[3] Yn<- ArgL[4]; Yp<- ArgL[5] - Genn<- ArgL[6]; Genp<- ArgL[7] - if(nchar(Zk)>0){ - C<- Zk - if(C=="a"){ - ZIKU<<- "arrow" - } - else{ - ZIKU<<- "line" - } - } + On<- ArgL[6]; Op<- ArgL[7] + ZIKU<<- ArgL[1] #180821 if(nchar(Xn)>0){ XNAME<<- paste("$",Xn,"$",sep="") } @@ -6667,11 +6712,11 @@ Setax<- function(...) if(nchar(Yp)>0){ YPOS<<-Yp } - if(nchar(Genn)>0){ - ONAME<<- Genn + if(nchar(On)>0){ + ONAME<<- On } - if(nchar(Genp)>0){ - OPOS<<- Genp + if(nchar(Op)>0){ + OPOS<<- Op } Out<- ""; } @@ -6743,41 +6788,39 @@ Setorigin<- function(...) ################################ -Setscaling<- function(...) -{ +Setscaling<- function(...){ varargin<- list(...) Nargs<- length(varargin) - if(Nargs==0) - { - return(c(SCALEY,LOGX,LOGY)) + if(Nargs==0){ + return(c(SCALEX,SCALEY,LOGX,LOGY)) } - for (I in 1:Nargs) - { + Tmp=varargin[[1]] #181020from + if((Nargs==1)&&(is.numeric(Tmp))){ + SCALEY<<- Tmp + return(invisible(c(SCALEX,SCALEY,LOGX,LOGY))) + } + nCtr=1 #181020to + for (I in 1:Nargs){ Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric") - { - SCALEY<<- Tmp + if(mode(Tmp)=="numeric"){ + if(nCtr==1)SCALEX<<- Tmp #181020(2llines) + if(nCtr==2)SCALEY<<- Tmp + nCtr=nCtr+1 } - if(mode(Tmp)=="character") - { - if(Tmp=="l") - { + if(mode(Tmp)=="character"){ + if(Tmp=="l"){ LOGX<<- 0 LOGY<<- 1 - } - else if(Tmp=="ll") - { + }else if(Tmp=="ll"){ LOGX<<- 1 LOGY<<- 1 - } - else - { + }else{ LOGX<<- 0 LOGY<<- 0 } } } - Tmp<- c(SCALEY,LOGX,LOGY); + Tmp<- c(SCALEX,SCALEY,LOGX,LOGY) } ######################################### @@ -7009,51 +7052,35 @@ Shade<- function(...) } } if(Iroflg==1){ - if(Wfile=="default") - cat(Str,"%\n",file="",append=TRUE,sep="") - else - cat(Str,"%\n",file=Wfile,append=TRUE,sep="") } } Tmp<- varargin[[1]] - Data<- Kyoukai(Tmp) - for (I in Looprange(1, length(Data))){ +# Data<- Kyoukai(Tmp) + Data= Joincrvs(Tmp) #180929from + Data=list(Data) #180929to + for (I in Looprange(1, Length(Data))){ #180621 PL<- Op(I,Data) + PL=Appendrow(PL,Op(1,PL)) #180929 Mojisu<- 0 - for (J in 1:Nrow(PL)){ + for (J in Looprange(1,Length(PL))){ P<- Doscaling(Op(J,PL)) X<- as.character(round(MilliIn*P[1])) Y<- as.character(-round(MilliIn*P[2])) Str<- paste("\\special{pa ",X," ",Y,"}",sep="") - if(Wfile=="default") - cat(Str,file="",append=TRUE,sep="") - else - cat(Str,file=Wfile,append=TRUE,sep="") + cat(Str,file=Wfile,append=TRUE,sep="") Mojisu<- Mojisu+nchar(Str) if(Mojisu>80){ - if(Wfile=="default") - cat("%\n",file="",append=TRUE,sep="") - else - cat("%\n",file=Wfile,append=TRUE,sep="") + cat("%\n",file=Wfile,append=TRUE,sep="") Mojisu<- 0 } } Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") Str2<- paste("\\special{ip}%\n",sep="") - if(Wfile=="default"){ - cat(Str1,file="",append=TRUE,sep="") - cat(Str2,file="",append=TRUE,sep="") - } - else{ - cat(Str1,file=Wfile,append=TRUE,sep="") - cat(Str2,file=Wfile,append=TRUE,sep="") - } + cat(Str1,file=Wfile,append=TRUE,sep="") + cat(Str2,file=Wfile,append=TRUE,sep="") } if(Iroflg==1){ - if(Wfile=="default") - cat("}%\n",file="",append=TRUE,sep="") - else - cat("}%\n",file=Wfile,append=TRUE,sep="") + cat("}%\n",file=Wfile,append=TRUE,sep="") } } @@ -9752,6 +9779,142 @@ Projpers<- function(...){ } ######################################### +# 180807 + +Reflect3data<- function(...){ + varargin<-list(...) + Nargs<- length(varargin) + Pd3<- varargin[[1]] + VL<- varargin[[2]] + if(Mixtype(Pd3)==1){ + Pd3<- list(Pd3) + } else if(Mixtype(Pd3)==3){ + Tmp<- list() + for (I in Looprange(1,Length(Pd3))){ + Tmp<- c(Tmp,Op(I,Pd3)) + } + Pd3<- Tmp + } + Out<- list() + for (I in Looprange(1,Length(Pd3))){ + PD<- Op(I,Pd3) + Ans<- c() + for (J in Looprange(1,Nrow(PD))){ + if(is.matrix(PD)){ + P<- PD[J,] + } + else{ + P<- PD + } + Tmp<- Reflect3pt(P,VL) + Ans<- rbind(Ans,Tmp) + } + rownames(Ans)<- 1:Nrow(Ans) + Out<- c(Out,list(Ans)) + } + if(Length(Out)==1){ + Out<- Op(1,Out) + } + return(Out) +} + +####################################### + +Reflect3pt<- function(...){ + varargin<-list(...) + Nargs<-length(varargin) + P<- varargin[[1]] + VL<- varargin[[2]] + if(Length(VL)==1){ + Ans=2*Op(1,VL)-P + } + if(Length(VL)==2){ + V1=Op(1,VL) + V2=Op(2,VL) + V3=(V2-V1)/Norm(V2-V1) + Tmp=V1+Dotprod(P-V1,V3)*V3 + Ans=2*Tmp-P + } + if(Length(VL)==3){ + V1=Op(1,VL) + V2=Op(2,VL) + V3=Op(3,VL) + Tmp=Crossprod(V2-V1,V3-V1) + Tmp1=P-Dotprod(Tmp, P-V1)/Norm(Tmp)^2*Tmp + Ans=2*Tmp1-P + } + return(Ans) +} + +######################################### +# 180807 + +Scale3data<- function(...){ + varargin<-list(...) + Nargs<- length(varargin) + Pd3<- varargin[[1]] + R<- varargin[[2]] + C<- varargin[[3]] + C<- c(0,0,0) + if(Nargs>=3){ + C<- varargin[[3]] + } + if(Mixtype(Pd3)==1){ + Pd3<- list(Pd3) + } else if(Mixtype(Pd3)==3){ + Tmp<- list() + for (I in Looprange(1,Length(Pd3))){ + Tmp<- c(Tmp,Op(I,Pd3)) + } + Pd3<- Tmp + } + Out<- list() + for (I in Looprange(1,Length(Pd3))){ + PD<- Op(I,Pd3) + Ans<- c() + for (J in Looprange(1,Nrow(PD))){ + if(is.matrix(PD)){ + P<- PD[J,] + } + else{ + P<- PD + } + Tmp<- Scale3pt(P,R,C) + Ans<- rbind(Ans,Tmp) + } + rownames(Ans)<- 1:Nrow(Ans) + Out<- c(Out,list(Ans)) + } + if(Length(Out)==1){ + Out<- Op(1,Out) + } + return(Out) +} + +####################################### + +Scale3pt<- function(...){ + varargin<-list(...) + Nargs<-length(varargin) + P<- varargin[[1]] + R<- varargin[[2]] + if(length(R)==1){ #180808from + R=c(R,R,R) + } #180808to + C<- c(0,0,0) + if(Nargs>=3){ + C<- varargin[[3]] + } + X1=P[1]; Y1=P[2]; Z1=P[3] + Cx=C[1]; Cy=C[2]; Cz=C[3] + X2=Cx+R[1]*(X1-Cx) + Y2=Cy+R[2]*(Y1-Cy) + Z2=Cz+R[3]*(Z1-Cz) + Ans=c(X2,Y2,Z2) + return(Ans) +} + +######################################### # 11.08.27 # 14.03.23 Debugged "center" @@ -9785,7 +9948,7 @@ Rotate3data<- function(...){ } else{ P<- PD - } + } Tmp<- Rotate3pt(P,W1,W2,C) # 14.03.23 Ans<- rbind(Ans,Tmp) } # 11.08.27 @@ -9886,6 +10049,45 @@ Rotate3pt<- function(...){ return(Ans) } +################################# + +Translate3data<- function(...){ + varargin<- list(...) + Nargs<- length(varargin) + Pd3<- varargin[[1]] + Mv<- varargin[[2]] + if(mode(Mv)=="numerice" && length(Mv)==1){ + Mv<- c(varargin[[2]],varargin[[3]],varargin[[4]]) + } + if(Mixtype(Pd3)==1){ + Pd3<- list(Pd3) + } + else if(Mixtype(Pd3)==3){ + Tmp<-list() + for(I in Looprange(1,Mixlength(Pd3))){ + Tmp<- c(Tmp, Op(I,Pd3)) + } + Pd3<- Tmp + } + Out<- list() + for(I in Looprange(1,Mixlength(Pd3))){ + PD<- Op(I,Pd3) + PD<- rbind(c(),PD) + Ans<- c() + for(J in Looprange(1,Nrow(PD))){ + P<- PD[J,] + Tmp<- P+Mv + Ans<- rbind(Ans,Tmp) + } + rownames(Ans)<- 1:Nrow(Ans) + Out<- c(Out,list(Ans)) + } + if(Mixlength(Out)==1){ + Out<- Op(1,Out) + } + return(Out) +} + ###################################### Setangle<- function(...){ @@ -10198,11 +10400,11 @@ Spacecurve<- function(...){ Rng<- c(XMIN,XMAX) } T1<- Rng[1]; T2<- Rng[2] - Dt<- (T2-T1)/N #17.09.22 + Dt<- (T2-T1) #180929 Str<- gsub(Vname,"t",Fnstr) Str=gsub("[","c(",Str,fixed=TRUE) #17.12.22(2lines) Str=gsub("]",")",Str,fixed=TRUE) - if(abs(Dt)<Eps){ # 16.12.13 + if(abs(Dt/N)<Eps){ #180929 t=T1 P=eval(parse(text=Str)) return(P) @@ -10213,7 +10415,7 @@ Spacecurve<- function(...){ E<- sort(E,decreasing=FALSE) Ke<- 1 for(jj in 1:(N+1)){ - t=T1+(jj-1)*Dt + t=T1+(jj-1)*Dt/N #180929 Pa<- c() if(t-E[Ke]< Eps){ Pa<- eval(parse(text=Str)) @@ -10284,45 +10486,6 @@ Spaceline<- function(...){ return(Z) } -################################# - -Translate3data<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Pd3<- varargin[[1]] - Mv<- varargin[[2]] - if(mode(Mv)=="numerice" && length(Mv)==1){ - Mv<- c(varargin[[2]],varargin[[3]],varargin[[4]]) - } - if(Mixtype(Pd3)==1){ - Pd3<- list(Pd3) - } - else if(Mixtype(Pd3)==3){ - Tmp<-list() - for(I in Looprange(1,Mixlength(Pd3))){ - Tmp<- c(Tmp, Op(I,Pd3)) - } - Pd3<- Tmp - } - Out<- list() - for(I in Looprange(1,Mixlength(Pd3))){ - PD<- Op(I,Pd3) - PD<- rbind(c(),PD) - Ans<- c() - for(J in Looprange(1,Nrow(PD))){ - P<- PD[J,] - Tmp<- P+Mv - Ans<- rbind(Ans,Tmp) - } - rownames(Ans)<- 1:Nrow(Ans) - Out<- c(Out,list(Ans)) - } - if(Mixlength(Out)==1){ - Out<- Op(1,Out) - } - return(Out) -} - ############################################### Xyzax3data<- function(Xrange,Yrange,Zrange){ @@ -11490,17 +11653,17 @@ Implicitplot<- function(...){ #180402 Rngy=eval(parse(text=Tmp[2])) Tmp=paste("Impfun<- function(",Varx,",",Vary,"){",Fn,"}",sep="") eval(parse(text=Tmp)) - dx=(Rngx[2]-Rngx[1])/Mdv - dy=(Rngy[2]-Rngy[1])/Ndv + dx=(Rngx[2]-Rngx[1]) #180929 + dy=(Rngy[2]-Rngy[1]) #180929 out=list() for(jj in 1:Ndv){ - yval1=Rngy[1]+(jj-1)*dy - yval2=Rngy[1]+jj*dy + yval1=Rngy[1]+(jj-1)*dy/Ndv #180929 + yval2=Rngy[1]+jj*dy/Ndv #180929 xval1=Rngx[1] eval11=Impfun(xval1,yval1) eval12=Impfun(xval1,yval2) for(ii in 1:Mdv){ - xval2=Rngx[1]+ii*dx + xval2=Rngx[1]+ii*dx/Mdv #180929 eval21=Impfun(xval2,yval1) eval22=Impfun(xval2,yval2) pL=list(c(xval1,yval1));vL=c(eval11) @@ -12135,18 +12298,18 @@ Objcurve<- function(...){ if(Nargs>=3){ Np=Args[[3]] } - Assign("Sz",Sz) +# Assignadd("Sz",Sz) #180901 if(Pstr=="xy"){ Vz=c(0,0,1) - Fs=Assign("c(Sz*cos(t),Sz*sin(t),0)") + Fs=Assign("c(Sz*cos(t),Sz*sin(t),0)","Sz",Sz) #180901 } if(Pstr=="yz"){ Vz=c(1,0,0) - Fs=Assign("c(0,Sz*cos(t),Sz*sin(t))") + Fs=Assign("c(0,Sz*cos(t),Sz*sin(t))","Sz",Sz) #180901 } if(Pstr=="zx"){ Vz=c(0,1,0) - Fs=Assign("c(Sz*sin(t),0,Sz*cos(t))") + Fs=Assign("c(Sz*sin(t),0,Sz*cos(t))","Sz",Sz) #180901 } Gc0=Spacecurve(Fs,"t=c(0,2*pi)",paste("Num=",as.character(Np),sep="")) P=PL[[1]]; Q=PL[[2]]; R=PL[[length(PL)-1]] @@ -12218,7 +12381,7 @@ Objcurve<- function(...){ } Objsymb<- function(Symb,Thick,Face,Dir){ - for(J in Looprange(1,length(Symb))){ + for(J in Looprange(1,Length(Symb))){ Objcurve(Op(J,Symb),Thick,Face,Dir) } } @@ -12750,6 +12913,7 @@ Enclosing2<- function(...){ Nargs=length(varargin) plist=varargin[[1]] Eps0=10^(-5) + epspara=1; #180707 Eps1=0.01 Eps2=0.1 Start=c() @@ -12757,10 +12921,11 @@ Enclosing2<- function(...){ for(ii in Looprange(2,Nargs)){ tmp=varargin[[ii]] if(length(tmp)>1){ -# Start=tmp + Start=tmp }else{ - if(flg==0){Eps1=tmp} - if(flg==1){Eps2=tmp} + if(flg==0){epspara=tmp} + if(flg==1){Eps1=tmp} + if(flg==2){Eps2=tmp} flg=flg+1 } } @@ -12788,41 +12953,46 @@ Enclosing2<- function(...){ plist=c(plist,list(tmp)) Start=tmp2 tst=1 -# flg=1 }else{ if(length(KL)==1){ tmp=Op(1,KL) tst=Op(2,tmp) - Start=crv(tst,Fdata) + Start=Op(1,tmp) #180706 } if(length(KL)>1){ - KL=Quicksort(KL,2) + KL=Quicksort(KL,2) #180706from if(length(Start)==0){ tmp=Op(1,KL) tst=Op(2,tmp) - Start=Pointoncurve(tst,Fdata) + Start=Op(1,tmp) }else{ tmp=c() - for(ii in Looprange(1,length(KL))){ - tmp=c(tmp,Norm(Op(1,KL[[ii]]-Start))) - } - tmp=min(tmp) tmp1=list() for(ii in Looprange(1,length(KL))){ tmp2=Op(1,KL[[ii]]) - if(Norm(tmp2-Start)==tmp){ - tmp1=c(tmp1,list(tmp2)) + flgsame=0 #180717from + for(jj in Looprange(1,length(tmp1))){ + if(Norm(tmp2-Op(jj,tmp1))<Eps1){ + flgsame=1 + break + } } + if(flgsame==0){ + tmp=c(tmp,Norm(Op(1,KL[[ii]])-Start)) + tmp1=c(tmp1,list(tmp2)) + } #180717to } - tmp=Op(1,tmp1) + tmp=order(tmp) + tmp=Op(tmp[1],KL) tst=Op(2,tmp) - Start=Pointoncurve(tst,Fdata) + Start=Op(1,tmp)#180706to } } } } if(flg==0){ t1=tst + p1=Pointoncurve(t1,Fdata)#180713 for(nn in Looprange(1,length(plist))){ Fdata=Op(nn,plist) if(nn==length(plist)){ @@ -12837,19 +13007,42 @@ Enclosing2<- function(...){ Gdata=Appendrow(tmp,Gdata) plist[[nxtno]]=Gdata t2=Length(Fdata) - ss=1 #18.02.02until + ss=1 #18.02.02to }else{ - tmp=Op(1,KL) - t2=Op(2,tmp) - ss=Op(3,tmp) +# KL=Quicksort(KL,2); #180706from +# for(j in Looprange(1,length(KL))){ +# tmp1=t1+epspara/50*Length(Fdata)#180713(2lines) +# tmp2=Op(2,KL[[j]]) +# if((tmp2>tmp1)||((tmp2>t1)&&(Norm(Op(3,KL[[j]])-p1)>Eps1))){ +# break +# } #180711,16 +# } +# t2=Op(2,KL[[j]]) +# p2=Pointoncurve(t2,Fdata)#180713 +# ss=Op(3,KL[[j]])# 180706to + tmp=c() #180711from + for(j in Looprange(1,length(KL))){ + tmp=c(tmp,Op(2,KL[[j]])) + } + tmp1=order(tmp) + tmp2=KL + KL=list() + for(j in tmp1){ + tmp=tmp2[[j]] + tmp3=t1+epspara/50*Length(Fdata) + tmp4=Op(2,tmp) + if((tmp4>tmp3)||((tmp4>t1)&&(Norm(Op(1,tmp)-p1)>Eps1))){ + KL=c(KL,list(tmp)) + } + } + t2=Op(2,KL[[1]]) + ss=Op(3,KL[[1]]) #180711from if(abs(t2-t1)<Eps0){ if(length(KL)>1){ tmp=Op(2,KL) t2=Op(2,tmp) ss=Op(3,tmp) }else{ -# println(text(nn)+" and "+text(nn+1)+" not intersect"); -# flg=1 } } } @@ -12861,8 +13054,9 @@ Enclosing2<- function(...){ tmp=tmp[2:Length(tmp),] AnsL=Appendrow(AnsL,tmp) } - t1=ss } + t1=ss + p1=Pointoncurve(t1,Gdata)#180713 } } return(AnsL) @@ -13713,10 +13907,14 @@ Nohiddenpara2<- function (Par,Fk,Uveq,Np,Eps1,Eps2){ FigkL=c(FigkL,list(Fk)) } } - Tmp=c() - for(I in Looprange(1,length(PaL)-1)){ - if(!Member(I,SeL)){ - Tmp=c(Tmp,I) + if(length(SeL)==0){#181024from + Tmp=Looprange(1,length(PaL)-1) + }else{ #181024to + Tmp=c() + for(I in Looprange(1,length(PaL)-1)){ + if(!Member(I,SeL)){ + Tmp=c(Tmp,I) + } } } SeL=Tmp @@ -14377,7 +14575,7 @@ Wireparadata<- function(...){ if(ctr==2){Eps2=tmp} } } - if(length(DuL)==1){ #180430 + if(!is.list(DuL)){ #181024 tmp1=DuL DuL=list() for(jj in Looprange(1,tmp1)){ @@ -14385,7 +14583,7 @@ Wireparadata<- function(...){ DuL=c(DuL,list(tmp)) } } - if(length(DvL)==1){ #180430 + if(!is.list(DvL)){ #181024 tmp1=DvL DvL=list() for(jj in Looprange(1,tmp1)){ |