From 97c498990768240db2126f56c5bb2a07014b3b88 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Wed, 18 Apr 2018 09:58:55 +0900 Subject: remove ketcindy, it is in main --- texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r | 14614 ------------------- 1 file changed, 14614 deletions(-) delete mode 100644 texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r (limited to 'texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r') diff --git a/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r b/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r deleted file mode 100644 index dc54682b..00000000 --- a/texmf-dist/scripts/ketcindy/ketlib/ketpiccurrent.r +++ /dev/null @@ -1,14614 +0,0 @@ -# Copyright (C) 2014 Setsuo Takato, KETCindy Japan project team -# -#This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see - - -######################################### - -ThisVersion<- "KeTpic for R v5_2_4(20180327)" - -print(ThisVersion) - -# 20180402 -# Implicitplot greatly changed -# 20180327 -# Kyoukai debugged -# 20180317 -# IntersectcurvesPp changed and debugged -# Intersectpartseg changed (Eps00 ) -# Collectsameseg added, Collectnear commented out -# 20180306 -# PthiddenQ,Meetpoints,Sfcutparadata changed (to avoid duplications ) -# Sfbdparadata changed ( for near points in Implicitdata ) -# Envelopedata, Evlpfun added -# 20180305 -# (for surface drwaings ) Eps => Eps1 -# 2018.02.27 -# Nohiddenpara2,Crvsfparadara debugged (Eps=>Eps0) -# 2018.02.26 -# Sfcutparadata changed -# Partcrv3 debugged -# Projcurve rewritten -# Nohiddenparadata debugged -# PthiddenQ debugged -# 2018.02.24 -# Sfcutdata added ( for functions ) -# Meetpoints debugged (case Norm(PtB-PtA) Paramoncrv ) -# 2018.02.05 -# Dotprod changed ( crossprod not used ) -# Intersectpartseg changed ( case of length of result =1) -# 2018.02.04 -# Diff added ( func, withvar, (varnamevalue1,... )) -# Funvalue added ( for an expression ) -# 2018.02.02 -# Enclosing2 changed ( for distant curves, startpt option removed ) -# 2018.02.01 -# Intersectline,Intersectseg,...,Intersectcuves added -# Quicksort added -# Enclosing2 added (incomplete) -# 2018.01.29 -# Length added -# 2017.12.24 -# Objpolyhedron added -# 2017.12.23 -# Objsymb, symb3data added -# Objrecs, Objpolygon debugged -# Objthicksurf added -# 2017.12.22 -# Openobj,Closeobj,Writeobjpoint,Printobjstr,Objname,Objsurf added -# Crossprod added -# Objjoin, Objcurve, Objrecs, Objpolygon, Objsymb added -# Spacecurve debugged -# 2017.12.17 -# Setunitlen debugged ( MEMORI ) -# 2017.12.13 -# ReadOutData debugged -# 2017.12.11 -# Enclosing debugged ( appendrow -> Appendrow ) -# 2017.11.29 -# Anglemark, Arrowhead, Ovaldata debugged ( Circldeta included ) -# 2017.11.27 -# Anglemark changed ( Scilab 16.12.29) -# Plotdata,Paramplot,Spacecurve changed ( Scilab 16.12.13) -# Enclosing changed ( Scilab 16.10.09) -# Arrowhead,Arrowline changed ( Scilab 15.06.11) -# Definecolor added ( Scilab 15.05.04) -# 2017.11.26 -# Exprrot, Letterrot debugged ( `) -# 2017.11.24 -# Deqplot debugged (Looprange) -# 2017.11.20 -# InWindow debugged (for length=1) -# 2017.10.28 -# Openfile changed (Creator) -# 2017.10.23 -# ReadOutData greatly changed -# 2017.10.11 -# Drwpt debugged (Flattenlist ) -# 2017.10.08 -# Bezier debugged ( Num ) -# 2017.10.07 -# ReadOutData debugged ( for null data ) -# 2017.10.06 -# Deqdata, Deqplot added -# Connectseg remade(bug) -# 2017.09.30 -# Bezierpt, Bezier added -# 2017.09.29 -# Ptcrv debugged -# 2017.09.28 -# Openfile changed -# 2017.09.24 -# Circledata debugged -# Kyoukai changed (Eps) -# Shade updated -# 2017.09.22 -# Setcolor changed -# Plotdata,Paramplot,Spacecurve changed (N-1 -> N) -# 2017.09.21 -# Shade changed (Sci 17.01.09) -# 2017.09.17 -# Ovaldata,Assignadd changed -# Dist added -# Cicledata changed -# Bowdata debugged (Circledata,etc) - -# 2015.11.05 -# WriteOutData changed - -# 2015.10.29 -# WriteOutData changed ( endmark //// ) - -# 2015.10.24 -# ReadOutData changed ( in case of listlength=1 ) - -# 2014.12.23 -# ReadOutData added - -# 2014.12.17 -# WriteOutData added - -# 2014.0905 -# Unscaling debugged MARKLENI => MARKLEN -# 2014.03.31 -# PhHiddenData added -# 2014.03.30 -# Facesdata changed ( for Hiddendata ) -# 2014.03.23 -# MARKLEN separated, Rotate3data debugged - -# 2013.12.19 -# Openfile, Closefile, Bowname, Bownamerot - -# 2013.11.13 -# Arrowhead, Arrowheaddata - -# 2013.08.07 -# Cancoordpara added - -# 2013.08.07 -# Integrate added - -# 2013.05.20 -# Openfile changed - -# 2013.05.03 -# Tabledata, Pointdata changed -# Dividetable, Partframe added - -# 2013.02.10 -# Ketinit added - -# 2012.01.07 -# Arrowline, Arrowhead ( Cut implemented ) - -# 2011.12.18 -# Framedata ( compliant for list ) - -# 2011.12.12 -# Skeletonparadata... ( Flattellist used) - -# 2011.11.27 -# drwboxframe - -# 2011.11.07 -# metacommands added - -# 2011.11.02 -# Joingraphics ( for list structure ) - -# 2011.08.24 -# Setcolor ( c(1,0,0,0.5) etc ) -# Rotate3data ( Point is available ) - -# 2011.07.19 -# Drwline, Letter, Expr -# Drwboxplot( etc ) min,max => outliners -# Drwline ( unfinished in the case of "integer" ) - -# 2011.06.25 -# joincrvs debugged - -# synchro with ketpict2e - -# 2011.06.01 -# Bowdata debugged - -#2011.05.28 -# Ratiocmyk, Setcolor ( new ) - -#2011.04.28 -# Htickmark, Vtickmark debugged - -#2011.03.08 -# Drwboxframe debugged -# Putrow, Putrowexpr debugged (Dpos ) - -#2011.03.02 -# Tabledata ( index of hline ), PutcoL, PutcoLexpr ( "r",...) debugged -# Texcom changed ( // => backslash ) - -#2011.01.07 -# Dividegraphics, Splinedat are changed significantly -# Readtextdata is changed - -#2011.01.04 -# Derivative, Integrate are added - -#2010.12.07 -# Translatedata, Scaledata, Reflectdata changed ( efficient for vector ) -# Rotatedata changed ( deg : logical ) -# HIstplotdata, Drwhistplot ( type => freq , fpplot (added) ) - -# 2010.12.04 -# WindispT changed ( tickmark ) -# Lineplot changed ( mag=> length ) -# Plotdata debugged ( 'E=fun', 'D=') -# Enclosing changed (return PD) - -# 2010.12.02 -# WindispT changed -# Makecurves debugged - -# 2010.11.27 -# Pointdata changed ( efficient for matrix and data.frame ) -# WindispT -# Setwindow ( decide from data ) -# Assign debugged ( strsplit => gsub(fixed=T)) - -# 2010.11.20 -# Flattenlist, WindispT -# Splinedata changed( efficient for data.frame ) - -#2010.08.19 ( Maybe not finished ) -# Stripblanks -# Fullformfunc, Sf3data - -#2010.08.17 -# Phparadata, Phpersdata, Phspersdata, Phsparadata -# Facesdata, MakeveLfaceL, Menkakusi2 -# Rotate3data -# Skeletonpersdata, Skeletonpers3data, Makeskeletonpersdata -# Embed - -#2010.08.16 -# Spacecurve changed -# CameracoordCurve, Partcrv3, Projpers, CameraCurve, -# Perspt, Xyzaxpersname, Invperspt, Zparapt, Zperspt - -# 2010.08.15 -# Phcutoffdata added - -# 2010.08.13 -# Phcutdata, Spacecurve debugged -# Setangle changed - -# 2010.08.09 -# Spacecurve -# Rotate3data, Rotate3pt -# Phcutdata - -# 2010.08.08 -# Implementing 3d -# Initangle, Setangle, Setpers, SetstereoL, SetstereoR -# Mixlength -# Spaceline, Projpara, ProjCurve, Parapt -# Xyzax3data, Xyzaxparaname -# Cancoordpers, Invparapt, ProjcoordCurve -# Skeletonparadata, Skeletonpara3data, Makeskeletondata, Kukannozoki - -# 2010.07.25 -# Rotatedata changed -# Drwline changed (list of list) - -# 2010.04.09 -# Stat package added - -# 2010.04.02 -# Putcolexpr, Putrowexpr - -# 2010.04.02 - -# Windisp, Op changed -# Execmd added -# Texnewcmd, Texrenewcmd, Texend, -# Texctr, Texnewctr, Texsetctr -# Kyoukai debugged - -# 2010.01.20 -# Partcrv, Makeshasen : debugged - -# 2010.01.23 -# Ovaldata, Ovalbox added - -# 2010.01.27 -# Readtextdata changed -# Putrow, PutcoL debugged ( Putcol is OK) - -# 2010.01.31 -# Writetextdata added - -# 2010.02.12 -# Texvalctr, Texthectr added - -# 2010.02.22 -# Execmd changed - -# 2010.02.23 -# Op, Windisp changed - -# 2010.02.24 -# Execmd changed - -# 2010.03.07 -# Dotfilldata (Kosa>1) - -# 2010.03.21 -# Mixjoin -# Koutenlist (bug) - - -# 2010.03.24 -# Arrowhead ( bug in the case of "l" ) - -# 2010.03.28 -# Tabledata -# Diagcelldata ( New ) - -# 2010.03.30 -# Tabledata - -########################################### - -XMIN<- -5 -XMAX<- 5 -YMIN<- -5 ; YMAX<- 5 -ZIKU<- "line" -ARROWSIZE<- 1 -XNAME<- "$x$" -XPOS<- "e" -YNAME<- "$y$" -YPOS<- "n" -ONAME<- "O" -OPOS<- "sw" -ULEN<- "1cm" -MilliIn<- 1/2.54*1000 -PenThick<- round(MilliIn*0.02) -PenThickInit<- PenThick -TenSizeInit<<- 0.02*2 #17.10.07 -TenSize<- TenSizeInit -Wfile<-"" -MEMORI<- 0.05 -MEMORIInit<- MEMORI -MEMORINow<- MEMORI -MARKLEN<- 0.05 -MARKLENInit<- MARKLEN -MARKLENNow<- MARKLEN -GENTEN<- c(0,0) -YaSize<- 1 -YaAngle<- 18 -YaPosition<- 1 -YaThick<- 1 -YaStyle<- "tf" -PHI<- 30*pi/180 -THETA<- 60*pi/180 -FocusPoint<- c(0,0,0) -EyePoint<- c(5,5,5) -ASSIGNLIST<- list("`","'") - -SCALEX<- 1 -SCALEY<- 1 -LOGX<- 0 -LOGY<- 0 - -TEXFORLEVEL<- 0 -TEXFORLAST<- list() - -####################### - -Ketinit<- function(){ -XMIN<<- -5 -XMAX<<- 5 -YMIN<<- -5 ; YMAX<<- 5 -ZIKU<<- "line" -ARROWSIZE<<- 1 -XNAME<<- "$x$" -XPOS<<- "e" -YNAME<<- "$y$" -YPOS<<- "n" -ONAME<<- "O" -OPOS<<- "sw" -ULEN<<- "1cm" -MilliIn<<- 1/2.54*1000 -PenThick<<- round(MilliIn*0.02) -PenThickInit<<- PenThick -TenSizeInit<<- 0.02*2 #17.10.07 -TenSize<<- TenSizeInit -Wfile<<-"" -MEMORI<<- 0.05 -MEMORIInit<<- MEMORI -MEMORINow<<- MEMORI -MARKLEN<<- 0.05 -MARKLENInit<<- MARKLEN -MARKLENNow<<- MARKLEN -GENTEN<<- c(0,0) -YaSize<<- 1 -YaAngle<<- 18 -YaPosition<<- 1 -YaThick<<- 1 -YaStyle<<- "tf" -PHI<<- 30*pi/180 -THETA<<- 60*pi/180 -FocusPoint<<- c(0,0,0) -EyePoint<<- c(5,5,5) -ASSIGNLIST<<- list("`","'") - -SCALEX<<- 1 -SCALEY<<- 1 -LOGX<<- 0 -LOGY<<- 0 - -TEXFORLEVEL<<- 0 -TEXFORLAST<<- list() -} - -#------------------------------------------------------- - -Appendrow<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Out<-c() - Nc<- 0 - for (I in 1:Nargs) - { - Dt<- varargin[[I]] - Nc<- max(Nc,Ncol(Dt)) - if(class(Dt)=="matrix") Dt<-as.numeric(t(Dt)) - Out<- c(Out,Dt) - } - if(Nc>0) - { - Out<-matrix(Out, nrow=Nc) - Out<-t(Out) - } - else - { - Out<-c() - } - return(Out) -} - -Datalength<-function(Data) -{ - if(length(Data)==0) return(0) - if(mode(Data)=="numeric") return(Nrow(Data)) - if(mode(Data)=="character") return(nchar(Data)) - if(mode(Data)=="list") return(length(Data)) -} - -Crossprod<- function (a,b){ # 17.12.22 - if(length(a)==3){ - Tmp1=a[2]*b[3]-a[3]*b[2] - Tmp2=a[3]*b[1]-a[1]*b[3] - Tmp3=a[1]*b[2]-a[2]*b[1] - Out=c(Tmp1,Tmp2,Tmp3) - }else{ - Out=a[1]*b[2]-a[2]*b[1] - } - return(Out) -} - -Dotprod<-function(a,b){ # 18.02.05 - nn=min(length(a),length(b)) - out=0 - for(jj in Looprange(1,nn)){ - out=out+a[jj]*b[jj] - } - return(out) -} - -Dist<- function(...) # 17.09.17 -{ - varargin<- list(...) - a=varargin[[1]] - if(length(varargin)==1){ - tmp=sqrt(Dotprod(a,a)) - return(as.vector(tmp)) - } - else{ - b=varargin[[2]] - tmp=sqrt(Dotprod(b-a,b-a)) - retun(as.vector(tmp)) - } -} - -Member<-function(A,L) -{ - N<-length(L); - if(length(N)==0) return(FALSE) - for (I in 1:N) - { - if(class(L)=="list") - { - Tmp<-L[[I]] - } - else - { - Tmp<-L[I] - } - if(mode(A)=="numeric") - { - if(Norm(A-Tmp)==0) return(TRUE) - } - else - { - if(A==Tmp) return(TRUE) - } - } - return(FALSE) -} - -Norm<-function(V) -{ - Tmp=Dotprod(V,V) #18.02.09 -# Tmp<-as.vector(V); -# Tmp<-crossprod(Tmp,Tmp) - Tmp<-sqrt(Tmp) -# as.numeric(Tmp) -} - -Ncol<-function(P) -{ - if(class(P)=="matrix") return(ncol(P)) - else return(length(P)) -} - -Nrow<-function(P) -{ - if(length(P)==0) return(0) - if(class(P)=="matrix") return(nrow(P)) - else return(1) -} - -Looprange<- function(a,b) -{ -if(a<=b) return(a:b) -return(c()) -} - -Stripblanks<- function(Ch){ - Tmp<- gsub(" ","",Ch,fixed=TRUE) - return(Tmp) -} - -Quicksort<- function(seqL,key){ #18.02.01 - if(length(seqL)<2){ - out=seqL - }else{ - tmp1=Op(1,seqL) - tmp2=Op(2,seqL) - if(Op(key,tmp1)>=Op(key,tmp2)){ - pivot = tmp1 - }else{ - pivot=tmp2 - } - left = list() - right = list() - for(ii in 1:length(seqL)){ - tmp=Op(ii,seqL) - if(Op(key,tmp)< Op(key,pivot)){ - left=c(left,list(tmp)) - }else{ - right=c(right,list(tmp)) - } - } - left = Quicksort(left,key) - right = Quicksort(right,key) - out=c(left,right) - } - return(out) -} - -Derivative<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Fstr<- varargin[[1]] - Vstr<- varargin[[2]] - NvaL<- length(Vstr) - Flg<- 0 - if(Nargs>=3){ - VaL<- varargin[[3]] - Flg<- 1 - } - Str<- paste("deriv(~",Fstr,",c('",Vstr[1],"'",sep="") - for(J in Looprange(2,NvaL)){ - Str<- paste(Str,",'",Vstr[J],"'",sep="") - } - Str<- paste(Str,")",sep="") - if(NvaL<=3){ - Str<- paste(Str,",func=TRUE)",sep="") - } - else{ - Str<- paste(Str,")",sep="") - } - f<- eval(parse(text=Str)) - if(Flg==1){ - if(NvaL<=3){ - if(NvaL==1){V<- f(VaL[1])} - if(NvaL==2){V<- f(VaL[1],VaL[2])} - if(NvaL==3){V<- f(VaL[1],VaL[2],VaL[3])} - } - else{ - for(J in 1:NvaL){ - Tmp<- paste(Vstr[J],'<-',as.character(VaL[J])) - eval(parse(text=Tmp)) - } - V<- eval(f) - } - Out<- attr(V,'gradient') - Out<- Out[1,] - } - else{ - Out<- f - } - return(Out) -} - -Diff<- function(...){ #18.02.04 - varargin=list(...) - Nargs=length(varargin) - fun=varargin[[1]] - withvar=varargin[[2]] - tmp=paste("f<- expression(",fun,")",sep="") - eval(parse(text=tmp)) - nn=nchar(withvar) - for(jj in Looprange(1,nn)){ - tmp=substring(withvar,jj,jj) - f=D(f,tmp) - } - var=c() - val="" - for(jj in Looprange(3,Nargs)){ - tmp=strsplit(varargin[[jj]],"=") - var=c(var,tmp[[1]][1]) - val=paste(val,tmp[[1]][2],",",sep="") - } - if(Length(val)>1){ - val=substring(val,1,Length(val)-1) - f=deriv(f,var,func=TRUE) - tmp=paste("out=f(",val,")",sep="") - out=eval(parse(text=tmp)) - return(out[1]) - }else{ - return(f) - } -} - -Funvalue<- function(...){ - varargin=list(...) - Nargs=length(varargin) - df=varargin[[1]] - var=c() - val="" - for(jj in Looprange(2,Nargs)){ - tmp=strsplit(varargin[[jj]],"=") - var=c(var,tmp[[1]][1]) - val=paste(val,tmp[[1]][2],",",sep="") - } - val=substring(val,1,Length(val)-1) - dfun=deriv(df,var,func=TRUE) - tmp=paste("out=dfun(",val,")",sep="") - eval(parse(text=tmp)) - return(out[1]) -} - -Integrate<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Fstr<- varargin[[1]] - Vstr<- varargin[[2]] - IntvL<- varargin[[3]] - Str<- 'Tmpfun<- function(' - Str<- paste(Str,Vstr,'){',sep='') - Str<- paste(Str,Fstr,'}',sep='') - eval(parse(text=Str)) - Tmpfunv<- function(x){sapply(x,Tmpfun)} - Out<- 0 - for (J in 1:(length(IntvL)-1)){ - Tmp<- integrate(Tmpfunv,IntvL[J],IntvL[J+1]) - Out<- Out+Tmp[[1]] - } - return(Out) -} - -#-------------------------------------- - -######################### - -Anglemark<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-3) - PA<- varargin[[1]] - PB<- varargin[[2]] - PC=varargin[[3]] - r <- 0.5 - if(Nargs>=4){ - r<- varargin[[4]]*r - } - Out=c() - if(r>min(Norm(PA-PB),Norm(PC-PB))){ - return(Out) - } - Cir<- Circledata(c(PB,r)) #17.11.29 - Tmp<- IntersectcrvsPp(Cir,Listplot(PA,PB)) - P1<- Op(2,Op(1,Tmp)) - Tmp<- IntersectcrvsPp(Cir,Listplot(PC,PB)) - P2<- Op(2,Op(1,Tmp)) - if(abs(P1-P2)1){ - R<- Tmp - } - else{ - if(Flg==0){ - Ookisa<- Ookisa*Tmp - } - if(Flg==1){ - if(Tmp<5){ - Hiraki<- Tmp*Hiraki - } - else{ - Hiraki<- Tmp - } - } - if(Flg==2){ - R<- P+Tmp*(Q-P) - } - else{ - R<- P+Yapos*(Q-P) - } - if(Flg==3){ - Futosa<- Tmp - } - Flg<- Flg+1 - } - } - if(mode(Tmp)=="character"){ - Tmp<- grep("=", Tmp) - if(length(Tmp)>0){ - eval(parse(text=Tmp)) - Futosa<- Futosa*Thickness - R<- P+Position*(Q-P) - } - else{ - Str<- Tmp - } - } - } - Tmp1<- Listplot(c(P,Q)) - Tmp2<- Arrowheaddata(R,Q-P,Ookisa,Hiraki,Futosa,Str) - Out<- Joingraphics(Tmp1,Tmp2) -} - -###################################### - -# 2013.11.13 No Intersect debugged - -Arrowhead<-function(...) -{ ## Scaling is implemented - ## 12.01.08 Kirikomi - varargin<-list(...) - Nargs<-length(varargin) - P<-varargin[[1]] - Houkou<-varargin[[2]] - Ookisa<-0.2*YaSize - Hiraki<-YaAngle - Futosa<-0.5*YaThick - Cut<- 0 - Str<-YaStyle - Flg<- 0 - for (I in Looprange(3,Nargs)){ - Tmp<-varargin[[I]] - if(is.character(Tmp)){ - Equal<- grep("=",Tmp,fixed=TRUE) # 12.01.07 from - if(length(Equal)>0){ - Tmp1<- strsplit(Tmp,"=",fixed=TRUE) - Tmp2<- Tmp1[[1]] - if(Tmp2[1]=="Cut" || Tmp2[1]=="cut"){ - Tmp<- paste("Cut=",Tmp2[2],sep="") - eval(parse(text=Tmp)) - } - }else{ - Str<- Tmp - } # 12.01.07 until - } - if(is.numeric(Tmp) && length(Tmp)==1){ - if(Flg==0) Ookisa<-Ookisa*Tmp - if(Flg==1){ - if(Tmp<5) Hiraki<-Tmp*Hiraki - else Hiraki<-Tmp - } - if(Flg==2) Futosa<-Tmp - Flg<-Flg+1 - } - } - Ookisa<-1000/2.54/MilliIn*Ookisa - Theta<-Hiraki*pi/180 - if(Nrow(Houkou)>1){ - P<- Doscaling(P) - Houkou<- Doscaling(Houkou) - Tmp<-Nearestpt(P,Houkou) - A<-Tmp[[1]] - I<-floor(Tmp[[2]]) - G<-Circledata(c(P,Ookisa*cos(Theta)),N=10) #17.11.29 - Flg<- 0 # 13.11.13 - JL<-seq(I,1,by=-1) - for (J in JL){ - B<-Ptcrv(J,Houkou) - Tmp<-IntersectcrvsPp(Listplot(list(A,B)),G) - if(length(Tmp)>0){ - 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 - } - if(length(grep("b",Str))>0){ - 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 - if(length(grep("l",Str))>0){ - Tmp<-Listplot(list(A,P,B)) - 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 - Tmp1<- Unscaling(Tmp) - Shade(Tmp1) - Tmp=Listplot(c(A,P,B,C,A,P)) # 15.6.20 - Tmp1=Unscaling(Tmp) - Drwline(Tmp1,0.1) # 15.06.11, 15.06.14 - } -} - -############################################ - -# 2013.11.13 No intersect debugged - -Arrowheaddata<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - P<- varargin[[1]] - Houkou<- varargin[[2]] - Ookisa<- 0.2*YaSize - Hiraki<- YaAngle - Futosa<- 0 - Thickness<- 1 - Str<- YaStyle - Flg<- 0 - for (I in Looprange(3,Nargs)){ - Tmp<-varargin[[I]] - if(mode(Tmp)=="character"){ - Tmp1<-grep("=",Tmp) - if(length(Tmp1)>0){ - eval(parse(text=Tmp)) - Futosa<- Thickness - } - else{ - Str<- Tmp - } - } - if(mode(Tmp)=="numeric" && length(Tmp)==1){ - if(Flg==0) Ookisa<-Ookisa*Tmp - if(Flg==1){ - if(Tmp<5) Hiraki<-Tmp*Hiraki - else Hiraki<-Tmp - } - if(Flg==2) Futosa<-Tmp - Flg<-Flg+1 - } - } - Theta<- Hiraki*pi/180 - if(Nrow(Houkou)>1){ - P<- Doscaling(P) - Houkou<- Doscaling(Houkou) - Tmp<-Nearestpt(P,Houkou) - A<-Tmp[[1]] - I<-floor(Tmp[[2]]) - G<-Circledata(c(P,Ookisa*cos(Theta)),N=10) #17.11.29 - Flg<- 0 # 13.11.13 - JL<-seq(I,1,by=-1) - for (J in JL){ - B<- Ptcrv(J,Houkou) - Tmp<- IntersectcrvsPp(Listplot(list(A,B)),G) - if(length(Tmp)>0){ - 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 - } - if(length(grep("b",Str))>0){ - 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 - Tmp<- Listplot(A,P,B) - Out<- Unscaling(Tmp) - return(Out) -} - -########################################## - -Arrowline<- function(...) -{ # 12.01.07 kirikomi - varargin<- list(...) - Nargs<- length(varargin) - P<- varargin[[1]] - Q<- varargin[[2]] - Futosa<- YaThick - Ookisa<- YaSize - Hiraki<- YaAngle - Yapos<- YaPosition - Cutstr<- "Cut=0" - Str<- YaStyle - Flg<- 0 - for (I in Looprange(3,Nargs)){ - Tmp<- varargin[[I]] - if(is.character(Tmp)){ - Equal<- grep("=",Tmp,fixed=TRUE) # 12.01.07 from - if(length(Equal)>0){ - Tmp1<- strsplit(Tmp,"=") - Tmp2<- Tmp1[[1]] - if(Tmp2[1]=="Cut" || Tmp2[1]=="cut"){ - Tmp<- paste("Cut=", Tmp2[2],sep="") - Cutstr<- Tmp - } - } - else{ - Str<- Tmp - } # 12.01.07 until - } - if(is.numeric(Tmp) && length(Tmp)==1){ - if(Flg==0) Ookisa<- Ookisa*Tmp - if(Flg==1){ - if(Tmp<5) Hiraki<- Tmp*Hiraki - else Hiraki<- Tmp - } - if(Flg==2) Yapos<- Tmp - if(Flg==3) Futosa<- Tmp - Flg<- Flg+1 - } - } - 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) - Arrowhead(R,Q-P,Ookisa,Hiraki,Futosa,Cutstr,Str) -} - -######################################### - -Assign<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0){ - ASSIGNLIST<<- list("`",Prime()) - Out<- ASSIGNLIST - return() -# return("Assign reset done"); - } - L<- list("`","'") - if(Nargs%%2==0){ - L<- Mixjoin(L,varargin) - ASSIGNLIST<<- L - Out<- L - return() -# return("Assign set done"); - } - if(Nargs==1){ - Fnstr<- varargin[[1]] - if(nchar(Fnstr)==0){ # case of "" - L<- ASSIGNLIST - Out<- c() - for (I in seq(1,length(L),by=2)){ - Tmp1<- L[[I]] - Tmp2<- L[[I+1]] - if(length(Tmp2)==1){ - Tmp3<- as.character(Tmp2) - } - else{ - if(mode(Tmp2)=="character"){ - Tmp3<- Tmp2 - } - else if(mode(Tmp2)=="list"){ - Tmp3<- makeliststr(Tmp2) - } - else if(mode(Tmp2)=="numeric"){ - Tmp3<- "c(" - for (J in Looprange(1,length(Tmp2))){ - Tmp3<- paste(Tmp3,as.character(Tmp2[J]),sep="") - if(J0){ - if(length(grep(C,OL))>0){ - Tmp<-substring(Ucode,Is,I-1); - Str<-paste(VL,Tmp,C,sep="") - VL<-Str - Is<-I+1; - } - } - else{ - Unit<-substring(Ucode,I,I+1) - Str<-substring(Ucode,Is,I-1) - VL<-paste(VL,Str,sep="") - break; - } - } - Valu<-eval(parse(text=VL)) - Str<-as.character(Valu); - ULEN<<- paste(Str,Unit,sep="") - if(Unit=="cm") MilliIn<<-1000/2.54*Valu - if(Unit=="mm") MilliIn<<-1000/2.54*Valu/10 - if(Unit=="in") MilliIn<<-1000*Valu - if(Unit=="pt") MilliIn<<-1000/72.27*Valu - if(Unit=="pc") MilliIn<<-1000/6.022*Valu - if(Unit=="bp") MilliIn<<-1000/72*Valu - if(Unit=="dd2") MilliIn<<-1000/1238/1157/72.27*Valu - if(Unit=="cc") MilliIn<<-1000/1238/1157/72.27*12*Valu; - if(Unit=="sp") MilliIn<<-1000/72.27/65536*Valu/10 - MARKLEN<<- MARKLENNow*1000/2.54/MilliIn; - Str<-paste("{\\unitlength=",ULEN,"%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - cat("\\begin{picture}%\n",file=Wfile,append=TRUE) - Str<-"(" - Tmp<-as.character(round(Dx,digits=6)) - Str<-paste(Str,Tmp,",",sep="") - Tmp<-as.character(round(Dy,digits=6)) - Str<-paste(Str,Tmp,")(",sep="") - Tmp<-as.character(round(Xm,digits=6)) - Str<-paste(Str,Tmp,",",sep="") - Tmp<-as.character(round(Ym,digits=6)) - Str<-paste(Str,Tmp,")%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - Str<-paste("\\special{pn ",as.character(PenThickInit),"}%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - cat("%\n",file=Wfile,append=TRUE) -} - -################################################# - -Bowdata<- function(...) #17.09.17 -{ - varargin <- list(...) - Nargs <- length(varargin) - PA <- varargin[[1]] - PB <- varargin[[2]] - Cut <- 0 - D <- 1/2*Norm(PB-PA) - if(Nargs>=3) { - H <- varargin[[3]]*D*0.2 - } - else { - H <- D*0.2 - } - H <- min(H,D) - if(Nargs>=4){ - Cut <- varargin[[4]] - } - Ydata <- MakeBowdata(PA,PB,H) - C <- Op(1,Ydata) - r <- Op(2,Ydata) - R1 <- Op(3,Ydata) - R2 <- Op(4,Ydata) - Rng <- paste("R=c(",as.character(R1),",",as.character(R2),")",sep="") - Theta <- (R1+R2)*0.5 - BOWMIDDLE <<- list(c(C[1]+r*cos(Theta),C[2]+r*sin(Theta)),Theta) - M <- Op(1,BOWMIDDLE) - ThetaM <- Op(2,BOWMIDDLE) - BOWSTART <<- PA - BOWEND <<- PB - if(Cut==0){ - Pd<- Circledata(c(C,r),Rng) - } - else{ - Alpha <- R1; Beta <- ThetaM-Cut/(2*r) - Rng <- paste("Rng=c(",as.character(Alpha),",",as.character(Beta),")",sep="") - Pd <- Circledata(c(C,r),Rng) - Alpha <- ThetaM+Cut/(2*r); Beta <- R2 - Rng <- paste("R=c(",as.character(Alpha),",",as.character(Beta),")",sep="") - Tmp <- Circledata(c(C,r),Rng) - Pd <- Appendrow(Pd,c(Inf,Inf),Tmp) - } -} - -Bowmiddle <- function(...) -{ - varargin <- list(...) - Nargs <- length(varargin) - if( Nargs==0) { - M <- BOWMIDDLE - return(M) - } - if(Nargs==1) { - Bdata <- varargin[[1]] - A <- Bdata[1,] - Dind <- Dataindex(Bdata) - Dc <- Nrow(Dind) - Tmp <- Dind[Dc,2] - B <- Bdata[Tmp,] - if(Dc==1) { - Tmp1 <- round(Tmp/2) - } - else { - Tmp1 <- Dind[1,2] - } - D <- Bdata[Tmp1,] - B <- B-A - D <- D-A - Tmp1 <- B[1]*D[2]-D[1]*B[2] - Tmp2 <- (Norm(B)^2*D[2]-B[2]*Norm(D)^2)/2 - Tmp3 <- -(Norm(B)^2*D[1]-B[1]*Norm(D)^2)/2 - C <- c(Tmp2,Tmp3)/Tmp1+A - R <- Norm(C-A) - B <- B+A - V <- (A+B)/2-C - V <- V/Norm(V) - M <- C+R*V - } - else { - A <- varargin[[1]]; B <- varargin[[2]] - D <- 1/2*Norm(B-A) - H <- 0.2*D; - if(length(varargin)>=3) { - Tmp <- varargin[[3]] - H <- Tmp*D*0.2 - } - H <- min(H,D) - Ydata <- MakeBowdata(A,B,H) - C <- Op(1,Ydata) - R <- Op(2,Ydata) - T <- (Op(3,Ydata)+Op(4,Ydata))/2 - P <- C+R*c(cos(T),sin(T)) - #M <- list(P,T) - M <- P - } - return(M) -} - -########################## -# 13.12.19 small movement supported - -Bowname<- function(...) -{ - varargin <- list(...) - Nargs <- length(varargin) - Siki <- varargin[[Nargs]] - Nargs<- Nargs-1 - Dr<- "c" - if(Nargs>=1){ - Tmp<- varargin[[Nargs]] - if(is.character(Tmp)){ - Dr<- Tmp - Nargs<- Nargs-1 - } - } - if(Nargs==0){ - Siki <- varargin[[1]] - P <- Op(1,BOWMIDDLE) - } - else if(Nargs==1){ - Bdata <- varargin[[1]] - P <- Bowmiddle(Bdata) - } - else{ - A <- varargin[[1]]; B <- varargin[[2]] - D <- 1/2*Norm(B-A) - Tmp <- varargin[[3]] - if(is.character(Tmp)){ - H <- D*0.2 - } - else { - H <- Tmp*D*0.2 - } - H <- min(H,D) - Ydata <- MakeBowdata(A,B,H) - Tmp <- Bowmiddle(Ydata) - P <- Op(1,Tmp) - } - Expr(P,Dr,Siki) -} - -########################## -# 13.12.19 small movement supported -# A,B, ... no longer supported - -Bownamerot <- function(...) -{ - varargin <- list(...) - Nargs <- length(varargin) - Eps <- 10^(-6) - Flg <- 1 - Tmp <- varargin[[Nargs]] - if(is.numeric(Tmp) && length(Tmp)==1 && Tmp<0){ - Flg <- Tmp - Nargs <- Nargs-1 - } - Siki <- varargin[[Nargs]] - Nargs<- Nargs-1 - Dr<- "c" - if(Nargs>=1){ - Tmp<- varargin[[Nargs]] - if(is.character(Tmp)){ - Dr<- Tmp - Nargs<- Nargs-1 - } - } - if(Nargs==0) { - P <- Op(1,BOWMIDDLE) - A <- BOWSTART - B <- BOWEND - } - else{ - Bdata<- varargin[[1]] - P<- Bowmiddle(Bdata) - A=Bdata[1,] - B=Bdata[nrow(Bdata),] - Tm<- 0; Tv<- 0 - if(Nargs>1){ - Tm<- varargin[[2]] - if(Nargs>2){ - Tv<- varargin[[3]] - } - } - } -# else if(Nargs==2) { -# Bdata <- varargin[[1]] -# P <- Bowmiddle(Bdata) -# A <- Bdata[1,] -# B <- Bdata[Nrow(Bdata),] -# Siki <- varargin[[2]] -# } -# else { -# A <- varargin[[1]]; B <- varargin[[2]] -# D <- 1/2*Norm(B-A) -# Tmp <- varargin[[3]] -# if(mode(Tmp)=="character") { -# H <- 0.2*D; Siki <- Tmp -# } -# else { -# H <- Tmp*D*0.2; Siki <- varargin[[4]] -# } -# H <- min(H,D) -# Ydata <- MakeBowdata(A,B,H) -# C <- Op(1,Ydata) -# R <- Op(2,Ydata) -# T <- (Op(3,Ydata)+Op(4,Ydata))/2 -# P <- C+R*c(cos(T),sin(T)) -# } - if(A[1]>B[1]+Eps){ - Tmp <- A - A <- B - B <- Tmp - } - if(Flg>0) { - Tmp <- B-A - } - else{ - Tmp <- A-B - } - Exprrot(P,Tmp,Tm,Tv,Siki) -} - -CalcHeight<-function(Hoko,Moji) -{ - D<-0 - H<-substring(Hoko,1,1) - Tmp<-paste("\\settoheight{\\Height}{",Moji,"}",sep="") - Str<-c(Tmp) - Tmp=paste("\\settodepth{\\Depth}{",Moji,"}",sep="") - Str<-c(Str,Tmp) - if(H=="n") Str<-c(Str,"\\setlength{\\Height}{\\Depth}") - if(H=="s") Str<-c(Str,"\\setlength{\\Height}{-\\Height}") - if(H=="c") - { - Str<-c(Str,"\\setlength{\\Height}{-0.5\\Height}") - Str<-c(Str,"\\setlength{\\Depth}{0.5\\Depth}") - Str<-c(Str,"\\addtolength{\\Height}{\\Depth}") - } - for (I in 1:length(Str)) cat(Str[I],file=Wfile,append=TRUE) - cat("%\n",file=Wfile,append=TRUE) -} - -######################### - -CalcWidth<-function(Hoko,Moji) -{ - D<-0; - H<-substring(Hoko,2,2) - if(H=="e") D<-0 - if(H=="w") D<--1.0 - if(H=="c") D<--0.5 - Str1<-paste("\\settowidth{\\Width}{",Moji,"}",sep="") - Tmp<-as.character(D) - Str2<-paste("\\setlength{\\Width}{",Tmp,"\\Width}",sep="") - cat(Str1,file=Wfile,append=TRUE) - cat(Str2,file=Wfile,append=TRUE) - cat("%\n",file=Wfile,append=TRUE) -} - -######################### -# 17.09.17 -# 17.09.24 - -Circledata<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Cr<- varargin[[1]] - C=Cr[1:2] - if(length(Cr)==4){ - ra=Norm(C-Cr[3:4]) - Nop=2 - } - else{ - ra=Cr[3] - Nop=2 - } - R=c(0,2*pi) - N=50 - for (I in Looprange(Nop,Nargs)){ - Tmp<- varargin[[I]] - if(is.character(Tmp)){ - Tmp1=regexpr("=",Tmp) #17.09.24from - Tmp2=substring(Tmp,Tmp1+1,nchar(Tmp)) - Tmp1=substring(Tmp,1,Tmp1) - Tmp1=gsub("NUM", "N", toupper(Tmp1)) - Tmp1=gsub("RNG", "R", Tmp1) - Tmp=paste(Tmp1,Tmp2,sep="") #17.09.24until - eval(parse(text=Tmp)) - } - } - Dt<- (R[2]-R[1])/N - T <- seq(R[1],R[2],by=Dt) - X <- C[1]+ra*cos(T) - Y <- C[2]+ra*sin(T) - XY<- c(X,Y) - P<- matrix(XY,ncol=2) - return(P) -} - -######################### -# 13.12.19 - -Closefile<-function(...) -{ - varargin<- list(...) - if(length(varargin)>=1){ - Pa<- varargin[[1]] - if(is.character(Pa)){ - if(Pa=="1") Endpicture(1) - if(Pa=="0") Endpicture(0) - } - } - Wfile<<-"" -} - -######################### - -Closepar<- function() -{ - S<- "%\n\\end{minipage}" - cat(S,file=Wfile,append=TRUE) - Closephr() -} - - -#################################### - -Closephr<- function() -{ - cat("%\n}%\n",file=Wfile,append=TRUE) -} - -##################################### - -Dataindex<-function(P) -{ - # Inf;Inf : Terminator - Ndm<-c() - if(length(P)==0) return(Ndm) - N1<-1 - Flg<-0 - for (J in 1:Nrow(P)) - { - if(P[J,1]==Inf) - { - Ndm<-Appendrow(Ndm,c(N1,J-1)) - N1<-J+1; - if(P[N1,1]==Inf) - { - Flg<-1; - break; - } - } - } - if(Flg==0) - { - Ndm<-Appendrow(Ndm,c(N1,Nrow(P))) - } - if(class(Ndm)=="numeric") - { - Tmp<-matrix(Ndm,nrow=1) - Ndm<- Tmp - } - return(Ndm) -} - -################################ - -Dashline<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Nall<- Nargs; Sen<- 1 ; Gap<- 1 - Tmp<- varargin[[Nall]] - if(mode(Tmp)=="numeric" && length(Tmp)==1 && Tmp>0){ - Tmp1<- varargin[[Nall-1]] - if(mode(Tmp1)=="numeric" && length(Tmp1)==1 && Tmp1>0){ - Sen<- Tmp1; Gap<- Tmp - Nall<- Nall-2 - } - else{ - Sen<- Tmp; Gap<- Sen - Nall<- Nall-1 - } - } - Sen<- 1000/2.54/MilliIn*Sen - Gap<- 1000/2.54/MilliIn*Gap - for (N in Looprange(1,Nall)){ - Pdata<- varargin[[N]] - if(is.numeric(Pdata)==1){ - Pdata<- list(Pdata) - } - for (II in 1:length(Pdata)){ - Figdata<- Op(II,Pdata) - Makehasen(Figdata,Sen,Gap,0) - } - } -} - -############################################## -# 17.11.27 - -Definecolor<- function(Name,Data){ - Tmp1=length(Data) - if((Tmp1<3) || (Tmp1>4)){ - cat("Size of data should be 3 or 4.") - return() - } - if(Tmp1==4){ - Tp="cmyk" - }else{ - Tp="rgb" - } - Tmp="" - for(J in 1:Tmp1){ - Tmp=paste(Tmp, as.character(Data[J]),sep="") - if(J0){ - for (J in Looprange(1,length(Sha))){ - Tmp<- Op(J,Sha) - Q<- Tmp[1,] - R<- Tmp[2,] - Tmp<- Dotprod(Q-P,V)/Kankaku - K1<- ceiling(Tmp) - if(abs(K1-Tmp)0){ - for (J in 1:length(Sha)){ - Tmp<- Op(J,Sha) - Q<- Tmp[1,] - R<- Tmp[2,] - Tmp<- Dotprod(Q-P,V)/Kankaku - K1<- ceiling(Tmp) - if(abs(K1-Tmp)0){ - for (J in 1:length(Sha)){ - Tmp<- Op(J,Sha) - Q<- Tmp[1,] - R<- Tmp[2,] - Tmp<- Dotprod(Q-P,V)/Kankaku - K1<- ceiling(Tmp) - if(abs(K1-Tmp) 1) { - Seg <- Lenall/(Nten-1) - } - else { - Seg <- Lenall - } - Eps <- 10^(-6)*Seg - PPd<-c() - Hajime <- 1 - for (I in Looprange(0,Nten-1)) { - Len <- Seg*I - if(I>0) { - J <- Hajime - while( Len>=Lenlist[J]+Eps) { - J <- J+1 - } - Hajime <- J-1 - } - T <- (Len-Lenlist[Hajime])/ - (Lenlist[Hajime+1]-Lenlist[Hajime]) - P <- Data[Hajime,]+T*(Data[Hajime+1,]-Data[Hajime,]) - PPd<-Appendrow(PPd,P) - if(I==Nten-1) { - if(Norm(P-Data[1,])80){ - cat("%\n",file=Wfile,append=TRUE) - Mojisu<-0 - } - } - if(Mojisu!=0){ - cat("%\n",file=Wfile,append=TRUE) - } - cat("\\special{fp}%\n",file=Wfile,append=TRUE) - } - } - } - Str<-"%" - if(Thick>0){ - Tmp<-PenThick/PenThickInit - Setpen(Tmp) - } -} - -########################################### - -Drwpt<-function(...) -{ ## Scaling is implemented - varargin<-list(...) - Nargs<-length(varargin) - if(TenSize>TenSizeInit){ - N<- round(6*sqrt(TenSize/TenSizeInit)) - } - else{ - N<-4 - } - Tmp<- varargin[[Nargs]] - if(mode(Tmp)=="numeric"){ - if(length(Tmp)>1){ - Kosa<- 1; All<- Nargs - } - else{ - Kosa<- Tmp; All<- Nargs-1 - } - } - else if(mode(Tmp)=="list"){ - Kosa<- 1; All<- Nargs - } - CL<-c() - for (J in 0:N){ - Tmp<- TenSize*0.5*1000/2.54/MilliIn - Tmp<- Tmp*c(cos(pi/4+J*2*pi/N),sin(pi/4+J*2*pi/N)) - CL<- append(CL,Tmp) - } - CL<- matrix(CL,nrow=2) - CL<- t(CL) - for (II in Looprange(1,All)){ - MS<- varargin[[II]] - MS=Flattenlist(MS) #17.10.11 - if(mode(MS)=="numeric"){ - MS<- list(MS) - } - for (I in Looprange(1,length(MS))){ - P<- MS[[I]] - if(InWindow(P)!="i") next - P<- Doscaling(P) - PL<-c() - for (J in 0:N){ - PL<- c(PL,P+CL[J+1,]) - } - PL<-matrix(PL,nrow=2) - PL<-t(PL) - Mojisu<-0 - for (J in 1:Nrow(PL)){ - Q<- PL[J,] - X<- as.character(round(MilliIn*Q[1])) - Y<- as.character(-round(MilliIn*Q[2])) - Str<- paste("\\special{pa ",X," ",Y,"}",sep="") - cat(Str,file=Wfile,append=TRUE) - Mojisu<- Mojisu+nchar(Str) - if(Mojisu>80){ - cat("#\n",file=Wfile,append=TRUE) - } - Mojisu=0 - } - Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") - Str2<- "\\special{fp}%\n" - cat(Str1,file=Wfile,append=TRUE) - cat(Str2,file=Wfile,append=TRUE) - } - } -} - -###################################################### - -Drwxy<-function(...) -{ - 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) - } - else - { - Drwline(Listplot(c(XMIN,GENTEN[2]),c(XMAX,GENTEN[2]))) - Drwline(Listplot(c(GENTEN[1],YMIN),c(GENTEN[1],YMAX))) - } - Letter(c(XMAX,GENTEN[2]),XPOS,XNAME) - Letter(c(GENTEN[1],YMAX),YPOS,YNAME) - Letter(GENTEN,OPOS,ONAME); -} - -########################################## -# 10.12.04 - -Enclosing<- function(...) -{ - Eps=10^(-7) # Scilab 16.12.05 - varargin<- list(...) - Nargs<- length(varargin) - P<- varargin[[1]] - if(Mixtype(P)==2){ - Tmp<- Op(1,P) - if(mode(Tmp)!="numeric" || length(Tmp)>1){ - AnsL<- EnclosingS(...) - AnsL<- Joincrvs(AnsL) # 10.12.04 - } - } - Tmp1=Op(1,AnsL) # Scilab 16.12.05from - Tmp2=Op(nrow(AnsL),AnsL) - if(Norm(Tmp2-Tmp1)>Eps){ - AnsL=Appendrow(AnsL,Tmp1) - } - return(AnsL) -} - -######################################### - -EnclosingS<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - AnsL<- list() - PdataL<- varargin[[1]] - Nall<-length(PdataL) - Eps<- 10^(-3) - EEps<- 0.1 - S<- c() - Flg<- 0 - for (I in Looprange(2,Nargs)){ - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric" && Nrow(Tmp)==1 && length(Tmp)>1){ - S<- Tmp - } - if(mode(Tmp)=="numeric" && length(Tmp)==1){ - if(Flg==0){ - Eps<- Tmp - Flg=Flg+1 - } - else{ - EEps<- Tmp - } - } - } - F<- Op(1,PdataL); G<- Op(Nall,PdataL) - KL<- IntersectcrvsPp(F,G) - if(length(KL)==1){ - Tmp<- Op(1,KL) - P<- Op(1,Tmp) - T1<- Op(2,Tmp) - } - if(length(KL)==0){ - if(Numptcrv(F)>Numptcrv(G)){ - Tmp<- Nearestpt(F,G) - P<- Op(1,Tmp) - T1=Op(2,Tmp) - } - else{ - Tmp<- Nearestpt(G,F) - P<- Op(3,Tmp) - T1<- Op(4,Tmp) - } - } - if(length(KL)>=2){ - if(length(S)==0){ - return("No Start Point") - } - Tmp<- Op(1,KL) - P<- Op(1,Tmp) - T1<- Op(2,Tmp) - Tmp<- Norm(P-S) - for (I in Looprange(2,length(KL))){ - Tmp1<- Op(1,Op(I,KL)) - Tmp2<- Norm(Tmp1-S) - if(Tmp21) P<- Q - if(N==Nall){ - Q=S - } - else{ - Flg<- 0 - G<- Op(N+1,PdataL) - KL<- IntersectcrvsPp(G,F) - if(length(KL)==1){ - Tmp<- Op(1,KL) - Q<- Op(1,Tmp) - T3<- Op(2,Tmp) - Flg<- 10 - } - if(length(KL)==0) Flg<- 1 - if(length(KL)>=2){ # Maple bug? - Tmp1<- Op(1,Op(1,KL)) - Tmp2<- Op(1,Op(2,KL)) - Tmp<- Norm(Tmp1-Tmp2) - if(TmpNumptcrv(G)){ - Tmp<- Nearestpt(F,G) - Q<- Op(1,Tmp) - T3<- Op(4,Tmp) - Flg<- 10 - } - else{ - Tmp<- Nearestpt(G,F) - Q<- Op(3,Tmp) - T3<- Op(2,Tmp) - Flg<- 10 - } - } - if(Flg<10){ - T2<- Inf - for (I in Looprange(1,length(KL))){ - Dt<- Op(I,KL) - Tmp1<- Op(1,Dt) - Tmp<- Op(3,Dt) - Tmp2<- Paramoncurve(Tmp1,Tmp,F) - Tmp3<- Op(2,Dt) - if(Tmp2>T1+Eps && Tmp20){ - eval(parse(text=Op(I,StrL))) - } - } -} - -######################################### - -Expr<-function(...) -{ ## Scaling is implemented - varargin<-list(...) - Nargs<-length(varargin) - Irng<-c(seq(from=1,to=Nargs,by=3)) - for (I in Irng) - { - Tmp<-varargin[[I]] - P<- Doscaling(Tmp) - X<-P[1] - Y<-P[2] - Houkou<-varargin[[I+1]] - Mojiretu<-paste("$",varargin[[I+2]],"$",sep="") - Hset<-Houkou - Vhoko<-"c" - if(length(grep("n",Hset))>0) - { - Vhoko<-"n"; Y<-Y+MEMORI - } - if(length(grep("s",Hset))>0) - { - Vhoko<-"s"; Y<-Y-MEMORI - } - Hhoko<-"c" - if(length(grep("e",Hset))>0) - { - Hhoko<-"e"; X<-X+MEMORI - } - if(length(grep("w",Hset))>0) - { - Hhoko<-"w"; X<-X-MEMORI - } - Hoko<-paste(Vhoko,Hhoko,sep="") - Suu<-"+-.0123456789" - SuuL<-Suu - J<-1; Dstr<-"" - while (J<=nchar(Houkou)) - { - Tmp<-substring(Houkou,J,J) - if(length(grep(Tmp,Suu))>0) - { - if(Dstr=="") Hk<-substring(Houkou,J-1,J-1) - Dstr<-paste(Dstr,Tmp,sep="") - } - else - { - if(Dstr!="") - { - Nmbr<-as.numeric(Dstr) - D<-Nmbr*MEMORI - if(Hk=="n") Y<-Y+D - if(Hk=="s") Y<-Y-D - if(Hk=="e") X<-X+D - if(Hk=="w") X<-X-D - Dstr<-"" - } - } - J<-J+1 - } - if(Dstr!="") - { - Nmbr<-as.numeric(Dstr) - D<-Nmbr*MEMORI; - if(Hk=="n") Y<-Y+D - if(Hk=="s") Y<-Y-D - if(Hk=="e") X<-X+D - if(Hk=="w") X<-X-D - } - CalcWidth(Hoko,Mojiretu) - CalcHeight(Hoko,Mojiretu) - cat("\\put(",file=Wfile,append=TRUE) - Tmp1<- sprintf("%7.7f",X) # 11.07.19 - Tmp2<- sprintf("%7.7f",Y) # 11.07.19 - Str<-paste(Tmp1,",",Tmp2,sep="") - cat(Str,file=Wfile,append=TRUE) - Tmp<-"){\\hspace*{\\Width}" - Str<-paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - cat("%\n",file=Wfile,append=TRUE) - } -} - -########################################## - -Exprrot<- function(...) -{ - varargin<- list(...) - P<- varargin[[1]] - V<- varargin[[2]]; N<- 3 - P<- Doscaling(P) - V<- Doscaling(V) - Tmov<- 0 - Tmp<- varargin[[N]] - if(mode(Tmp)=="numeric"){ - Tmov<- Tmp; N<- N+1 - } - Nmov<- 0 - Tmp<- varargin[[N]] - if(mode(Tmp)=="numeric"){ - Nmov<- Tmp; N<- N+1 - } - Mojiretu<- paste("$",Assign(varargin[[N]]),"$",sep="") # 2017.11.26 - Tv<- 1/Norm(V)*V - Nv<- c(-Tv[2],Tv[1]) - P<- P+MEMORI*Tmov*Tv+MEMORI*Nmov*Nv - Tmp<- acos(V[1]/Norm(V)) - Theta<- round(Tmp*180/pi) - if(V[2]>=0){ - Units<- "" - } - else{ - Units<- "units=-360," - } - Tmp<- paste("\\rotatebox[",Units,"origin=c]{",as.character(Theta),sep="") - Tmp<- paste(Tmp,"}{",Mojiretu,"}",sep="") - Letter(P,"c",Tmp) -} - -###################################################### - -Findcell<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - Ag<- varargin[[2]] - Alpha<- "-ABCDEFGHIJKLMNOPQRSTUVWXYZ" - if(mode(Ag)=="character"){ - Clm<- c() - Rstr<- "" - for (I in Looprange(1,nchar(Ag))){ - C<- substr(Ag,I,I) - C<- toupper(C) - Tmp<- strsplit(Alpha,C) - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - Tmp1<- nchar(Tmp[1]) - Clm<- c(Clm,Tmp1) - } - else{ - Rstr<- paste(Rstr,C,sep="") - } - } - Nrg<- 0 - for (I in seq(length(Clm),1,by=-1)){ - Tmp<- Clm[I] - Tmp1<- length(Clm)-I - Nrg<- Nrg+Tmp*26^Tmp1 - } - Mrg<- eval(parse(text=Rstr)) - if(Nargs>=3){ - Ag<- varargin[[3]] - Clm<- c() - Rstr<- "" - for (I in Looprange(1,nchar(Ag))){ - C<- substr(Ag,1,1) - C<- toupper(C) - Tmp<- strsplit(Alpha,C) - if(length(Tmp)>1){ - Clm<- c(Clm,Tmp+1) - } - else{ - Rstr<- paste(Rstr,C,sep="") - } - } - Nrg2<- 0 - for (I in seq(length(Clm),1,by=-1)){ - Tmp<- Clm[I] - Tmp1<- length[Clm]-I - Nrg2<- Nrg2+Tmp*26^Tmp1 - } - Nrg<- c(Nrg,Nrg2) - Tmp=eval(parse(text=Rstr)) - Mrg<- c(Mrg,Tmp) - } - } - else{ - Nrg<- varargin[[2]] - Mrg<- varargin[[3]] - } - if(length(Mrg)==1){ - m1<- Mrg; m2<- m1+1 - } - else{ - m1<- Mrg[1]; m2<- Mrg[2] # 10.12.12 - } - if(length(Nrg)==1){ - n1<- Nrg; n2<- n1+1 - } - else{ - n1<- Nrg[1]; n2<- Nrg[2] - } - n1<- n1+1; n2<- n2+1 - m1<- m1+1; m2<- m2+1 - Hind<- TbL[[2]] - Vind<- TbL[[3]] - Tmp<- TbL[[1]] - HL<- Tmp[Hind] - Tmp1<- Op(1,TbL[[4]]) - Tmp2<- Op(2,TbL[[4]]) - HL<- Mixjoin(list(Tmp1),HL,list(Tmp2)) - VL<- Tmp[Vind] - Tmp1<- Op(1,TbL[[5]]) - Tmp2<- Op(2,TbL[[5]]) - VL<- Mixjoin(list(Tmp1),VL,list(Tmp2)) - Tmp<- TbL[[6]] - Tmp1<- Listplot(c(Ptsw(Tmp),Ptnw(Tmp))) - Tmp2<- Listplot(c(Ptse(Tmp),Ptne(Tmp))) - HL<- Mixjoin(list(Tmp1),HL,list(Tmp2)) - Tmp1<- Listplot(c(Ptnw(Tmp),Ptne(Tmp))) - Tmp2<- Listplot(c(Ptsw(Tmp),Ptse(Tmp))) - VL<- Mixjoin(list(Tmp1),VL,list(Tmp2)) - Tmp<- HL[[n1]] - if(mode(Tmp)=="numeric"){ - H1<- Tmp[1,1] - } - else{ - Tmp1<- Tmp[[1]] - H1<- Tmp1[1,1] - } - Tmp<- HL[[n2]] - if(mode(Tmp)=="numeric"){ - H2<- Tmp[1,1] - } - else{ - Tmp1<- Tmp[[1]] - H2<- Tmp1[1,1] - } - Tmp<- VL[[m1]] - if(mode(Tmp)=="numeric"){ - V1<- Tmp[1,2] - } - else{ - Tmp1<- Tmp[[1]] - V1<- Tmp1[1,2] - } - Tmp<- VL[[m2]] - if(mode(Tmp)=="numeric"){ - V2<- Tmp[1,2] - } - else{ - Tmp1<- Tmp[[1]] - V2<- Tmp1[1,2] - } - Pt<- c((H1+H2)/2,(V1+V2)/2) - High<- (V1-V2)/2 - Wide<- (H2-H1)/2 - Out<- list(Pt,Wide,High) - return(Out) -} - -############################################ - -Flattenlist<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Out<- list() - for(N in Looprange(1,Nargs)){ - D<- varargin[[N]] - if(is.data.frame(D) || !is.list(D)){ # modify - Out<- c(Out,list(D)) - } - else{ - for(I in Looprange(1,length(D))){ - Ds<- D[[I]] - Tmp<- Flattenlist(Ds) - Out<- c(Out,Tmp) - } - } - } - return(Out) -} - -############################################ - -Fontsize<- function(Ookisa) -{ - Str<- "%" - S<- substr(Ookisa,1,1) - if(S=="n"){ - Str<- "\\normalsize%" - } - if(S=="s"){ - if(nchar(Ookisa)==1){ - Tmp<- "n" - } - else{ - Tmp<- substr(Ookisa,2,2) - } - if(Tmp=="s"){ - Str<- "\\scriptsize%" - } - else{ - Str<- "\\small%" - } - } - if(S=="f"){ - Str<- "\\footnotesize%" - } - if(S=="t"){ - Str<- "\\tiny%" - } - if(S=="l"){ - Str<- "\\large%" - } - if(S=="L"){ - if(nchar(Ookisa)==1){ - Tmp<- "a" - } - else{ - Tmp<- substr(Ookisa,2,2) - } - if(Tmp=="a"){ - Str<- "\\Large%" - } - else{ - Str<- "\\LARGE%" - } - } - if(S=="h"){ - Str<- "\\huge%" - } - if(S=="H"){ - Str<- "\\Huge%" - } - cat(Str,file=Wfile,append=TRUE) - cat("\n",file=Wfile,append=TRUE) -} - -########################################## - -Fracform<- function(...) -{ - varargin<- list(...) - Eps<- 10^(-10) - Nmax<- 1/Eps - Nargs<- length(varargin) - X<- varargin[[1]] - Nr<- Nrow(X) - X<- as.matrix(X,nrow=Nr) - for (I in Looprange(2,Nargs)){ - Tmp<- varargin[[I]] - if(mode(Tmp)!="numeric"){ - next - } - if(Tmp>1){ - Nmax<- Tmp - } - else if(Tmp>0){ - Eps<- Tmp - } - } - Tmp<- rep("",length(X)) - Out<- matrix(Tmp,nrow=nrow(X)) - for (I in Looprange(1,nrow(X))){ - for (J in Looprange(1,ncol(X))){ - Dt<- X[I,J] - if(mode(Dt)=="character"){ - Dt<- eval(parse(text=Dt)) - } - R<- 1 - N<- 0 - Rmin<- R - Nr<- N - while (R>Eps && N0) - { - Tmp<- Mixjoin(ShaL, list(Sha)) - ShaL <- Tmp - Sha<- Makeshasen(PtnL,PA+I*Kankaku*Vm,V,Bdy) - I <- I+1 - } - Sha<- Makeshasen(PtnL,PA-Kankaku*Vm,V,Bdy) - I<- 2 - while (length(Sha)>0) - { - for (J in 1:length(Sha)) - { - Tmp<- Mixjoin(ShaL,list(Sha[[J]])) - ShaL<- Tmp - } - Sha<- Makeshasen(PtnL,PA-I*Kankaku*Vm,V,Bdy) - I<- I+1 - } - } - else - { - Delta<- c(Xmn,Ymn)-StartP - K1<- trunc(Dotprod(Delta,Vm)/Kankaku) - Delta<- c(Xmx,Ymn)-StartP - K2<- trunc(Dotprod(Delta,Vm)/Kankaku) - Delta<- c(Xmx,Ymx)-StartP - K3<- trunc(Dotprod(Delta,Vm)/Kankaku) - Delta<- c(Xmn,Ymx)-StartP - K4<- trunc(Dotprod(Delta,Vm)/Kankaku) - IM<- max(K1,K2,K3,K4) - Im<- min(K1,K2,K3,K4) - for (I in Im:IM) - { - Sha<- Makeshasen(PtnL,StartP+I*Kankaku*Vm,V,Bdy) - for (J in Looprange(1,length(Sha))) - { - Tmp<- Mixjoin(ShaL, list(Sha[[J]])) - ShaL<- Tmp - } - } - } - ShaLs<-list() - for (I in Looprange(1,length(ShaL))) - { - Tmp<- ShaL[[I]] - Tmp1<- Unscaling(Tmp) - Tmp2<- Mixjoin(ShaLs, list(Tmp1)) - ShaLs<- Tmp2 - } - ShaL<- ShaLs - return(ShaL) -} - -###################################### - -Htickmark<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - ArgsL<- varargin - if(mode(ArgsL[[1]])=="character"){ - Str<- ArgsL[[1]] - Tmp<- strsplit(Str,"m") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - I<- nchar(Tmp[1])+1 - } - else{ - I<- 0 - } - Tmp<- strsplit(Str,"n") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - J<- nchar(Tmp[1])+1 - } - else{ - J<- 0 - } - Tmp<- strsplit(Str,"r") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - K=nchar(Tmp[1])+1 - } - else{ - K<- 0 - } - if(K>0){ - S<- substr(Str,K+1,nchar(Str)) - R<- as.numeric(S) - if(is.na(R)){ - R<- 1 - } - } - else{ - R<- 1 - K<- nchar(Str)+1 - } - if(J>0){ - S<- substr(Str,J+1,K-1) - Dn<- as.numeric(S) - if(is.na(Dn)){ - Dn<- 1 - } - } - else{ - Dn<- 1000 - J<- nchar(Str)+1 - } - S<- substr(Str,I+1,J-1) - Dm<- as.numeric(S) - if(is.na(Dm)){ - Dm<- 1 - } - ArgsL<- list() - for (I in Looprange(1, floor((XMAX-GENTEN[1])/Dm))){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - for (I in seq(-1,ceiling((XMIN-GENTEN[1])/Dm),by=-1)){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - } - MemoriList<- list() - Memori<- list() - for (N in 1:length(ArgsL)){ - Dt<- ArgsL[[N]] - if(mode(Dt)=="numeric" && length(Dt)>1){ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt[1],Dt[2]) - next - } - if(mode(Dt)=="character"){ - Memori<- Mixjoin(Memori,Dt) - } - else{ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt,GENTEN[2]) - } - } - MemoriList<- Mixjoin(MemoriList,list(Memori)) - for (N in 1:length(MemoriList)){ - Dt<- MemoriList[[N]] - Ndt<- length(Dt) - X=Op(1,Dt) - Y=Op(2,Dt) - Tmp<-Doscaling(c(X,Y)) - X<- Tmp[1] - Y<- Tmp[2] - Moji<- Op(Ndt,Dt) - Tmp1<- Unscaling(c(X,Y+MARKLEN)) - Tmp2<- Unscaling(c(X,Y-MARKLEN)) - Fd<- Listplot(c(Tmp1,Tmp2)) - Drwline(Fd) - if(Ndt==3){ - Tmp<-Unscaling(c(X,Y-MARKLEN)) - Expr(Tmp,"s",Moji) - } - if(Ndt==4){ - Houkou<- Op(3,Dt) - Tmp<-grep("s",Houkou) - if(length(Tmp)>0){ - Tmp<-Unscaling(c(X,Y-MARKLEN)) - Expr(Tmp,Houkou,Moji) - } - else{ - Tmp<- Unscaling(c(X,Y+MARKLEN)) - Expr(Tmp,Houkou,Moji) - } - } - cat("%\n",file=Wfile,append=TRUE) - } -} - -############################################# -# 2013.08.07 - -Integrate<- function(Fs,Vs, Intv){ - if(is.function(Fs)){ - Fn<- Fs - } - else{ - Str<- paste("Fn<- function(",Vs, ") ", Fs, sep="") - eval(parse(text=Str)) - } - Tmp<- integrate(Fn, Intv[[1]], Intv[[2]]) - Out<- Tmp[[1]] - return(Out) -} - -############################################# - -Intersectcrvs<-function(...) -{ - varargin<-list(...) - Nargs<-length(varargin) - Eps<-10^(-4) - Tmp<-varargin[[Nargs]] - if(mode(Tmp)=="numeric" && length(Tmp)==1) - { - Eps<-Tmp - } - G1<-varargin[[1]] - if(mode(G1)=="numeric") - { - G1<-list(G1) - } - G2<-varargin[[2]] - if(mode(G2)=="numeric") - { - G2<-list(G2) - } - PL<-list() - for (N in 1:length(G1)) - { - for (M in 1:length(G2)) - { - KL<-IntersectcrvsPp(G1[[N]],G2[[M]],Eps) - for (I in Looprange(1,length(KL))) - { - Tmp<-KL[[I]] - P<-Tmp[1] - PL<-append(PL,P) - } - } - } - return(PL) -} - -########################################### - -IntersectcrvsPp<-function(...) -{ - varargin<-list(...) - Nargs<-length(varargin) - G1<-varargin[[1]]; G2<-varargin[[2]] - Eps<- 10.0^(-4) - if(Nargs>2) Eps<-varargin[[3]] - SqEps<- 10.0^(-10) - Eps2<- 0.1 - if(Nargs>3) Eps2<-varargin[[4]] - Data1<-G1 - Data2<-G2 - if(Nrow(Data1)==Nrow(Data2)) - { - Tmp<-seq(Nrow(Data2),1, by=-1) - Tmp1<-Data2[Tmp,] - Eps0<-10^(-6) - Tmp2<-Norm(Data1-Data2) - Tmp3<-Norm(Data1-Tmp1) - if(Tmp20) - { - Tmp<-KL1[[1]] - P<-Tmp[[1]] - T<-Tmp[[2]] - I<-Tmp[[3]] - J<-Tmp[[4]] - Tmp<-list(P,I+T,J) - KL<-list(Tmp) - } - for (N in Looprange(2,length(KL1))) - { - Tmp<-KL1[[N]] - P<-Tmp[[1]] - Flg<-0 - for (K in 1:length(KL)) - { - if(1>length(KL)) break - Tmp<-KL[[K]] - if(Norm(P-Tmp[[1]])^20){ # 13.12.20 - Tmp1<- varargin[[Nall-1]] - if(is.numeric(Tmp1) && length(Tmp1)==1 && Tmp1>0){ # 13.12.20 - Sen<- Tmp1; Gap<- Tmp - Nall<- Nall-2 - } - else{ - Sen<- Tmp; Gap<- Sen - Nall<- Nall-1 - } - } - Sen<- 1000/2.54/MilliIn*Sen - Gap<- 1000/2.54/MilliIn*Gap - for (N in Looprange(1,Nall)){ - Figdata<- varargin[[N]] - Makehasen(Figdata,Sen,Gap,1) - } -} - -######################################### - -Invert<- function(Pd) -{ - OutL=Pd[nrow(Pd):1,] - return(OutL) -} - -############################################ - -InWindow<-function(PA) -{ - Eps<-10.0^(-6); - if((length(PA)==2)&(is.numeric(PA))){ # 17.11.20 - X<-PA[1]; Y<-PA[2]; - if(X>XMIN-Eps && XYMIN-Eps && YEps){ - PtL<- Appendrow(PtL,Qd) - } - else{ - if(is.null(nrow(Qd))){ Qd<- as.matrix(Qd,nrow=1)} - PtL<- Appendrow(PtL,Qd[2:nrow(Qd),]) # 11.06.25 - } - } - return(PtL) -} - -######################################## -# 2011.11.02 - -Joingraphics<- function(...) -{ - varargin<- list(...) - Ls<- Flattenlist(varargin) - N<- length(Ls) - Tp<- Ls[[N]] - Listflg<- 0 - if( is.character(Tp)){ - Tmp<- toupper(substr(Tp,1,1)) - if(Tmp=="L"){ - Listflg<- 1 - } - N<- N-1 - Ls<- Ls[1:N] - } - if(Listflg==1){ - P<- Ls - } - else{ - P<- c() - for (I in 1:N){ - Tmp<- Ls[[I]] - P<- Appendrow(P,c(Inf,Inf)) - P<- Appendrow(P,Tmp) - } - P<- P[2:nrow(P),] - } - return(P) -} - -######################################## - -Kouten<- function(PA,V,P,Q) -{ - Eps<- 10.0^(-6) - A1<- PA[1]; A2<- PA[2] - V1<- V[1]; V2<- V[2] - P1<- P[1]; P2<- P[2] - U1<- Q[1]-P1; U2<- Q[2]-P2 - Tmp<- Norm(P-Q)*Norm(V) - if(Tmp==0) - { - Out<- list(Inf,-Inf) - return(Out) - } - D<- U1*V2-U2*V1 - if(abs(D)/Tmp1+Eps || S=5) - { - Eps<-varargin[[5]] - } - Eps2 <- 0.2 - if(Nargs>=6) - { - Eps2<-varargin[[6]] - } - Eps<-min(Eps2,Eps/sqrt(Sv2)) - P1<-(P[1]*V[1]+P[2]*V[2])/Sv2 - P2<-(-P[1]*V[2]+P[2]*V[1])/Sv2 - Q1<-(Q[1]*V[1]+Q[2]*V[2])/Sv2 - Q2<-(-Q[1]*V[2]+Q[2]*V[1])/Sv2 - m1 <- -Eps; M1 <- 1+Eps - m2 <- -Eps; M2 <- Eps - if(max(P1,Q1)M1) - { - Out<-Inf - return(Out) - } - if(max(P2,Q2)M2) - { - Out<-Inf - return(Out) - } - if(P2*Q2<0) - { - T<- P1-(Q1-P1)/(Q2-P2)*P2 - if(T>m1 && T -Eps0 && T<1+Eps0) - { - Tmp1<-A+T*V - Tmp2<-min(max(T,0),1) - Out<-list(Tmp1,Tmp2,0) - } - else - { - Tmp1<-A+T*V - Tmp2<-min(max(T,0),1) - Out<-list(Tmp1,Tmp2,1) - } - return(Out) - } - if(P1M1 || P2M2) - { - if(Q1M1 || Q2M2) - { - Out<-Inf - return(Out) - } - T<-min(max(Q1,0),1) - Tmp=A+T*V - Out<-list(Tmp,T,1) - return(Out) - } - T<-min(max(P1,0),1) - Tmp<-A+T*V - Out<-list(Tmp,T,1) - return(Out) - } - if(P1> -Eps0 && P1<1+Eps0 && P2> -Eps0 && P2 < Eps0) - { - T<- P1 - Tmp<- A+T*V - Out<- list(Tmp, T, 0) - return(Out) - } - if(Q1> -Eps0 && Q1<1+Eps0 && Q2> -Eps0 && Q2M1 || P2M2) - { - if(Q1M1 || Q2M2) - { - Out<-Inf - return(Out) - } - T<-min(max(Q1,0),1) - Tmp<-A+T*V - Out<-list(Tmp,T,1) - return(Out) - } - if(Q1M1 || Q2M2) - { - T<-min(max(P1,0),1) - Tmp<-A+T*V - Out<-list(Tmp,T,1) - return(Out) - } - if(abs(P2)Eps) - { - QL<-Pt1 - } - Tmp<-Appendrow(QL,PL[(N1+1):N2,]) - QL<- Tmp - if(Norm(Pt2-Op(N2,PL))>Eps) - { - Tmp<-Appendrow(QL,Pt2) - QL<- Tmp - } - HidariL<- QL - Ms<- M2+1; Me<- M1 - if(T1Eps) - { - Tmp<-Append(HidariL,P) - HidariL<-Tmp - } - } - Tmp<- Op(Nrow(HidariL),HidariL) - if(Norm(Tmp-Pt1)>Eps) - { - Tmp<-Append(HidariL,Pt1) - HidariL<-Tmp - } - MigiL<- QL - Ms<- M2; Me<- M1+1 - if(T1>T2-Eps) Me<- Me-4 - for (Mm in Looprange(Me,Ms)) - { - M<- Me+Ms-Mm - Tmp<- Op(Nrow(MigiL),MigiL) - P<- Op(((M-1) %% 4)+1,Sikaku) - if(Norm(Tmp-P)>Eps) - { - Tmp<-Appendrow(MigiL,P) - MigiL<-Tmp - } - } - Tmp<- Op(Nrow(MigiL),MigiL) - if(Norm(Tmp-Pt1)>Eps) - { - Tmp<-Appendrow(MigiL,Pt1) - MigiL<-Tmp - } - Out<- list(HidariL,MigiL) - return(Out) -} - -################################### -# 17.09.24 Eps - -Kyoukai<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps0<- 10^(-7) - DataL<-list() - for (I in 1:Nargs){ - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric"){ - DataL<- Mixjoin(DataL,list(list(Tmp))) - } - if(mode(Tmp)=="list"){ - if(mode(Tmp[[1]])!="list"){ - DataL<- Mixjoin(DataL, list(Tmp)) - } - else{ - DataL<-Mixjoin(DataL,Tmp) - } - } - } - Eps<- 10.0^(-4) #17.09.24 - PLall<- list() - Sflg<- 0 - N<- length(DataL) - 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 - } - else{ - if(mode(Tmp)=="character"){ - Rg<- Tmp ; Nd<-length(Data)-1 - } - else{ - Rg<- "c" ; Nd<-length(Data) - } - } - for (J in Looprange(1,Nd)){ - Tmp<- Op(J,Data) - if(mode(Tmp)=="character"){ - Rg<- Tmp - next - } - Points<- Tmp - P1<- Ptstart(Points) - P2<- Ptend(Points) - if(J==1){ - PL<- Points - Pfirst<- P1 - Plast<- P2 - if(Nd>=2){ - Tmp<- Op(2,Data) - P<- Ptstart(Tmp) - Q<- Ptend(Tmp) - if(Norm(P2-P)>Eps && Norm(P2-Q)>Eps){ - Tmp< Length(PL) - PL<-PL[Tmp:1,] - Pfirst<- Ptstart(PL) - Plast<- Ptend(PL) - } - } - } - else{ - if(Norm(P1-Plast)Eps){ - Np<- Length(PL) - if(Rg=="c"){ - Tmp<- Appendrow(PL,Pfirst) - PL<- Tmp - } - else if(Rg=="s"){ - Tmp<- c(PL[1:Np,2],YMIN) - Y<- min(Tmp)-1 - P<- c(Plast[1],Y); Q<- c(Pfirst[1],Y) - Tmp<- Appendrow(PL,P) - Tmp=Appendrow(Tmp,Q) - PL=Appendrow(Tmp,Pfirst) - } - else if(Rg=="n"){ - Tmp<- c(PL[1:Np,2],YMAX) - Y<-max(Tmp)+1 - P<- c(Plast[1],Y); Q<- c(Pfirst[1],Y) - Tmp<- Appendrow(PL,P) - Tmp<- Appendrow(Tmp,Q) - PL<- Appendrow(Tmp,Pfirst) - } - else if(Rg=="w"){ - Tmp<- c(PL[1:Np,1],XMIN) - X<- min(Tmp)-1 - P<- c(X,Plast[2]); Q<- c(X,Pfirst[2]) - Tmp<- Appendrow(PL,P) - Tmp<- Appendrow(Tmp,Q) - PL<- Appendrow(Tmp,Pfirst) - } - else if(Rg=="e"){ - Tmp<- c(PL[1:Np,1],XMAX) - X<- max(Tmp)+1 - P<- c(X,Plast[2]); Q<- c(X,Pfirst[2]) - Tmp<- Appendrow(PL,P) - Tmp<- Appendrow(Tmp,Q) - PL<- Appendrow(Tmp,Pfirst) - } - else if(mode(Rg)=="numeric" && Nrow(Rg)==1 && length(Rg)>1){ - Tmp<- Kukeiwake(PL) - Tmp1<- Op(1,Tmp) - Tmp2<- Naigai(Rg,list(Tmp1)) - if(Tmp2==c(1)){ - PL<-Op(1,Tmp) - } - else{ - PL<- Op(2,Tmp) - } - } - } - Tmp<- Ptstart(PL) - for (J in Looprange(2,Length(PL))){ - P<- Op(J,PL) - Q<- Op(Length(Tmp),Tmp) - if(Norm(P-Q)>Eps){ - Tmp1<-Appendrow(Tmp,P) - Tmp<-Tmp1 - } - } - PL<-Tmp - PLall<-c(PLall,list(PL)) - } - if(length(PLall)==1 && Sflg==0){ - Tmp<- Op(1,PLall) -# Tmp<- Op(1,Tmp) - if(Norm(Ptstart(Tmp)-Ptend(Tmp))>Eps0){ - Tmp1<- Appendrow(Tmp,Ptstart(Tmp)) - PLall<- list(Tmp1) - } - } - return(PLall) -} - -###################################### - -Letter<-function(...) -{ ## Scaling is implemented - varargin<-list(...) - Nargs<-length(varargin) - Irng<-c(seq(from=1,to=Nargs,by=3)) - for (I in Irng) - { - Tmp<-varargin[[I]] - P<- Doscaling(Tmp) - X<-P[1] - Y<-P[2] - Houkou<-varargin[[I+1]] - Mojiretu<-varargin[[I+2]] - Hset<-Houkou - Vhoko<-"c" - if(length(grep("n",Hset))>0) - { - Vhoko<-"n"; Y<-Y+MEMORI - } - if(length(grep("s",Hset))>0) - { - Vhoko<-"s"; Y<-Y-MEMORI - } - Hhoko<-"c" - if(length(grep("e",Hset))>0) - { - Hhoko<-"e"; X<-X+MEMORI - } - if(length(grep("w",Hset))>0) - { - Hhoko<-"w"; X<-X-MEMORI - } - Hoko<-paste(Vhoko,Hhoko,sep="") - Suu<-"+-.0123456789" - SuuL<-Suu - J<-1; Dstr<-"" - while (J<=nchar(Houkou)) - { - Tmp<-substring(Houkou,J,J) - if(length(grep(Tmp,SuuL))>0) - { - if(Dstr=="") Hk<-substring(Houkou,J-1,J-1) - Dstr<-paste(Dstr,Tmp,sep="") - } - else - { - if(Dstr!="") - { - Nmbr<-as.numeric(Dstr) - D<-Nmbr*MEMORI - if(Hk=="n") Y<-Y+D - if(Hk=="s") Y<-Y-D - if(Hk=="e") X<-X+D - if(Hk=="w") X<-X-D - Dstr<-"" - } - } - J<-J+1 - } - if(Dstr!="") - { - Nmbr<-as.numeric(Dstr) - D<-Nmbr*MEMORI; - if(Hk=="n") Y<-Y+D - if(Hk=="s") Y<-Y-D - if(Hk=="e") X<-X+D - if(Hk=="w") X<-X-D - } - CalcWidth(Hoko,Mojiretu) - CalcHeight(Hoko,Mojiretu) - cat("\\put(",file=Wfile,append=TRUE) - Tmp1<- sprintf("%7.7f",X) # 11.07.19 - Tmp2<- sprintf("%7.7f",Y) # 11.07.19 - Str<-paste(Tmp1,",",Tmp2,sep="") - cat(Str,file=Wfile,append=TRUE) - Tmp<-"){\\hspace*{\\Width}" - Str<-paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - cat("%\n",file=Wfile,append=TRUE) - } -} - -###################################################### - -Letterrot<- function(...) -{ - varargin<- list(...) - P<- varargin[[1]] - V<- varargin[[2]]; N<- 3 - P<- Doscaling(P) - V<- Doscaling(V) - Tmov<- 0 - Tmp<- varargin[[N]] - if(mode(Tmp)=="numeric"){ - Tmov<- Tmp; N<- N+1 - } - Nmov<- 0 - Tmp<- varargin[[N]] - if(mode(Tmp)=="numeric"){ - Nmov<- Tmp; N<- N+1 - } - Mojiretu<- Assign(varargin[[N]]) #2017.11.26 - Tv<- 1/Norm(V)*V - Nv<- c(-Tv[2],Tv[1]) - P<- P+MEMORI*Tmov*Tv+MEMORI*Nmov*Nv - Tmp<- acos(V[1]/Norm(V)) - Theta<- round(Tmp*180/pi) - if(V[2]>=0){ - Units<- "" - } - else{ - Units<- "units=-360," - } - Tmp<- paste("\\rotatebox[",Units,"origin=c]{",as.character(Theta),sep="") - Tmp<- paste(Tmp,"}{",Mojiretu,"}",sep="") - Letter(P,"c",Tmp) -} - -################################### -# 10.12.04 - -Lineplot<-function(...) -{ - varargin <- list(...) - Nargs<-length(varargin) - A<-varargin[[1]] - if(is.numeric(A)) { - Tmp<-length(A) - if(Tmp>3) { - B <- A[(Tmp/2+1):Tmp] - A <- A[1:(Tmp/2)] - Is <- 2 - } - else { - B<-varargin[[2]] - Is <- 3 - } - } - else { - B<-A[[2]] - A<-A[[1]] - Is <- 2 - } - Mag <- 100 ; Semi <- "" ## 10.12.04 - for (I in Looprange(Is,Nargs)) { - Tmp <- varargin[[I]] - switch ( mode(Tmp), - "numeric"= Mag <- Tmp, - "character"= Semi <- Tmp - ) - } -V<- Mag/Norm(B-A)*(B-A) ## 10.12.04 from here - if(Semi=="") { - Out<- Listplot(c(A-V,A+V)) - } - else if(Semi=="+") { - Out<- Listplot(c(A,A+V)) - } - else { - Out<- Listplot(c(A-V,A)) - } ## 10.12.04 to here - return(Out) -} - -################################ - -Listplot<-function(...) -{ - varargin<-list(...); - Z<-c(); - 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) - } - else - Z<-Appendrow(Z,Data) - } - else - { - for (J in 1:length(Data)) - { - Tmp<-Data[[J]]; - Z<-Appendrow(Z,Tmp) - } - } - } - return(Z) -} - -############################## - -MakeBowdata <- function(PA,PB,H) -{ - Eps <- 10^(-5) - BOWSTART <<- PA - BOWEND <<- PB - D <- 1/2*Norm(PB-PA) - R <- (H^2+D^2)/(2*H) - A1 <- PA[1]; A2<-PA[2] - B1 <- PB[1]; B2<-PB[2] - if(abs(A2-B2)>Eps){ -# x <- poly(0,"X") -# y <- -(A1-B1)*x/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) -# Eq1 <- (A1-x)^2+(A2-y)^2-R^2 -# Tmp <- coeff(Eq1) -# C0 <- Tmp[1]; C1<-Tm[2]; C2<-Tmp[3] - C0<- A1^2+(A2-(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2))^2-R^2 - C1<- -(A1+B1)*(A2^2+B2^2-2*A2*B2-2*A1*B1+A1^2+B1^2)/(A2-B2)^2 - C2<- 1+(A1-B1)^2/(A2-B2)^2 - Det <- sqrt(C1^2-4*C0*C2) - Ansx1 <- (-C1+Det)/(2*C2) - Ansx2 <- (-C1-Det)/(2*C2) - Tmp <- -(A1-B1)*Ansx1/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) - PC <- c(Ansx1,Tmp) - Tmp <--(A1-B1)*Ansx2/(A2-B2)+(1/2)*(A1^2+A2^2-B1^2-B2^2)/(A2-B2) - PC2 <- c(Ansx2,Tmp) - } - else{ - Tmp <- 0.5*(PA+PB) - PC <- Tmp+c(0,R-H) # 11.06.02 - PC2 <- Tmp-c(0,R-H) - } - VA <- PA-PC - VB <- PB-PC - if(VA[1]*VB[2]-VA[2]*VB[1]<0) { - PC <- PC2 - } - AngA <- acos((PA[1]-PC[1])/R) - if(PA[2]-PC[2]<0){ - AngA <- -AngA - } - AngB <- acos((PB[1]-PC[1])/R) - if(PB[2]-PC[2]<0){ - AngB <- -AngB - } - if(AngA>AngB) { - AngB <- AngB+2*pi - } - Out <- list(PC,R,AngA,AngB) - return(Out) -} - -#################################################### - -MakeCurves<-function(...){ ## Scaling is implemented - varargin<-list(...) - Figdata<-varargin[[1]] - if(class(Figdata)=="numeric"){ - Figdata<-matrix(Figdata,nrow=1) - } - Ptout<-1 - if(length(varargin)>=2) Ptout<-varargin[[2]] - Eps<-10.0^(-6) - IndM<-Dataindex(Figdata) - Atos<-c() - for (Nd in 1:Nrow(IndM)){ - Tmp<-IndM[Nd,] - Motos<-Figdata[Tmp[1]:Tmp[2],] - All<-Nrow(Motos) - if(Nrow(Motos)==1){ - if(InWindow(Motos)=="o"){ - next - } - Tmp1<- as.numeric(Motos) - if(Ptout==1){ - Drwpt(Tmp1) - } - else{ - Tmp1<- Doscaling(Tmp1) - Atos<-Appendrow(Atos,c(Inf,Inf),Tmp1) - next - } - } - Crv<-c() - for (I in Looprange(2,All)){ - P<- Op(I-1,Motos) - Q<- Op(I,Motos) - Snbn<-MeetWindow(P,Q) - if(length(Snbn)==0){ - if(length(Crv)>0){ - Atos<-Appendrow(Atos,c(Inf,Inf),Doscaling(Crv)) - Crv<-c() - } - } - else{ - if(Norm(Snbn[1,]-Snbn[2,])=2) - { - Atos<-Appendrow(Atos,c(Inf,Inf),Doscaling(Crv)) - } - } - Outdata<-Atos[2:Nrow(Atos),] - if(class(Outdata)=="numeric") - { - Outdata<-matrix(Outdata,nrow=1) - } - return(Outdata) -} - -###################################### - -Makehasen<- function(Figdata,Sen,Gap,Ptn) -{ - Eps<- 10.0^(-6) - Clist<- MakeCurves(Figdata) - DinM<- Dataindex(Clist) - for (N in Looprange(1,Nrow(DinM))){ - Tmp<- DinM[N,] - Data<- Clist[Tmp[1]:Tmp[2],] - Dtall<- Nrow(Data) - Len<- 0 - Lenlist<- c(0) - for (I in Looprange(2,Dtall)){ - Len<- Len+Norm(Data[I,]-Data[I-1,]) - Lenlist<- c(Lenlist,Len) - } - Lenall<- Lenlist[Dtall] - if(Lenall==0){ - next - } - Kari<- (Sen+Gap)*0.1 - Naga<- Sen*0.1 - Tobi<- Gap*0.1 - if(Norm(Data[1,]-Data[Dtall,])=Lenlist[J]-Eps){ - if(J==Dtall){ - break - } - J<- J+1 - } - Hajime<- J-1 - J<- Hajime - while (Len+Naga>Lenlist[J]-Eps){ - if(J==Dtall){ - break - } - J<- J+1 - } - Owari<- J-1 - T<- (Len-Lenlist[Hajime]) - T<- T/(Lenlist[Hajime+1]-Lenlist[Hajime]) - P<- Data[Hajime,]+T*(Data[Hajime+1,]-Data[Hajime,]) - X<- as.character(round(MilliIn*P[1])) - Y<- as.character(-round(MilliIn*P[2])) - Str<- paste("\\special{pa ",X," ",Y,"}",sep="") - cat(Str,file=Wfile,append=TRUE) - Mojisu<- Mojisu+nchar(Str) - for (J in Looprange(Hajime+1,Owari)){ - P<- Data[J,] - X<- as.character(round(MilliIn*P[1])) - Y<- as.character(-round(MilliIn*P[2])) - Str<- paste("\\special{pa ",X," ",Y,"}",sep="") - cat(Str,file=Wfile,append=TRUE) - Mojisu<- Mojisu+nchar(Str) - } - T<- (Len+Naga-Lenlist[Owari]) - T<- T/(Lenlist[Owari+1]-Lenlist[Owari]) - P<- Data[Owari,]+T*(Data[Owari+1,]-Data[Owari,]) - X<- as.character(round(MilliIn*P[1])) - Y<- as.character(-round(MilliIn*P[2])) - Str1<- paste("\\special{pa ",X," ",Y,"}",sep="") - Str2<- "\\special{fp}" - cat(Str1,file=Wfile,append=TRUE) - cat(Str2,file=Wfile,append=TRUE) - Mojisu<- Mojisu+nchar(Str1)+nchar(Str2) - if(Mojisu>80){ - cat("%\n",file=Wfile,append=TRUE) - Mojisu<- 0 - } - } - } - cat("%\n%\n",file=Wfile,append=TRUE); -} - -###################################### - -Makeliststr<- function(L) -{ - Out="list(" - for (I in 1:length(L)){ - Dt<- L[[I]] - if(mode(Dt)=="numeric"){ - if(length(Dt)==1){ - Dts<- as.character(Dt) - } - else{ - Dts<- "c(" - for (J in Looprange(1,Nrow(Dt))){ - for (K in 1:ncol(Dt)){ - Dts<- paste(Dts,as.character(Dt[J,K]),sep="") - if(K< ncol(Dt)){ - Dts<- paste(Dts,",",sep="") - } - } - if(JEps){ - if(Member(Ptn,PtnL)){ - if(abs(Te-Ts)>Eps){ - if(Nrow(GL)>0){ - Tmp<- Mixjoin(Out, list(GL)) - Out<- Tmp - } - GL<- Listplot(P,Q) - } - else{ - Tmp <- Appendrow(GL, Q) - GL<- Tmp - } - Te<- Op(1,TenQ) - } - } - } - if(Nrow(GL)>0){ - Tmp<- Mixjoin(Out, list(GL)) - Out<- Tmp - } - return(Out) -} - -############################################# - -Mawarikomi<- function(...) -{ - varargin<- list(...) - haba<- "10cm" - Nargs<- length(varargin) - if(Nargs>0){ - haba<- varargin[[1]] - } - cat("\\begin{mawarikomi}%\n",file="",append=TRUE) - cat("%<1>[5](0,0)%\n",file="",append=TRUE) - Str<- paste("{",haba,"}{%\n",sep="") - cat(Str,file="",append=TRUE) - cat("}%\n",file="",append=TRUE) - cat("\\end{mawarikomi}",file="",append=TRUE) -} - -############################################## - -MeetWindow<-function(PA,PB) -{ - if(InWindow(PA)=="i" && InWindow(PB)=="i") - { - R<-Appendrow(PA,PB) - return(R) - }; - Horner<-function(n,t) - { - PT<-(1-t)*PA+t*PB; - return(PT[n]) - } - Eps<-10.0^(-6); - Txm<-(-1); TxM<-(-1); Tym<-(-1); TyM<-(-1); - if(PA[1]!=PB[1]) - { - Txm<-(XMIN-PA[1])/(PB[1]-PA[1]); - TxM<-(XMAX-PA[1])/(PB[1]-PA[1]); - } - if(PA[2]!=PB[2]) - { - Tym<-(YMIN-PA[2])/(PB[2]-PA[2]); - TyM<-(YMAX-PA[2])/(PB[2]-PA[2]); - } - Tmp<-Horner(2,Txm); - if(TmpYMAX+Eps) - { - Txm<-(-1); - } - Tmp<-Horner(2,TxM); - if(TmpYMAX+Eps) - { - TxM<-(-1) - } - Tmp<-Horner(1,Tym); - if(TmpXMAX+Eps) - { - Tym<--1 - } - Tmp<-Horner(1,TyM); - if(TmpXMAX+Eps) - { - TyM<--1 - } - Tans<-sort(c(Txm,TxM,Tym,TyM)); - Tmp<-c(); - for (I in 1:length(Tans)) - { - Tmp1<-Tans[I]; - if(Tmp1>-Eps && Tmp1<1+Eps) - { - if(length(Tmp)==0) - { - Tmp<-c(Tmp1); - } - else - { - if(abs(Tmp[length(Tmp)]-Tmp1)>Eps) - { - Tmp<-c(Tmp,Tmp1) - } - } - } - } - Tans<-Tmp; - if(length(Tans)==0) - { - R<-c(); - return(R); - } - if(length(Tans)==1) - { - Ten1<-Horner(1:2,Tans[1]); - if(InWindow(PA)=="i") - { - R<-Appendrow(PA,Ten1) - return(R) - } - else - { - R<-Appendrow(Ten1,PB) - return(R) - } - } - Ten1<-Horner(1:2,Tans[1]) - Ten2<-Horner(1:2,Tans[2]) - R<-Appendrow(Ten1,Ten2) - return(R) -} - -######################################### - -# New 10.03.21 - -Mixjoin<-function(...) -{ - varargin<-list(...) - Nargs<- length(varargin) - M<- list() - for (I in 1:Nargs) - { - Tmp<-varargin[[I]] - if(length(Tmp)==0) next - if(Mixtype(Tmp)==1) - { - Tmp<-list(Tmp) - } - if(length(M)==0){ - M <- Tmp - } - else{ - M<- c(M,Tmp) - } - } - return(M) -} - -################################# - -Mixlength<- function(PL){ - if(length(PL)==0){ - return(0) - } - if(Mixtype(PL)==1){ - Out<- Nrow(PL) - } - else{ - Out<- length(PL) - } - return(Out) -} - -########################################### - -Mixtype<- function(D) -{ - if(mode(D)!="list") return(1) - for (I in 1:length(D)) - { - Tmp<- D[[I]] - if(mode(Tmp)=="list") return(3) - } - return(2) -} - -########################################### - -Naigai<- function(A,Bdy) -{ - V<- c(1,1) - Call<-length(Bdy) - KL<- KoutenList(A,V,Bdy) - Ptn<- seq(1,1,length=Call) - for (K in Looprange(1,length(KL))) - { - Ten<- Op(K,KL) - T<- Op(1,Ten); NC<- Op(4,Ten) - if(T<0) - { - Tmp<- (Ptn[NC]+1) %% 2 - Ptn[NC]<- Tmp - } - } - return(Ptn) -} - -######################################## - -Nearestpt<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - PL1<- varargin[[1]] - if(!is.matrix(PL1)){ - Tmp<- matrix(PL1); - PL1<- t(Tmp) - } - if(Nrow(PL1)==1) Flg=0 - else Flg=1 - Eps<- 10.0^(-6) - PL<- varargin[[2]] - Ans<- list(PL1[1,],1,PL[1,],1,Norm(PL1[1,]-PL[1,])) - for(N in Looprange(1,Nrow(PL1))){ - PA<- PL1[N,] - Pm<- PL[1,] - Im<- 1 - Sm<- Norm(Pm-PA) - for(I in Looprange(1,Nrow(PL)-1)){ - A1<- PL[I,1]; A2<-PL[I,2] - B1<- PL[I+1,1]; B2<-PL[I+1,2] - V1<- B1-A1; V2<-B2-A2 - X1<- PA[1]; X2<-PA[2] - Tmp<-V2^2+V1^2 - if(abs(Tmp)1+Eps){ - P<- c(B1,B2) - }else{ - P<- c(A1+T*V1,A2+T*V2) - } - } - S<- Norm(P-PA) - if(SN){ - Posstr<- paste("[",varargin[[N+1]],"]",sep="") - } - else{ - Posstr<- "[c]" - } - Openphr(Namestr) - S<- paste("\\begin{minipage}",Posstr,"{",Habastr,"}%\n",sep="") - cat(S,file=Wfile,append=TRUE) -} - -################################### - -Openphr<- function(Str) -{ - S<- paste("\\def",Str,"{%\n",sep="") - cat(S,file=Wfile,append=TRUE) -} - -##################################### - -Ovalbox<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Pos<- varargin[[1]] - Dr<- varargin[[2]] - StrV<- varargin[[3]] - R<- 0.2 - NDflg<- 0 - for (I in Looprange(4,Nargs)){ - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric"){ - R<- Tmp - } - else{ - if(substr(Tmp,1,1)=="-"){ - NDflg<- 1 - Tmp1<- substr(Tmp,2,nchar(Tmp)) - Cmdstr<- chartr("*","G",Tmp1) - } - } - } - Xr<- c(XMIN,XMAX) - Yr<- c(YMIN,YMAX) - Uv<- 0.6; Uh<- 0.8 - N<- nchar(StrV) - W<- Uh;H<- Uv*N - Setwindow(c(-W/2,W/2),c(-H,0)) - G<- Ovaldata(c(0,-H/2),W/2,H/2,R) - Openphr("\\ketpictmp") - Beginpicture("1cm") - if(NDflg==0){ - Drwline(G) - } - else{ - eval(parse(text=Cmdstr)) - } - for (I in Looprange(1,N)){ - Letter(c(0,Uv/2-Uv*I),"c",Op(I,StrV)) - } - Endpicture(0) - Closephr() - Setwindow(Xr,Yr) - Letter(Pos,Dr,"\\ketpictmp") -} - -########################################## - -Ovaldata<- function(...) #17.09.11 -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==1){ - Eps<- 1.0*10^(-4) - C<- c((XMIN+XMAX)/2,(YMIN+YMAX)/2) - Dx<- XMAX-C(1)-Eps - Dy<- YMAX-C(2)-Eps - N<- 1 - } - else{ - C<- varargin[[1]] - Dx<- varargin[[2]] - Dy<- varargin[[3]] - N<- 4 - } - Rc<- 0.2 - if(N<=Nargs){ #15.11.15 - Rc<- varargin[[N]]*Rc #15.11.15 - } - Out<- c() - P<- C+c(Dx-Rc,Dy-Rc) - Tmp1<- Circledata(c(P,Rc),"R=c(0,pi/2)","N=10") #17.11.29 - Tmp2<- Listplot(C+c(Dx-Rc,Dy),C+c(0,Dy)) - Tmp3<- Listplot(C+c(Dx,0),C+c(Dx,Dy-Rc)) - G<- Joincrvs(Tmp3,Tmp1,Tmp2) - Tmp<- Reflectdata(G,c(C,C+c(0,1))) - G<- Joincrvs(G,Tmp) - Tmp<- Reflectdata(G,c(C,C+c(1,0))) - Out<- Joincrvs(G,Tmp) -} - -######################################### - -Paramark<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - PA<- varargin[[1]] - PB<- varargin[[2]] - PC<- varargin[[3]] - R<- 0.5 - if(Nargs>=4){ - R<- varargin[[4]]*R - } - U<- R*(PA-PB)/Norm(PA-PB) - V<- R*(PC-PB)/Norm(PC-PB) - if(Crossprod(PA-PB,PC-PB)!=0){ - P<- Listplot(c(PB+U,PB+U+V,PB+V)) - } - else{ - P<- c() - } -} - -########################################### - -Paramoncurve<-function(...){ - varargin<-list(...) - Nargs<-length(varargin) - Eps<-10^(-8) - P<-varargin[[1]] - Gdata<-varargin[[Nargs]] - if(Nrow(P)>1){ - Tmp<-P; P<-Gdata; Gdata<-Tmp - } - if(Nargs==2){ - Tmp<-Nearestpt(P,Gdata) - Out<-Tmp[[2]] - return(Out) - } - N<-varargin[[2]] - PtL<-Gdata - N=min(N,Length(PtL)-1) #18.02.11from - Pa<-Ptcrv(N,PtL) - Pb<-Ptcrv(N+1,PtL) - V<-Pb-Pa - W<-P-Pa - D2<-Norm(V)^2 - if(D20) - { - E<-sort(E) - E0 && Op(Nrow(P),P)!=c(Inf,Inf)) - { - Pa<- c(Inf,Inf) - } - } - if(t-E[Ke]>Eps) - { - if(Fnflg==0) - { - Tmp<- eval(parse(text=Str)) - Pa<- Tmp - } - else - { - } - Ke<-Ke+1 - } - if(length(Pa)>0) - { - if(Pa[1]==Inf) - { - Tmp<-Appendrow(P,Pa) - P<-Tmp - } - else - { - if(Nrow(P)==0) - { - Tmp<- Appendrow(P,Pa) - P<-Tmp - } - else - { - Tmp<- Op(Nrow(P),P) - if(Tmp[1]==Inf) - { - Tmp<- Appendrow(P,Pa) - P<- Tmp - } - else - { - if(Norm(Tmp-Pa)B+Eps){ - Npt<- Numptcrv(PkL) - Out1<- Partcrv(A,Npt,PkL) - Out2<- Partcrv(1,B,PkL) - Tmp<- Ptstart(PkL)-Ptend(PkL) - if(Norm(Tmp)Ie+Eps){ - P<- (1-B+Ie)*PkL[Ie,]+(B-Ie)*PkL[Ie+1,] - PL<- Appendrow(PL,P) - } - Ans<- PL - return(Ans) - } - Tmp<- Nearestpt(A,PkL) - Ta<- Op(2,Tmp) - Tmp<- Nearestpt(B,PkL) - Tb<- Op(2,Tmp) - Ans<- Partcrv(Ta,Tb,PkL) -} - -########################################## -# 13.05.03 - -Partframe<- function(Tb,St,Ed) -{ - G<- Dividetable(Tb) - Gw<- G[[1]] - Gt<- G[[2]] - Gy<- G[[3]] - Gwt<- Tb[[4]] - Gwy<- Tb[[5]] - Gat<- c(list(Gwt[[1]]),Gt,list(Gwt[[2]])) - Gay<- c(list(Gwy[[1]]),Gy,list(Gwy[[2]])) - Tmp1<- Ptstart(Gat[[St[1]]]) - Tmp2<- Ptstart(Gay[[St[2]]]) - Ps<- c(Tmp1[1],Tmp2[2]) - Tmp1<- Ptstart(Gat[[Ed[1]]]) - Tmp2<- Ptstart(Gay[[Ed[2]]]) - Pe<- c(Tmp1[1],Tmp2[2]) - Pars<- Paramoncurve(Ps,Gw) - Pare<- Paramoncurve(Pe,Gw) - if(Pars0){ - E<-sort(E) - E0){ - Tmp<-eval(parse(text=Exfun)) - if(abs(Tmp)0 && P[Nrow(P),]!=c(Inf,Inf)){ - Pa<- c(Inf,Inf) - } - } - if(x-E[Ke]>Eps){ - Tmp<- eval(parse(text=Str)) - Pa<- c(x,Tmp) - Ke<-Ke+1 - } - if(length(Pa)>0){ - if(Pa[1]==Inf){ - Tmp<-Appendrow(P,Pa) - P<-Tmp - } - else{ - if(Nrow(P)==0){ - Tmp<- Appendrow(P,Pa) - P<-Tmp - } - else{ - Tmp<- P[Nrow(P),] - if(Tmp[1]==Inf){ - Tmp<- Appendrow(P,Pa) - P<- Tmp - } - else{ - if(Norm(Tmp-Pa)1) - { - Tmp<-T; T<-Gdata; Gdata<-Tmp - } - PtL<-Gdata - N<-trunc(T+Eps); - S<-max(T-N,0); - if(N==Nrow(PtL)) - { - Out<-PtL[N,] - } - else - { - Pa<-PtL[N,] - Pb<-PtL[N+1,] - Out<-(1-S)*Pa+S*Pb - } - return(Out) -} - -############################################## -# 10.11.20 -# 13.05.03 Inf - -Pointdata<-function(...) -{ - varargin<-list(...) - Nargs<-length(varargin) - PL<- list() - for (I in Looprange(1,Nargs)){ # 10.11.20 - DL<-varargin[[I]] - DL<- Flattenlist(DL) # 10.11.20 from here - for (J in Looprange(1,length(DL))){ - Dt<- DL[[J]] - if(is.matrix(Dt)|| is.data.frame(Dt)){ - for (K in 1:nrow(Dt)){ - Tmp<- as.numeric(Dt[K,]) - if(Tmp[1]0){ #18.02.09 - return(Op(Length(Fig),Fig)) - }else{ - return(c()) - } -} - -######################################### - -Ptne<-function(...) -{ - varargin<- list(...) - if(length(varargin)==0){ - Out<- c(XMAX,YMAX) - } - else{ - G<- varargin[[1]] - XM<- max(G[,1]) - YM<- max(G[,2]) - Out<- c(XM,YM) - } - return(Out) -} - -######################################### - -Ptnw<-function(...) -{ - varargin<- list(...) - if(length(varargin)==0){ - Out<- c(XMIN,YMAX) - } - else{ - G<- varargin[[1]] - Xm<- min(G[,1]) - YM<- max(G[,2]) - Out<- c(Xm,YM) - } - return(Out) -} - -######################################### - -Ptse<-function(...) -{ - varargin<- list(...) - if(length(varargin)==0){ - Out<- c(XMAX,YMIN) - } - else{ - G<- varargin[[1]] - XM<- max(G[,1]) - Ym<- min(G[,2]) - Out<- c(XM,Ym) - } - return(Out) -} - -############################################# - -Ptstart<-function(Fig) -{ - if(Length(Fig)>0){ #18.02.09 - return(Op(1,Fig)) - }else{ - return(c()) - } -} - -######################################### - -Ptsw<-function(...) -{ - varargin<- list(...) - if(length(varargin)==0){ - Out<- c(XMIN,YMAX) - } - else{ - G<- varargin[[1]] - Xm<- min(G[,1]) - Ym<- min(G[,2]) - Out<- c(Xm,Ym) - } - return(Out) -} - -############################################## - -Putcell<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - Str<- varargin[[Nargs]] - if(mode(Str)=="numeric"){ - Str<- as.character(Str) - } - Pos<- varargin[[Nargs-1]] - Nrg<- varargin[[2]] - if(mode(Nrg)=="character"){ - if(Nargs==4){ - Cell<- Findcell(TbL,Nrg) - } - else{ - Mrg<- varargin[[3]] - Cell<- Findcell(TbL,Nrg,Mrg) - } - } - else{ - Mrg<- varargin[[3]] - Cell<- Findcell(TbL,Nrg,Mrg) - } - Pt<- Cell[[1]]; Dr<- "c" - Posh<- substr(Pos,1,1) - Post<- substr(Pos,2,nchar(Pos)) - if(toupper(Posh)=="R"){ - Pt<- Pt+c(Cell[[2]],0) - if(nchar(Post)==0){ - Dr<- "w1" - } - else{ - Dr<- paste("w",Post,sep="") - } - } - if(toupper(Posh)=="L"){ - Pt=Pt-c(Cell[[2]],0) - if(nchar(Post)==0){ - Dr<- "e1" - } - else{ - Dr<- paste("e",Post,sep="") - } - } - if(toupper(Posh)=="U"){ - Pt<- Pt+c(0,Cell[[3]]) - if(nchar(Post)==0){ - Dr<- "s1" - } - else{ - Dr<- paste("s",Post,sep="") - } - } - if(toupper(Posh)=="D"){ - Pt<- Pt-c(0,Cell[[3]]) - if(nchar(Post)==0){ - Dr<- "n1" - } - else{ - Dr<- paste("n",Post,sep="") - } - } - if(toupper(Posh)=="B"){ - Pt<- Pt-c(0,Cell[[3]]) - if(nchar(Post)==0){ - Dr<- "n1" - } - else{ - Dr<- paste("n",Post,sep="") - } - Str<- paste("$\\mathstrut$",Str,sep="") - } - Letter(Pt,Dr,Str) -} - -############################################# - -PutcoL<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - if(mode(TbL)!="list"){ - return("Tabledata missing") - } - Ag<- varargin[[2]] - if(mode(Ag)=="numeric"){ - CoL<- Ag - } - else{ - Alpha<- "-ABCDEFGHIJKLMNOPQRSTUVWXYZ" - Clm<- c() - for (I in Looprange(1,nchar(Ag))){ - C<- substr(Ag,I,I) - C<- toupper(C) - Tmp<- strsplit(Alpha,C) - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - Tmp1<- nchar(Tmp[1]) - Clm<- c(Clm,Tmp1) - } - } - Nrg<- 0 - for (I in seq(length(Clm),1,by=-1)){ - Tmp<- Clm[I] - Tmp1<- length(Clm)-I - Nrg<- Nrg+Tmp*26^Tmp1 - } - CoL<- Nrg - } - Nc<- length(TbL[[3]])+1 - K<- 1 - Dpos<- varargin[[3]] - for (I in Looprange(4,Nargs)){ - if(I-3>Nc){ - break - } - Dt<- varargin[[I]] - if(mode(Dt)!="list"){ - Putcell(TbL,CoL,K,Dpos,Dt) # 2011.03.02 - K<- K+1 - } - else{ - N<- length(Dt) - Str<- Dt[[N]] - Rrng<- c(K,K+1) - Pos<- Dpos - for (J in Looprange(1,N-1)){ - Tmp<- Dt[[J]] - if(mode(Tmp)=="numeric"){ - Rrng<- c(K,K+Tmp) - } - if(mode(Tmp)=="character"){ - Pos<- Tmp - } - } - Putcell(TbL,CoL,Rrng,Pos,Str) - K<- Crng[2] - } - } -} - -Putcol<- function(...) -{ - PutcoL(...) -} - -PutcoLexpr<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - if(mode(TbL)!="list"){ - return("Tabledata missing") - } - Ag<- varargin[[2]] - if(mode(Ag)=="numeric"){ - CoL<- Ag - } - else{ - Alpha<- "-ABCDEFGHIJKLMNOPQRSTUVWXYZ" - Clm<- c() - for (I in Looprange(1,nchar(Ag))){ - C<- substr(Ag,I,I) - C<- toupper(C) - Tmp<- strsplit(Alpha,C) - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - Tmp1<- nchar(Tmp[1]) - Clm<- c(Clm,Tmp1) - } - } - Nrg<- 0 - for (I in seq(length(Clm),1,by=-1)){ - Tmp<- Clm[I] - Tmp1<- length(Clm)-I - Nrg<- Nrg+Tmp*26^Tmp1 - } - CoL<- Nrg - } - Nc<- length(TbL[[3]])+1 - K<- 1 - Dpos<- varargin[[3]] - for (I in Looprange(4,Nargs)){ - if(I-3>Nc){ - break - } - Dt<- varargin[[I]] - if(mode(Dt)!="list"){ - Dt<- paste("$",Dt,"$",sep="") - Putcell(TbL,CoL,K,Dpos,Dt) # 2011.03.02 - K<- K+1 - } - else{ - N<- length(Dt) - Str<- paste("$",Dt[[N]],"$",sep="") - Rrng<- c(K,K+1) - Pos<- Dpos - for (J in Looprange(1,N-1)){ - Tmp<- Dt[[J]] - if(mode(Tmp)=="numeric"){ - Rrng<- c(K,K+Tmp) - } - if(mode(Tmp)=="character"){ - Pos<- Tmp - } - } - Putcell(TbL,CoL,Rrng,Pos,Str) - K<- Crng[2] - } - } -} - -Putcolexpr<- function(...) -{ - PutcoLexpr(...) -} - -##################################################### - -PutcoLstr<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Tb<- varargin[[1]] - Nr<- varargin[[2]] - Pos<- varargin[[3]] - Str<- varargin[[4]] - Sep<- "" - if(Nargs>4){ - Sep<- varargin[[5]] - } - if(nchar(Sep)==0){ - for (I in Looprange(1,nchar(Str))){ - Tmp<- substr(Str,I,I) - Putcell(Tb,Nr,I,Pos,Tmp) - } - } - else{ - Ltr<- "" - K<- 1 - for (I in Looprange(1,length(Str))){ - Tmp<- substr(Str,I,I) - if(Tmp==Sep){ - Putcell(Tb,Nr,K,Pos,Ltr) - K<- K+1 - Ltr<- "" - } - else{ - Ltr<- paste(Ltr,Tmp,sep="") - } - } - if(nchar(Ltr)>0){ - Putcell(Tb,Nr,K,Pos,Ltr) - } - } -} - -############################################# - -Putrow<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - if(mode(TbL)!="list"){ - return("Tabledata missing") - } - Row<- varargin[[2]] - Nr<- length(TbL[[2]])+1 - K<- 1 - Dpos<- varargin[[3]] - for (I in Looprange(4,Nargs)){ - if(I-3>Nr){ - break; - } - Dt<- varargin[[I]] - if(mode(Dt)!="list"){ - Putcell(TbL,K,Row,Dpos,Dt) # 110308 - K<- K+1 - } - else{ - N<- length(Dt) - Str<- Dt[[N]] - Crng<- c(K,K+1) - Pos<- Dpos - for (J in Looprange(1,N-1)){ - Tmp<- Dt[[J]] - if(mode(Tmp)=="numeric"){ - Crng<- c(K,K+Tmp) - } - if(mode(Tmp)=="character"){ - Pos<- Tmp - } - } - Putcell(TbL,Crng,Row,Pos,Str) - K<- Crng[2] - } - } -} - -Putrowexpr<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - TbL<- varargin[[1]] - if(mode(TbL)!="list"){ - return("Tabledata missing") - } - Row<- varargin[[2]] - Nr<- length(TbL[[2]])+1 - K<- 1 - Dpos<- varargin[[3]] - for (I in Looprange(4,Nargs)){ - if(I-3>Nr){ - break; - } - Dt<- varargin[[I]] - if(mode(Dt)!="list"){ - Dt<- paste("$",Dt,"$",sep="") - Putcell(TbL,K,Row,Dpos,Dt) #110308 - K<- K+1 - } - else{ - N<- length(Dt) - Str<- paste("$",Dt[[N]],"$",sep="") - Crng<- c(K,K+1) - Pos<- Dpos - for (J in Looprange(1,N-1)){ - Tmp<- Dt[[J]] - if(mode(Tmp)=="numeric"){ - Crng<- c(K,K+Tmp) - } - if(mode(Tmp)=="character"){ - Pos<- Tmp - } - } - Putcell(TbL,Crng,Row,Pos,Str) - K<- Crng[2] - } - } -} - -#################################################### - -Putrowstr<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Tb<- varargin[[1]] - Nr<- varargin[[2]] - Pos<- varargin[[3]] - Str<- varargin[[4]] - Sep<- "" - if(Nargs>4){ - Sep<- varargin[[5]] - } - if(nchar(Sep)==0){ - for (I in Looprange(1,nchar(Str))){ - Tmp<- substr(Str,I,I) - Putcell(Tb,I,Nr,Pos,Tmp) - } - } - else{ - Ltr<- "" - K<- 1 - for (I in Looprange(1,length(Str))){ - Tmp<- substr(Str,I,I) - if(Tmp==Sep){ - Putcell(Tb,K,Nr,Pos,Ltr) - K<- K+1 - Ltr<- "" - } - else{ - Ltr<- paste(Ltr,Tmp,sep="") - } - } - if(nchar(Ltr)>0){ - Putcell(Tb,K,Nr,Pos,Ltr) - } - } -} - -############################################ -# 11.05.28 - -Ratiocmyk<- function(Color) -{ - if(is.numeric(Color)){ - return(Color) - } - R<- - switch(Color, - greenyellow=c(0.15,0,0.69,0), - yellow=c(0,0,1,0), - goldenrod=c(0,0.1,0.84,0), - dandelion=c(0,0.29,0.84,0), - apricot=c(0,0.32,0.52,0), - peach=c(0,0.5,0.7,0), - melon=c(0,0.46,0.5,0), - yelloworange=c(0,0.42,1,0), - orange=c(0,0.61,0.87,0), - burntorange=c(0,0.51,1,0), - bittersweet=c(0,0.75,1,0.24), - redorange=c(0,0.77,0.87,0), - mahogany=c(0,0.85,0.87,0.35), - maroon=c(0,0.87,0.68,0.32), - brickred=c(0,0.89,0.94,0.28), - red=c(0,1,1,0), - orangered=c(0,1,0.5,0), - rubinered=c(0,1,0.13,0), - wildstrawberry=c(0,0.96,0.39,0), - salmon=c(0,0.53,0.38,0), - carnationpink=c(0,0.63,0,0), - magenta=c(0,1,0,0), - violetred=c(0,0.81,0,0), - rhodamine=c(0,0.82,0,0), - mulberry=c(0.34,0.9,0,0.02), - redviolet=c(0.07,0.9,0,0.34), - fuchsia=c(0.47,0.91,0,0.08), - lavender=c(0,0.48,0,0), - thistle=c(0.12,0.59,0,0), - orchid=c(0.32,0.64,0,0), - darkorchid=c(0.4,0.8,0.2,0), - purple=c(0.45,0.86,0,0), - plum=c(0.5,1,0,0), - violet=c(0.79,0.88,0,0), - royalpurple=c(0.75,0.9,0,0), - blueviolet=c(0.86,0.91,0,0.04), - periwinkle=c(0.57,0.55,0,0), - cadetblue=c(0.62,0.57,0.23,0), - cornflowerblue=c(0.65,0.13,0,0), - midnightblue=c(0.98,0.13,0,0.43), - navyblue=c(0.94,0.54,0,0), - royalblue=c(1,0.5,0,0), - blue=c(1,1,0,0), - cerulean=c(0.94,0.11,0,0), - cyan=c(1,0,0,0), - processblue=c(0.96,0,0,0), - skyblue=c(0.62,0,0.12,0), - turquoise=c(0.85,0,0.2,0), - tealblue=c(0.86,0,0.34,0.02), - aquamarine=c(0.82,0,0.3,0), - bluegreen=c(0.85,0,0.33,0), - emerald=c(1,0,0.5,0), - junglegreen=c(0.99,0,0.52,0), - seagreen=c(0.69,0,0.5,0), - green=c(1,0,1,0), - forestgreen=c(0.91,0,0.88,0.12), - pinegreen=c(0.92,0,0.59,0.25), - limegreen=c(0.5,0,1,0), - yellowgreen=c(0.44,0,0.74,0), - springgreen=c(0.26,0,0.76,0), - olivegreen=c(0.64,0,0.95,0.4), - rawsienna=c(0,0.72,1,0.45), - sepia=c(0,0.83,1,0.7), - brown=c(0,0.81,1,0.6), - tan=c(0.14,0.42,0.56,0), - gray=c(0,0,0,0.5), - black=c(0,0,0,1), - white=c(0,0,0,0) - ) - if(length(R)<4){ - print("No color") - return(c()) - } - return(R) -} - -############################################ -# 11.01.07 - -Readtextdata<- function(...) -{ - varargin<- list(...) - OutL<- list() - Nargs<- length(varargin) - Fname<- varargin[[1]] - Tmp<- readLines(Fname,n=1) - if(length(grep("\t",Tmp))>0){ - Sep<- "\t" - } - else if(length(grep(",",Tmp))>0){ - Sep<- "," - } - else{ - Sep<- " " - } - Hajime<- c(1,1) - Owari<- c(Inf,Inf) - C<- Inf - R<- Inf - Rna<- FALSE - Cna<- TRUE - Mat<- FALSE - Num<- TRUE - D<- -Inf - Flg<- 0 - for (I in Looprange(2,Nargs)){ - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric"){ - if (Flg==0){ - Hajime<- Tmp - Flg<- 1 - } - else{ - Owari<- Tmp - } - } - else{ - eval(parse(text=Tmp)) - } - } - Tmp<- Hajime+c(R-1,C-1) - Owari<- c(min(Owari[1],Tmp[1]),min(Owari[2],Tmp[2])) - if(Cna){ - Df<- read.table(Fname,sep=Sep,header=TRUE,,stringsAsFactors=FALSE) - } - else{ - Df<- read.table(Fname,sep=Sep,header=FALSE,,stringsAsFactors=FALSE) - Nv<- c(1:ncol(Df)) - colnames(Df)<- Nv - } - if(Rna){ - rownames(Df)<-Df[,1] - Hajime<- Hajime+c(0,1) - } - if(Mat){ - M<- as.matrix(Df) - Tmp1<- min(Owari[1],nrow(M)) - Tmp2<- min(Owari[2],ncol(M)) - Out<- as.matrix(M[Hajime[1]:Tmp1,Hajime[2]:Tmp2]) - if(Num){ - Tmp1<- as.numeric(Out) - Out<- matrix(Tmp1,nrow=nrow(Out)) - } - } - else{ - Tmp1<- min(Owari[1],nrow(Df)) - Tmp2<- min(Owari[2],ncol(Df)) - Out<- Df[Hajime[1]:Tmp1,Hajime[2]:Tmp2] - } - if(D!=-Inf){ # 11.01.20 v2 - Tmp<- ncol(Out) # 11.01.07 - Tmp1<- rep(Inf,Tmp) - Out[Out[,1]<=D,]<- Tmp1 # 11.01.07 - } - return(Out) -} - -################################## - -Reflectdata<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-8) - ML<- varargin[[1]] - if(Mixtype(ML)==1){ - ML<- list(ML) - } - if(Nargs==1){ - PtA<- c(0,0); PtB<- PtA - } - else{ - Pts<- varargin[[2]] - if(length(Pts)==2){ - PtA<- Pts; PtB<- PtA - } - else{ - PtA<- Pts[1:2]; PtB<- Pts[3:4] - } - } - OutL<- list() - for (N in Looprange(1,length(ML))){ - GL<- Op(N,ML) - Out<- c() - for (I in Looprange(1,Nrow(GL))){ - if(is.matrix(GL)){ # 10.12.07 - Tmp<- GL[I,] - } - else{ - Tmp<- GL - } - X1<- Tmp[1] - Y1<- Tmp[2] - if(X1==Inf){ - X2<- X1 - Y2<- Y1 - } - else{ - if(Norm(PtA-PtB)0){ - Str=paste(Str,",",sep="") - } - if(length(Pt)<3){ - Str=paste(Str,sprintf("[%5.5f,%5.5f]",Pt[1],Pt[2]),sep="") - } - else{ - Str=paste(Str,sprintf("[%5.5f,%5.5f,%5.5f]",Pt[1],Pt[2],Pt[3]),sep="") - } - if(nchar(Str)>80){ - cat("[",Str,"]//","\n",sep="",file=Fname,append=TRUE) - Str="" - } - } - if(nchar(Str)>0){ - cat("[",Str,"]//","\n",sep="",file=Fname,append=TRUE) - } - if((N==Nargs-1) & (K==length(Gdata)) & (J==length(GL))){ -# cat("end////","\n",sep="",file=Fname,append=TRUE) - cat("end//","\n",sep="",file=Fname,append=TRUE) - } - else{ - cat("end//","\n",sep="",file=Fname,append=TRUE) - } - } - } - } - cat("//","\n",sep="",file=Fname,append=TRUE) # 15.11.05 -} - -###### Old #################################### -# 2015.10.23 -ReadOutData<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Fname=varargin[[1]] - cmdall=readLines(Fname) - cmdall=gsub("//","",cmdall,fixed=TRUE) - varname=cmdall[1] - outdt=list() - varL=c() - ptL=list() - flg=0 - for(cmd in cmdall){ - if(nchar(cmd)>0){ - if((cmd=="start") | cmd=="end" | substring(cmd,1,1)=="["){ - if(cmd=="start"){ - pts=c() - } - if(cmd=="end"){ - ptL=c(ptL,list(pts)) - } - if(substring(cmd,1,1)=="["){ - tmp1=paste(",",substring(cmd,2,nchar(cmd)-1),sep="") - tmp1=strsplit(tmp1,"]",fixed=TRUE) - tmp1=tmp1[[1]] - tmp1=gsub(",[","c(",tmp1,fixed=TRUE) - for(st in tmp1){ - tmp=eval(parse(text=paste(st,")",sep=""))) - pts=rbind(pts,tmp) - } - row.names(pts)=1:nrow(pts) - } - } - else{ - varname=cmd - varL=c(varL,varname) - if(flg==0){ # 17.10.07from - flg=1 - }else{ - outdt=c(outdt,list(ptL)) - } # 17.10.07until - ptL=c() - } - } - } - outdt=c(outdt,list(ptL)) # 17.10.07 - names(outdt)=varL - for(var in varL){ - tmp=paste(var,"<<- outdt$",var,sep="") - eval(parse(text=tmp)) - } -# print(varL) - outdt -} - -#################################################### - -ReadOutData<- function(...){ #2017.10.23 - varargin<- list(...) - Nargs<- length(varargin) - Fname=varargin[[1]] - cmdall=readLines(Fname) - cmdall=gsub("//","",cmdall,fixed=TRUE) - varname=""#17.12.13 cmdall[1] - outdt=list() - varL=c() - ptL=list() - flg=0 - for(cmd in cmdall){ - if(nchar(cmd)>0){ - if((cmd=="start") | cmd=="end" | substring(cmd,1,1)=="["){ - if(cmd=="start"){ - tmp=paste(varname,"<<- c(",varname,",list(c()))",sep="") - eval(parse(text=tmp)) - Ctr=Ctr+1 - } - if(cmd=="end"){ - } - if(substring(cmd,1,1)=="["){ - tmp1=paste(",",substring(cmd,2,nchar(cmd)-1),sep="") - tmp1=strsplit(tmp1,"]",fixed=TRUE) - tmp1=tmp1[[1]] - tmp1=gsub(",[","c(",tmp1,fixed=TRUE) - for(st in tmp1){ - tmp=paste(varname,"[[",as.character(Ctr),"]]",sep="") - tmp=paste(tmp,"<<- rbind(",tmp,",",st,"))",sep="")# - eval(parse(text=tmp)) - } - } - } - else{ - # 17.12.13from - if(nchar(varname)>0){ - tmp=paste("if(length(",varname,")==1){",varname,"<<- ",varname,"[[1]]}",sep="") - eval(parse(text=tmp)) - } - # 17.12.13until - varname=cmd - tmp=paste(varname,"<<- list()",sep="") - eval(parse(text=tmp)) - Ctr=0 - if(flg==0){ # 17.10.07from - flg=1 - }else{ - } # 17.10.07until - } - } - } - # 17.12.13from - tmp=paste("if(length(",varname,")==1){",varname,"<<- ",varname,"[[1]]}",sep="") - eval(parse(text=tmp)) - # 17.12.13until -} - -#################################################### - -Rotatedata<- function(..., deg=FALSE) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-8) - ML<- varargin[[1]] - if(Mixtype(ML)==1){ - ML<- list(ML) - } - Theta<- varargin[[2]] - if(deg) Theta<- Theta*pi/180 # 10.12.07 - if(Nargs==2){ - Pt<- c(0,0) - } - else{ - Pt<- varargin[[3]] - } - Cx<- Pt[1]; Cy<- Pt[2] - OutL<- c() - for (N in Looprange(1,length(ML))){ - GL<- Op(N,ML) - Out<- c() - for (I in Looprange(1,Nrow(GL))){ - if(is.matrix(GL)){ - Tmp<- GL[I,] - } - else{ - Tmp<- GL - } - X1<- Tmp[1] - Y1<- Tmp[2] - if(X1==Inf){ - X2<- X1 - Y2<- Y1 - } - else{ - X2<- Cx+(X1-Cx)*cos(Theta)-(Y1-Cy)*sin(Theta) - Y2<- Cy+(X1-Cx)*sin(Theta)+(Y1-Cy)*cos(Theta) - } - Out<- Appendrow(Out,c(X2,Y2)) - } - if(nrow(Out)==1){ - Out<- Out[1,] - } - OutL<- Mixjoin(OutL,list(Out)) - } - if(length(OutL)==1){ - OutL<- Op(1,OutL) - } - return(OutL) -} - -############################################### - -Scaledata<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-8) - ML<- varargin[[1]] - if(Mixtype(ML)==1){ - ML<- list(ML) - } - A<- varargin[[2]] - B<- varargin[[3]] - if(Nargs==3){ - Pt<- c(0,0) - } - else{ - Pt<- varargin[[4]] - } - OutL<- list() - for (N in Looprange(1,length(ML))){ - GL<- Op(N,ML) - Out<- c() - for (I in Looprange(1,Nrow(GL))){ - if(is.matrix(GL)){ # 10.12.07 - Tmp<- GL[I,] - } - else{ - Tmp<- GL - } - X1<- Tmp[1] - Y1<- Tmp[2] - if(X1==Inf){ - X2<- X1 - Y2<-Y1 - } - else{ - X2<- Pt[1]+A*(X1-Pt[1]) - Y2<- Pt[2]+B*(Y1-Pt[2]) - } - Out<- Appendrow(Out,c(X2,Y2)) - } - OutL<- Mixjoin(OutL,list(Out)) - } - if(length(OutL)==1){ - OutL<- Op(1,OutL) - } - return(OutL) -} - -################################ - -Setarrow<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0){ - Str<- paste("Size=",YaSize,",","Angle=",YaAngle,",",sep="") - Str<- paste(Str,"Position=",YaThick,",","Style=",YaStyle,sep="") - return(Str) - } - Flg<- 0 - for (I in 1:Nargs){ - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric"){ - Flg<- Flg+1 - if(Flg==1) YaSize<<-Tmp - if(Flg==2){ - if(Tmp<5){ - YaAngle<<- 18*Tmp - } - else{ - YaAngle<<- Tmp - } - } - if(Flg==3) YaPosition<<- Tmp - if(Flg==4) YaThick<<- Tmp - } - if(mode(Tmp)=="character"){ - YaStyle<<- Tmp - } - } -} - -#################################### - -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="") - Str<- paste(Str,YNAME,",",YPOS,",",ONAME,",",OPOS,sep="") - return(Str) - } - ArgL<- c() - Is<- 1 - Tmp<- varargin[[1]] - if(mode(Tmp)=="numeric" && length(Tmp)==1){ - Is<- varargin[[1]] - ArgL<- c() - for (I in Looprange(1,Is-1)){ - ArgL<- c(ArgL,"") - } - for (I in Looprange(2,Nargs)){ - 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]]) - } - } - } - } - 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) - } - } - 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" - } - } - if(nchar(Xn)>0){ - XNAME<<- paste("$",Xn,"$",sep="") - } - if(nchar(Xp)>0){ - XPOS<<- Xp - } - if(nchar(Yn)>0){ - YNAME<<- paste("$",Yn,"$",sep="") - } - if(nchar(Yp)>0){ - YPOS<<-Yp - } - if(nchar(Genn)>0){ - ONAME<<- Genn - } - if(nchar(Genp)>0){ - OPOS<<- Genp - } - Out<- ""; -} - -################################# -# 11.08.24 - -Setcolor<- function(...){ - varargin<- list(...) - Color<- 'black' - Kosa<- 1 - for(J in Looprange(1,length(varargin))){ - Tmp<- varargin[[J]] - if(is.character(Tmp)) Color<- Tmp - if(is.numeric(Tmp)){ - if(length(Tmp)==1){# 11.08.24 - Kosa<- Tmp - } - else{ - Color<- Tmp - } - }# 11.08.24 - } - Iro<- Ratiocmyk(Color) - if(length(Iro)==0) return(c()) - Str<- "\\color[cmyk]{" #17.09.22 - for(J in 1:4){ - Str<- paste(Str,as.character(Kosa*Iro[J]),sep="") - if(J<4){ - Str<- paste(Str,",",sep="") - } - } - Str<- paste(Str,"}",sep="") - Texcom(Str) -} - -################################## - -Setmarklen<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0){ - Tmp<- MARKLENNow/MARKLENInit - Tmp=round(Tmp*100)/100 - return(Tmp) - } - Size<- varargin[[1]] - MARKLENNow<<- MARKLENInit*Size - MARKLEN<<- MARKLENNow*1000/2.54/MilliIn -} - -############################### - -Setorigin<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0){ - return(GENTEN) - } - Pt<- varargin[[1]] - GENTEN<<- Pt; -} - -################################ - -Setscaling<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0) - { - return(c(SCALEY,LOGX,LOGY)) - } - for (I in 1:Nargs) - { - Tmp<- varargin[[I]] - if(mode(Tmp)=="numeric") - { - SCALEY<<- Tmp - } - if(mode(Tmp)=="character") - { - if(Tmp=="l") - { - LOGX<<- 0 - LOGY<<- 1 - } - else if(Tmp=="ll") - { - LOGX<<- 1 - LOGY<<- 1 - } - else - { - LOGX<<- 0 - LOGY<<- 0 - } - } - } - Tmp<- c(SCALEY,LOGX,LOGY); -} - -######################################### - -Setpen<-function(Width) -{ - PenThick<<-round(PenThickInit*Width) - Str=paste("\\special{pn ", as.character(PenThick),"}%\n",sep="") - cat(Str,file=Wfile,append=TRUE) -} - -############################################## - -Setpt<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - if(Nargs==0) - { - Tmp<- TenSize/TenSizeInit - Tmp<- round(Tmp*100)/100 - return(Tmp) - } - Size<- varargin[[1]] - TenSize<<- TenSizeInit*Size; -} - -############################################## - -Setunitlen<-function(...) -{ - varargin<-list(...) - if(length(varargin)==0){ - return(ULEN) - } - Ul=varargin[[1]] - Dx<-XMAX-XMIN - Dy<-YMAX-YMIN - Sym<-".0123456789 +-*/" - SL<-Sym - OL<-"+-*/" - if(nchar(Ul)>0){ - ULEN<<-Ul - } - Is<-1 - VL<-"" - Ucode<-ULEN - for (I in 1:nchar(Ucode)){ - C<-substring(Ucode,I,I) - if(length(grep(C,SL))>0){ - if(length(grep(C,OL))>0){ - Tmp<-substring(Ucode,Is,I-1) - Str<-paste(VL,Tmp,C,sep="") - VL<-Str - Is<-I+1 - } - } - else{ - Unit<-substring(Ucode,I,I+1) - Str<-substring(Ucode,Is,I-1) - VL<-paste(VL,Str,sep="") - break; - } - } - Valu<-eval(parse(text=VL)) - Str<-as.character(Valu) - ULEN<<-paste(Str,Unit,sep=""); - if(Unit=="cm") MilliIn<<-1000/2.54*Valu - if(Unit=="mm") MilliIn<<-1000/2.54*Valu/10 - if(Unit=="in") MilliIn<<-1000*Valu - if(Unit=="pt") MilliIn<<-1000/72.27*Valu - if(Unit=="pc") MilliIn<<-1000/6.022*Valu - if(Unit=="bp") MilliIn<<-1000/72*Valu - if(Unit=="dd2") MilliIn<<-1000/1238/1157/72.27*Valu - if(Unit=="cc") MilliIn<<-1000/1238/1157/72.27*12*Valu - if(Unit=="sp") MilliIn<<-1000/72.27/65536*Valu/10 - MARKLEN<<-MARKLENNow*1000/2.54/MilliIn - MEMORI<<-MEMORINow*1000/2.54/MilliIn #17.12.17 -} - -######################################### -# 10.11.20 - -Setwindow<-function(...) -{ - varargin<-list(...) - Nargs<-length(varargin) - if(Nargs==0){ - Out<-c(XMIN,XMAX,YMIN,YMAX) - return(Out) - } - if(Nargs==1){ - Dt<- varargin[[1]] - if(is.list(Dt) && !is.data.frame(Dt)){ - Tmp<- as.data.frame(Dt) - Dt<- t(Tmp) - } - Xm<- min(Dt[,1]) - XM<- max(Dt[,1]) - Ym<- min(Dt[,2]) - YM<- max(Dt[,2]) - Str<- "Setwindow(" - Str<- paste(Str,"c(",as.character(Xm),",",as.character(XM),"),c(",sep="") - Str<- paste(Str,as.character(Ym),",",as.character(YM),")",sep="") - Str<- paste(Str,")",sep="") - print(Str) - } - if(Nargs==2){ - RgX<-varargin[[1]] - RgY<-varargin[[2]] - XMIN<<-RgX[1]; XMAX<<-RgX[2] - YMIN<<-RgY[1]; YMAX<<-RgY[2] - } - if(Nargs==4){ - XMIN<<-varargin[[1]]; XMAX<<-varargin[[2]] - YMIN<<-varargin[[3]]; YMAX<<-varargin[[4]] - } - Out<- c(XMIN,XMAX,YMIN,YMAX); -} - -######################################### - -Shadeold<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - Iroflg=0 - Kosa=1 - if(Nargs>1){ - Iro=varargin[[Nargs]] - if(is.character(Iro)){ - Iroflg=1 - if(length(grep("{",Iro))>0){ - Str=paste("{\\color",Iro,sep="") - } - else{ - Str=paste("{\\color{",Iro,"}",sep="") - } - } - else{ - if(length(Iro)==1){ - Kosa=Iro - } - else{ - Iroflg=1 - if(length(Iro)==4){ - Str="{\\color[cmyk]{" - } - else{ - if(length(Iro)==3){ - Str="{\\color[rgb]{" - } - } - for(J in 1:length(Iro)){ - Str=paste(Str,as.character(Iro[J]),sep="") - if(J80){ - cat("%\n",file=Wfile,append=TRUE) - Mojisu<- 0 - } - } - Str1<- paste("\\special{sh ",as.character(Kosa),"}",sep="") - Str2<- paste("\\special{ip}%\n",sep="") - cat(Str1,file=Wfile,append=TRUE) - cat(Str2,file=Wfile,append=TRUE) - } - if(Iroflg==1){ - cat("}%\n",file=Wfile,append=TRUE) - } -} - -####### Shade new 17.09.24############ - -Shade<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - Iroflg<- 0 - Kosa<- 1 - if(Nargs>1){ - Iro<- varargin[[Nargs]] - if(mode(Iro)=="character"){ - Iroflg<- 1 - if(length(grep(Iro,"{"))>0) - Str<- paste("{\\color",Iro,sep="") - else - Str<- paste("{\\color{",Iro,"}",sep="") - } - else{ - if(length(Iro)==1) - Kosa<- Iro - else{ - Iroflg<- 1 - if(length(Iro)==4) - Str<- paste("{\\color[cmyk]{",sep="") - else - if(length(Iro)==3) - Str<- paste("{\\color[rgb]{",sep="") - for (J in Looprange(1,length(Iro))){ - Str<- paste(Str,as.character(Iro[J]),sep="") - if(J80){ - if(Wfile=="default") - cat("%\n",file="",append=TRUE,sep="") - else - 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="") - } - } - if(Iroflg==1){ - if(Wfile=="default") - cat("}%\n",file="",append=TRUE,sep="") - else - cat("}%\n",file=Wfile,append=TRUE,sep="") - } -} - -############################################## -# 11.01.07 - -Splinedata<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-3) - PL<- varargin[[1]] - if(mode(PL)=="character"){ - Fname<- PL - PL<- Readtextdata(Fname) - } - else{ - PL<- as.matrix(PL) - if(Nrow(PL)==1){ - PL<- matrix(PL, nrow=length(PL)/2) - PL<- t(PL) - } - } - if(ncol(PL)==3){ - Flg3<- 1 - } - else{ - Flg3<- 0 - } - PLL<- Dividegraphics(PL) - N<- 50 - C<- c() - for (I in Looprange(2,Nargs)){ - Tmp<- varargin[[I]] - if(mode(Tmp)!="character") next - if(length(grep("=",Tmp,fixed=TRUE))>0){ - eval(parse(text=Tmp)) - } - else{ - Tmp1<- substr(Tmp,1,1) - if(toupper(Tmp1)=="C"){ - C<- 1:length(PLL) - } - } - } - Cflg<- rep(0,length(PLL)) - for(J in Looprange(1,length(C))){ - K<- C[J] - Cflg[K]<- 1 - } - if(length(N)>1){ - Nj<- as.numeric(N) - } - else{ - Tmp<- lapply(PLL,nrow) - Tmp1<- as.numeric(Tmp) - MxP<- max(Tmp1) - Nj<- c() - for (J in 1:length(PLL)){ - Tmp<- nrow(PLL[[J]]) - Tmp1<- round(N/MxP*(Tmp-1)) - Nj<- c(Nj,Tmp1) - } - } - OutL<- list() - for(J in 1:length(PLL)){ - PL<- PLL[[J]] - if(Cflg[J]==1){ - if(Norm(PL[1,]-PL[Nrow(PL),])>Eps){ - PL<-Appendrow(PL,PL[1,]) - Nj[J]=round(N/MxP*nrow(PL)) - } - else{ - PL[Nrow(PL),]<- PL[1,] - } - } - Tn<- 1:Nrow(PL) - Xn<- PL[,1] - Yn<- PL[,2] - if(Flg3==1) Zn<- PL[,3] - if(Cflg[J]==0){ - Dxn<- spline(Tn,Xn,n=Nj[J]) - Dyn<- spline(Tn,Yn,n=Nj[J]) - if(Flg3==1) Dzn<- spline(Tn,Zn,n=Nj[J]) - } - else{ - Dxn<- spline(Tn,Xn,method="periodic") - Dyn<- spline(Tn,Yn,method="periodic") - if(Flg3==1) Dzn<- spline(Tn,Zn,method="periodic") - } - Tmp1<- Dxn$y - Tmp2<- Dyn$y - Tmp3<-c() - if(Flg3==1) Tmp3<- Dzn$y - Out<- matrix(c(Tmp1,Tmp2,Tmp3),nrow=length(Tmp1)) - OutL<- c(OutL,list(Out)) - } - return(OutL) -} - -############################################ -# 2013.05.03 Domain is optional - -Tabledata<- function(...){ - varargin<- list(...) - Eps<- 0.001 - Tmp<- varargin[[1]] # 130503 from - if(is.numeric(Tmp)){ - Domain<- varargin[[1]] - VL<- varargin[[2]] - HL<- varargin[[3]] - } - else{ - Domain<- c(-1,-1) - VL<- varargin[[1]] - HL<- varargin[[2]] - } # 130503 until - Hsize<- Domain[1] - SvL<- list(0) - S<- 0 - for (I in Looprange(1,length(VL))){ - Tmp<- VL[[I]] - S<- S+Tmp[1] - Tmp[1]<- S - SvL<- c(SvL,list(Tmp)) - } - if(Hsize>S){ - SvL<- c(SvL,list(Hsize)) - } - Hsize<- Op(1,SvL[[length(SvL)]]) - Vsize<- Domain[2] - ShL<- list(0) - S<- 0 - for (I in Looprange(1,length(HL))){ - Tmp<- HL[[I]] - S<- S+Tmp[1] - Tmp[1]<- S - ShL<- c(ShL,list(Tmp)) - } - if(Vsize>S){ - ShL<- c(ShL,list(Vsize)) - } - Vsize<- Op(1,ShL[[length(ShL)]]) - Marw<- 0; Mare<- 0; Mars<- 0; Marn<- 0 - if(length(Domain)>2){ - Marw<- Domain[3] - Mare<- Domain[4] - } - if(length(Domain)>4){ - Marn<- Domain[5] - Mars<- Domain[6] - } - Setwindow(c(-Marw,Hsize+Mare),c(-Mars,Vsize+Marn)) - Tmp<- Framedata(c(Eps,Hsize-Eps),c(Eps,Vsize-Eps)) - Gdata<- list(Tmp) - Tmp<- -Marw - Hdata<- list(Listplot(c(c(Tmp,-Mars),c(Tmp,Vsize+Marn)))) - for (I in Looprange(1,length(SvL))){ - Data<- SvL[[I]] - X<- Data[1] - if(length(Data)==1){ - Y1<- 0 - Y2<- Vsize - G<- Listplot(c(X,Y1),c(X,Y2)) - } - else{ - G<- c() - for (J in seq(2,length(Data),by=2)){ - Y1<- Vsize-Op(1,ShL[[Data[J]]]) - Y2<- Vsize-Op(1,ShL[[Data[J+1]]]) - Tmp<- Listplot(c(c(X,Y1),c(X,Y2))) - Tmp1<- Appendrow(G,c(Inf,Inf)) - G<- Appendrow(Tmp1,Tmp) - } - G<- G[2:nrow(G),] - } - Hdata<- c(Hdata,list(G)) - } - Tmp<- Hsize+Mare - Tmp1<- Listplot(c(c(Tmp,-Mars),c(Tmp,Vsize+Marn))) - Hdata<- c(Hdata,list(Tmp1)) - Tmp<- Vsize+Marn - Vdata<- list(Listplot(c(c(-Marw,Tmp),c(Hsize+Mare,Tmp)))) - for (I in Looprange(1,length(ShL))){ - Data<- ShL[[I]] - Y<- Vsize-Data[1] - if(length(Data)==1){ - X1<- 0 - X2<- Hsize - G<- Listplot(c(X1,Y),c(X2,Y)) - } - else{ - G<- c() - for (J in seq(2,length(Data),by=2)){ - X1<- Op(1,SvL[[Data[J]]]) - X2<- Op(1,SvL[[Data[J+1]]]) - Tmp<- Listplot(c(X1,Y),c(X2,Y)) - G<- Appendrow(G,c(Inf,Inf)) - G<- Appendrow(G,Tmp) - } - G<-G[2:nrow(G),] - } - Vdata<- c(Vdata,list(G)) - } -# Tmp<- Listplot(c(c(0,0),c(Hsize,0))) # 2011.03.02 -# Vdata<- Mixjoin(Vdata,list(Tmp)) - Tmp<- Listplot(c(c(-Marw,-Mars),c(Hsize+Mare,-Mars))) - Vdata<- Mixjoin(Vdata,list(Tmp)) - Tmp1<- Hdata[Looprange(3,length(Hdata)-2)] - Tmp2<- Vdata[Looprange(3,length(Vdata)-2)] - Gdata<- Mixjoin(Gdata,Tmp1,Tmp2) - Hind<- Looprange(2,1+length(Tmp1)) - Vind<- Looprange(2+length(Tmp1),1+length(Tmp1)+length(Tmp2)) - G=Gdata[[1]] - P1<- Ptsw(G); P2<- Ptnw(G) - Q1<- Ptse(G); Q2<- Ptne(G) - Tmp1<- list(Listplot(c(P1,P2)),Listplot(c(Q1,Q2))) - P1<- Ptnw(G); P2<- Ptne(G) - Q1<- Ptsw(G); Q2<- Ptse(G) - Tmp2<- list(Listplot(c(P1,P2)),Listplot(c(Q1,Q2))) - Tmp3<- Framedata() - Out<- list(Gdata,Hind,Vind,Tmp1,Tmp2,Tmp3) - return(Out) -} - -################################ - -Texcom<- function(Meirei) -{ - if(Meirei=="\\thinlines"){ - Setpen(1); - return(); - } - if(Meirei=="\\thicklines"){ - Setpen(2); - return() - } - if(Meirei=="\\Thicklines"){ - Setpen(3); - return() - } - if(length(Meirei)==0){ # 09.12.07 - Tmp<- c() - } - else{ - Tmp<- grep("newline",Meirei) - } - if(length(Tmp)>0){ - cat("\n",file=Wfile,append=TRUE); - } - else{ - Tmp<- paste(Meirei,"%\n",sep="") - Tmp<- gsub("//","\\",Tmp,fixed=TRUE) # 11.03.02 - cat(Tmp,file=Wfile,append=TRUE); - } -} - -############################################### - -Texctr<- function(N){ - if(is.numeric(N)){ - Alpha<- "abcdefghijklmnopqrstuvwxyz" - Out<- paste("ketpicctr",substr(Alpha,N,N),sep="") - } - else{ - if(grep("\\",N,fixed=TRUE)>0){ - Out<- substr(N,2,nchar(N)) - } - else{ - Out<- N - } - } - return(Out) -} - -############################################### - -Texelse<- function (){ - Texcom(""); - Texcom("\\else") -} - -############################################### - -Texend<- function() -{ - Texcom("%\n}") -} - -############################################### - -Texendfor<- function(I){ - Last<- TEXFORLAST[[TEXFORLEVEL]] - Texcom("") - Tmp<- paste("\\ifnum",Texthectr(I),"<",Last,sep="") - Texcom(Tmp) - Texcom("\\repeat") - Texcom("}") - TEXFORLEVEL<<- TEXFORLEVEL-1 - TEXFORLAST<<- TEXFORLAST[1:(length(TEXFORLAST)-1)] -} - -############################################### - -Texendif<- function(){ - Texcom("") - Texcom("\\fi") - Texcom("}") -} - -############################################### - -Texfor<- function(I,First,Last){ - TEXFORLEVEL<<- TEXFORLEVEL+1; - Texsetctr(I,"0") - Texsetctr(I,paste(as.character(First),"-1",sep="")) - Texcom("") - Texcom("{") - Texcom("\\loop") - Texsetctr(I,"+1") - TEXFORLAST<<- c(TEXFORLAST,as.character(Last)) -} - -############################################### - -Texforinit<- function(){ - TEXFORLEVEL<<- 0 - TEXFORLAST<<- list() -} - -############################################### - -Texif<- function(...){ - varargin<- list(...) - Condstr<- varargin[[1]] - Tp<- 0 - if(length(varargin)>1){ - Tp<- varargin[[2]] - } - Texcom("") - Texcom("{") - if(Tp==0){ - Texcom("\\ifnum") - } - else{ - Texcom("\\ifdim ") - } - Texcom(paste(Condstr," ",sep="")) -} - -###################################### - -Texletter<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - for (I in seq(1,Nargs,by=3)){ - P<- varargin[[I]] - X<- P[1] - if(mode(X)=="numeric"){ - X<- as.character(X) - } - Y<- P[2] - if(mode(Y)=="numeric"){ - Y<- as.character(Y) - } - Houkou<- varargin[[I+1]] - Mojiretu<- varargin[[I+2]] - Hset<- Houkou - Vhoko<- "c" - if(length(grep("n",Hset))>0){ - Vhoko<- "n" - } - if(length(grep("s",Hset))>0){ - Vhoko<- "s" - } - Hhoko<- "c"; - if(length(grep("e",Hset))>0){ - Hhoko<- "e" - } - if(length(grep("w",Hset))>0){ - Hhoko<- "w" - } - Hoko<- paste(Vhoko,Hhoko,sep="") - CalcWidth(Hoko,Mojiretu) - CalcHeight(Hoko,Mojiretu) - Tmp<- paste("\\put(",X,",",Y,"){\\hspace*{\\Width}",sep="") - Str<- paste(Tmp,"\\raisebox{\\Height}{",Mojiretu,"}}%\n",sep="") - cat(Str,file=Wfile,append=TRUE) - } -} - -################################################## - -Texnewcmd<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Str<- varargin[[1]] - S<- paste("\\newcommand{",Str,"}",sep="") - if(Nargs>1){ - Tmp<- as.character(varargin[[2]]) - S<- paste(S,"[",Tmp,"]",sep="") - } - if(Nargs>2){ - Tmp<- varargin[[3]] - if(mode(Tmp)=="numeric"){ - Tmp<- as.character(Tmp) - } - S<- paste(S,"[",Tmp,"]",sep="") - } - S<- paste(S,"{",sep="") - Texcom(S) -} - -############################################### - -Texnewctr<- function(N) -{ - if(mode(N)=="character"){ - Str<- paste("\\newcounter{",N,"}",sep="") - Texcom(Str) - } - else{ - for (I in N){ - Str<- paste("\\newcounter{",Texctr(I),"}",sep="") - Texcom(Str) - } - } -} -############################################### - -Texrenewcmd<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Str<- varargin[[1]] - S<- paste("\\renewcommand{",Str,"}",sep="") - if(Nargs>1){ - Tmp<- as.character(varargin[[2]]) - S<- paste(S,"[",Tmp,"]",sep="") - } - if(Nargs>2){ - Tmp<- varargin[[3]] - if(mode(Tmp)=="numeric"){ - Tmp<- as.character(Tmp) - } - S<- paste(S,"[",Tmp,"]",sep="") - } - S<- paste(S,"{",sep="") - Texcom(S) -} - -############################################### - -Texsetctr<- function(Nctr,Opstr) -{ - Ctr<- Texctr(Nctr) - Opstr<- paste(Opstr,"%",sep="") - OperL<- "+-*/%" - Oper<- "" - Va<- "" - Evflg<- 0 - Paflg<- 0 - for (I in Looprange(1,nchar(Opstr))){ - Tmp<- substring(Opstr,I,I) - if(Tmp=="("){ - Paflg<- 1 - if(nchar(Va)>0){ - Evflg<- 1 - Va<- paste(Va,Tmp,sep="") - } - next - } - if(Tmp==")"){ - Paflg<- 0 - if(Evflg>0){ - Va<- paste(Va,Tmp,sep="") - } - next - } - if(Paflg>0){ - Va<- paste(Va,Tmp,sep="") - next - } - if(length(grep(Tmp,OperL))==0){ - Va<- paste(Va,Tmp,sep="") - } - else{ - if(Evflg>0){ - Tmp1<- eval(parse(text=Va)) - Va<- paste("\\value{",Tmp1,"}",sep="") - Evflg<- 0 - } - if(Oper==""){ - if(nchar(Va)>0){ - Str<- paste("\\setcounter{",Ctr,"}{",Va,"}",sep="") - Texcom(Str) - } - Oper<- Tmp - Va<-"" - } - else if(Oper=="+"){ - Str<- paste("\\addtocounter{",Ctr,"}{",Va,"}",sep="") - Texcom(Str) - Oper<- Tmp - Va<-"" - } - else if(Oper=="-"){ - Str<- paste("\\addtocounter{",Ctr,"}{-",Va,"}",sep="") - Texcom(Str) - Oper<- Tmp - Va<-"" - } - else if(Oper=="*"){ - Str<- paste("\\multiply\\value{",Ctr,"} by ",Va,sep="") - Texcom(Str) - Oper<- Tmp - Va<-"" - } - else if(Oper=="/"){ - Str<- paste("\\divide\\value{",Ctr,"} by ",Va,sep="") - Texcom(Str) - Oper<- Tmp - Va<-"" - } - } - } -} - -############################################### - -Texthectr<- function(N) -{ - Out<- paste("\\the",Texctr(N),sep="") - return(Out) -} - -############################################### - -Texvalctr<- function(N){ - Out<- paste("\\value{",Texctr(N),"}",sep="") - return(Out) -} - -############################################### - -Texvctr<- function(N) -{ - Out<- paste("\\value{",Texctr(N),"}",sep="") - return(Out) -} - -############################################### - -Tonumeric <- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Data<- varargin[[1]] - Sp<- c(1,1) - Ep<- c(Inf,Inf) - if(Nargs>1){ - Sp<- varargin[[2]] - } - if(Nargs>2){ - Ep<- varargin[[3]] - } - Nrs<- Sp[1] - Nre<- min(nrow(Data),Ep[1]) - Ncs<- Sp[2] - Nce<- min(ncol(Data),Ep[2]) - Tmp1<- Data[Nrs:Nre, Ncs:Nce] - Tmp2 <- as.numeric(Tmp1) - Out <- matrix(Tmp2,nrow=nrow(Tmp1)) - Sp<- c() - for (I in 1:nrow(Out)){ - for (J in 1:ncol(Out)){ - Tmp<- Out[I,J] - if(!is.na(Tmp)){ - Sp<- c(I,J) - break; - } - } - if(length(Sp)>0) break - } - if(length(Sp)==0){ - return("Numeric data not found") - } - Ep<- c(nrow(Out),ncol(Out)) - for (I in Sp[1]:nrow(Out)){ - Tmp<- Out[I,Sp[2]] - if(is.na(Tmp)){ - Ep[1]<- I-1 - break - } - } - for (J in Sp[2]:ncol(Out)){ - Tmp<- Out[Sp[1],J] - if(is.na(Tmp)){ - Ep[2]<- J-1 - break - } - } - Out<- Out[Sp[1]:Ep[1], Sp[2]:Ep[2]] - return(Out) -} - -################################################## - -Translatedata<- function(...) -{ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10^(-8) - ML<- varargin[[1]] - if(Mixtype(ML)==1){ - ML<- list(ML) - } - Tmp=varargin[[2]] - if(mode(Tmp)=="numeric" && length(Tmp)>1){ - A<- Tmp[1]; B<- Tmp[2] - } - else{ - A<- Tmp - if(Nargs>=3){ - B<- varargin[[3]] - } - else{ - B<- 0 - } - } - OutL<- list() - for (N in Looprange(1,length(ML))){ - GL<- Op(N,ML) - Out<- c() - for (I in Looprange(1,Nrow(GL))){ - if(is.matrix(GL)){ # 10.12.07 - Tmp<- GL[I,] - } - else{ - Tmp<- GL - } - X1<- Tmp[1] - Y1<- Tmp[2] - if(X1==Inf){ - X2<- X1 - Y2<-Y1 - } - else{ - X2<- X1+A - Y2<- Y1+B - } - Out<- Appendrow(Out,c(X2,Y2)) - } - OutL<- Mixjoin(OutL,list(Out)) - } - if(length(OutL)==1){ - OutL<- Op(1,OutL) - } - return(OutL) -} - -####################################### - -Unscaling<- function(G) -{ - GLg<- G - if(class(GLg)=="numeric"){ - GLg<-c(G[1]/SCALEX, G[2]/SCALEY) - Tmp<-GLg - if(LOGX==1) Tmp[1]<- 10^(GLg[1]) - if(LOGY==1) Tmp[2]<- 10^(GLg[2]) - return(Tmp) - } - else{ - Tmp1<-matrix(c(1/SCALEX,0,0,1/SCALEY),nrow=2) - GLg<-G %*% Tmp1 - Tmp<-GLg - if(LOGX==1) Tmp[,1]<- 10^(G[,1]) - if(LOGY==1) Tmp[,2]<- 10^(G[,2]) - return(Tmp) - } -} - -############################################# - -Vtickmark<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - ArgsL<- varargin - if(mode(ArgsL[[1]])=="character"){ - Str<- ArgsL[[1]] - Tmp<- strsplit(Str,"m") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - I<- nchar(Tmp[1])+1 - } - else{ - I<- 0 - } - Tmp<- strsplit(Str,"n") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - J<- nchar(Tmp[1])+1 - } - else{ - J<- 0 - } - Tmp<- strsplit(Str,"r") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - K=nchar(Tmp[1])+1 - } - else{ - K<- 0 - } - if(K>0){ - S<- substr(Str,K+1,nchar(Str)) - R<- as.numeric(S) - if(is.na(R)){ - R<- 1 - } - } - else{ - R<- 1 - K<- nchar(Str)+1 - } - if(J>0){ - S<- substr(Str,J+1,K-1) - Dn<- as.numeric(S) - if(is.na(Dn)){ - Dn<- 1 - } - } - else{ - Dn<- 1000 - J<- nchar(Str)+1 - } - S<- substr(Str,I+1,J-1) - Dm<- as.numeric(S) - if(is.na(Dm)){ - Dm<- 1 - } - ArgsL<- list() - for (I in 1:floor((YMAX-GENTEN[2])/Dm)){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - for (I in seq(-1,ceiling((YMIN-GENTEN[2])/Dm))){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - } - MemoriList<- list() - Memori<- list() - for (N in 1:length(ArgsL)){ - Dt<- ArgsL[[N]] - if(mode(Dt)=="numeric" && length(Dt)>1){ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt[1],Dt[2]) - next - } - if(mode(Dt)=="character"){ - Memori<- Mixjoin(Memori,Dt) - } - else{ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(GENTEN[1],Dt) - } - } - MemoriList<- Mixjoin(MemoriList,list(Memori)) - for (N in 1:length(MemoriList)){ - Dt<- MemoriList[[N]] - Ndt<- length(Dt) - X=Op(1,Dt) - Y=Op(2,Dt) - Tmp<-Doscaling(c(X,Y)) - X<- Tmp[1] - Y<- Tmp[2] - Moji<- Op(Ndt,Dt) - Tmp1<- Unscaling(c(X+MARKLEN,Y)) - Tmp2<- Unscaling(c(X-MARKLEN,Y)) - Fd<- Listplot(c(Tmp1,Tmp2)) - Drwline(Fd) - if(Ndt==3){ - Tmp<-Unscaling(c(X-MARKLEN,Y)) - Expr(Tmp,"w",Moji) - } - if(Ndt==4){ - Houkou<- Op(3,Dt) - Tmp<-grep("w",Houkou) - if(length(Tmp)>0){ - Tmp<-Unscaling(c(X-MARKLEN,Y)) - Expr(Tmp,Houkou,Moji) - } - else{ - Tmp<- Unscaling(c(X+MARKLEN,Y)) - Expr(Tmp,Houkou,Moji) - } - } - cat("%\n",file=Wfile,append=TRUE) - } -} - -############################################ - -Windisp<-function(...){ - varargin<-list(...) - Nargs<-length(varargin) - Tmp<- Doscaling(c(XMIN,YMIN)) - Xmn<- Tmp[1]; Ymn<- Tmp[2] - Tmp<- Doscaling(c(XMAX,YMAX)) - Xmx<- Tmp[1]; Ymx<- Tmp[2] - plot(c(Xmn,Xmx),c(Ymn,Ymx),type="n",asp=1,axes=FALSE,xlab="",ylab="") - Tmp<- Doscaling(Listplot(c(0,YMIN),c(0,YMAX))) - axis(2,at=as.numeric(Tmp[,2]), labels=round(c(YMIN,YMAX),2)) - Tmp<- Doscaling(Listplot(c(XMIN,0),c(XMAX,0))) - axis(1,at=as.numeric(Tmp[,1]), labels=round(c(XMIN,XMAX),2)) - Tmp1<- c(XMIN,GENTEN[2]) - Tmp2<- c(XMAX,GENTEN[2]) - Tmp3<- Listplot(Tmp1,Tmp2) - Tmp<- MakeCurves(Tmp3,0) - if(Datalength(Tmp)>0){ - lines(Tmp[,1],Tmp[,2],col="green") - } - Tmp1<- c(GENTEN[1],YMAX) - Tmp2<- c(GENTEN[1],YMIN) - Tmp3<- Listplot(Tmp1,Tmp2) - Tmp<- MakeCurves(Tmp3,0) - if(Datalength(Tmp)>0){ - lines(Tmp[,1],Tmp[,2],col="green") - } - Tmp<-Doscaling(Framedata()) - lines(Tmp[,1],Tmp[,2]) - for (I in Looprange(1,Nargs)){ - Pdata<-varargin[[I]] - if(mode(Pdata)=="numeric"){ - Pdata<-list(Pdata) - } - while(Mixtype(Pdata)==3){ # 10.02.23 - Tmp1<- list() - for(II in Looprange(1,length(Pdata))){ - Tmp1<- Mixjoin(Tmp1,Pdata[[II]]) - } - Pdata<- Tmp1 - } # 10.02.23 - for (II in Looprange(1,length(Pdata))){ - Tmp<-Pdata[[II]] - P<-MakeCurves(Tmp,0) - Ndm<-Dataindex(P) - for (J in Looprange(1,Nrow(Ndm))){ - Q<-P[Ndm[J,1]:Ndm[J,2],] - if(Nrow(Q)==1){ - Tmp<-seq(1,Ncol(Q),by=2) - for (K in Tmp){ - Pt<-Q[K:(K+1)] - points(Pt[1],Pt[2]) - } - } - else{ - lines(Q[,1],Q[,2]) - } - } - } - } -} - -############################################ - -WindispT<-function(..., color="black",width=1,new=FALSE,htick=c(),vtick=c()){ # 10.12.04 - par(new=new) - varargin<-list(...) - Nargs<-length(varargin) - if(!new) # 10.12.04 - { - Tmp<- Doscaling(c(XMIN,YMIN)) - Xmn<- Tmp[1]; Ymn<- Tmp[2] - Tmp<- Doscaling(c(XMAX,YMAX)) - Xmx<- Tmp[1]; Ymx<- Tmp[2] - plot(c(Xmn,Xmx),c(Ymn,Ymx),type="n",asp=1,axes=FALSE,xlab="",ylab="") - Tick<- sort(c(YMIN,YMAX,vtick)) #### 10.12.04 from here - Tmp1<- matrix(c(rep(0,length(Tick)),Tick),ncol=2) - Tmp<- Doscaling(Tmp1) - axis(2,at=as.numeric(Tmp[,2]), labels=round(Tick,2)) - Tick<- sort(c(XMIN,XMAX,htick)) - Tmp1<- matrix(c(Tick,rep(0,length(Tick))),ncol=2) - Tmp<- Doscaling(Tmp1) - axis(1,at=as.numeric(Tmp[,1]), labels=round(Tick,2)) #### 10.12.04 to here - Tmp1<- c(XMIN,GENTEN[2]) - Tmp2<- c(XMAX,GENTEN[2]) - Tmp3<- Listplot(Tmp1,Tmp2) - Tmp<- MakeCurves(Tmp3,0) - if(Datalength(Tmp)>0){ - lines(Tmp[,1],Tmp[,2],col="green") - } - Tmp1<- c(GENTEN[1],YMAX) - Tmp2<- c(GENTEN[1],YMIN) - Tmp3<- Listplot(Tmp1,Tmp2) - Tmp<- MakeCurves(Tmp3,0) - if(Datalength(Tmp)>0){ - lines(Tmp[,1],Tmp[,2],col="green") - } - Tmp<-Doscaling(Framedata()) - lines(Tmp[,1],Tmp[,2]) - } - for (I in Looprange(1,Nargs)){ - Pdata<-Flattenlist(varargin[[I]]) # 101129 from here - Cmd<- list() - for (II in Looprange(1,length(Pdata))){ - Tmp<-Pdata[[II]] - if(length(Tmp)==1){ - Cmd<- c(Cmd,list(Tmp)) - next - } - - P<-MakeCurves(Tmp,0) - - if(length(Cmd)>0){ - if(length(Cmd)>=3){ - polygon(P,col=Cmd[[1]],border=Cmd[[2]],density=Cmd[[3]]) - } - else{ - polygon(P,col=Cmd[[1]],border=Cmd[[2]]) - } - next - } # 101129 to here - Ndm<-Dataindex(P) - for (J in Looprange(1,Nrow(Ndm))){ - Q<-P[Ndm[J,1]:Ndm[J,2],] - if(Nrow(Q)==1){ - Tmp<-seq(1,Ncol(Q),by=2) - for (K in Tmp){ - Pt<-Q[K:(K+1)] - points(Pt[1],Pt[2],col=color)#taka101111 - } - } - else{ - lines(Q[,1],Q[,2],col=color,lwd=width)#taka101111 - } - } - } - } - par(new=FALSE) -} - -###################################### - -# 3D - -################################# - -# 10.08.16 -CameracoordCurve<- function(Curve){ - Out<- c() - for(J in Looprange(1,Nrow(Curve))){ - P<- Ptcrv(J,Curve) #P=Curve(J,:); - Tmp<- P-FocusPoint - X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] - Tmp<- EyePoint-FocusPoint - E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] - Ca<- E1/sqrt(E1^2+F1^2) - Sa<- F1/sqrt(E1^2+F1^2) - X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 - E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 - Cb<- E2/sqrt(E2^2+G2^2) - Sb<- G2/sqrt(E2^2+G2^2) - X3<- X2*Cb+Z2*Sb; Y3<- Y2; Z3<- -X2*Sb+Z2*Cb - E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb - Xz<- X3 - Yz<- E3/(E3-X3)*Y3 - Zz<- E3/(E3-X3)*Z3 - Out<- rbind(Out,c(Yz,Zz,Xz)) - } - rownames(Out)<- 1:Nrow(Out) - return(Out) -} - -######################################### - -#100815 -CameraCurve<- function(Curve){ - Eps<- 10^(-6) - for (I in Looprange(1,Nrow(Curve))){ - P<- Curve[I,] - x<- P[1]; y<- P[2]; z<- P[3] - if(x!=Inf){ - Tmp<- Perspt(P) - if(I==1){ - AnsL<- rbind(c(),Tmp) - }else{ - Tmp1<- AnsL[Nrow(AnsL),] - if(Tmp1[1]==Inf || Norm(Tmp-Tmp1)>Eps){ - AnsL<- rbind(AnsL,Tmp) - } - } - }else{ - AnsL<- rbind(AnsL,c(Inf,Inf)) - } - } - rownames(AnsL)<- 1:Nrow(AnsL) - return(AnsL) -} - -###################################### - -Cancoordpara<- function(P){ # 18.02.15 - Xz<- P[1] - Yz<- P[2] - Zz<- P[3] - X<- -Xz*sin(PHI)-Yz*cos(PHI)*cos(THETA)+Zz*cos(PHI)*sin(THETA) - Y<- Xz*cos(PHI)-Yz*sin(PHI)*cos(THETA)+Zz*sin(PHI)*sin(THETA) - Z<- Yz*sin(THETA)+Zz*cos(THETA) - Out<- c(X,Y,Z) - return(Out) -} - -###################################### - -Cancoordpers<- function(P){ - Tmp<- EyePoint-FocusPoint - E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] - Ca<- E1/sqrt(E1^2+F1^2) - Sa<- F1/sqrt(E1^2+F1^2) - E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 - Cb<- E2/sqrt(E2^2+G2^2) - Sb<- G2/sqrt(E2^2+G2^2) - E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb - Xz<- P[3]; Yz<- P[1]; Zz<- P[2] - X3<- Xz; Y3<- Yz*(E3-Xz)/E3; Z3<- Zz*(E3-Xz)/E3 - X2<- X3*Cb-Sb*Z3; Y2<- Y3; Z2<- Cb*Z3+Sb*X3 - X1<- X2*Ca-Sa*Y2; Y1<- Ca*Y2+Sa*X2; Z1<- Z2 - X<- X1+FocusPoint[1] - Y<- Y1+FocusPoint[2] - Z<- Z1+FocusPoint[3] - Out<- c(X,Y,Z) - return(Out) -} - -####################################### - -Embed<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Pd3<- varargin[[1]] - if(Mixtype(Pd3)==1){ - Pd3<- list(Pd3) - } - else if(Mixtype(Pd3)==3){ - Tmp<- list(); - for(I in Looprange(1,length(Pd3))){ - Tmp<- c(Tmp,Pd3[[I]]) - } - Pd3<- Tmp - } - Tmpf=varargin[[2]] - if(mode(Tmpf)=="character"){ - Tmp<- varargin[[3]] - Tmp1<- gsub("c(","(",Tmp,fixed=TRUE) - Vstr<- gsub(")",")",Tmp1,fixed=TRUE) - Str<- paste("Tmpfn<- function",Vstr,"{",Tmpf,"}",sep="") - eval(parse(text=Str)) - } - else{ - Tmpfn<- Tmpf - } - Out<- list() - for(I in Looprange(1,length(Pd3))){ - PD<- Pd3[[I]] - Ans<- c() - for(J in Looprange(1,Nrow(PD))){ - P<- PD[J,] - Tmp<- Tmpfn(P[1],P[2]) - Ans<- rbind(Ans,Tmp) - } - Out<- c(Out, list(Ans)) - } - if(length(Out)==1){ - Out<- Out[[1]] - } - return(Out) -} - -####################### -# 10.08.17 -# 14.03.30 -Facesdata<- function(...){ - varargin<-list(...) - Nargs<- length(varargin) - FL<- varargin[[1]] - PT<- varargin[[length(varargin)]] - Tmp<-grep("para",PT,fixed=TRUE) - if(length(Tmp)>0){ - Ptype<- 1 - }else{ - Ptype<- -1 - } - if(Nargs==2){ - CLadd<- list() - }else{ - CLadd<- varargin[[2]] - } - NohiddenL<- list() - HiddenL<- list() - Eps<- 10^(-4) - if(length(CLadd)>0){ - if(mode(CLadd)=="numeric"){ - C<- list() - if(Nrow(CLadd)>1){ - for (I in Looprange(1,Nrow(CLadd))){ - C<- c(C,list(CLadd[I,])) - } - }else{ - I<- 1 - while (I<=Ncol(CLadd)){ - C<- c(C,list(CLadd[1,I:(I+2)])) - I<- I+3 - } - } - CrvL<- list(C) - }else if(mode(CLadd[[1]])=="numeric"){ - CrvL<- list() - for (J in Looprange(1,length(CL))){ - Ctmp<- CLadd[[J]] - C<- list() - if(Nrow(Ctmp)>1){ - for (I in Looprange(1,Nrow(Ctmp))){ - C<- c(C,list(Ctmp[I,])) - } - }else{ - I<- 1 - while(I<=Ncol(Ctmp)){ - C<- c(C,list(Ctmp[1,I:(I+2)])) - I<- I+3 - } - } - CrvL<- c(CrvL,list(C)) - } - }else{ - CrvL<- CLadd - } - }else{ - CrvL<- list() - } - Out<- MakeveLfaceL(FL) - VELNO<<- Out[[1]] - VELHI<<- list() - for (I in Looprange(1,length(CrvL))){ - Tmp<- CrvL[[I]] - for (J in Looprange(1,length(Tmp)-1)){ - Edge<- list(Tmp[J],Tmp[J+1]) - Ntmp<- length(VELNO) - VELNO(Ntmp+1)<<- list(Edge,0,Ntmp+1) - } - } - FaceL<- Out[[2]] - Tmp<- grep("raw",PT,fixed=TRUE) - if(length(Tmp)==0){ - for (Nf in Looprange(1,length(FaceL))){ - Face<- FaceL[[Nf]] - Menkakusi2(Face,Nf,Ptype) - } - } - for (I in Looprange(1,length(VELNO))){ - Edge<- Op(1,VELNO[[I]]) - if(Norm(Edge[[1]]-Edge[[2]])>Eps){ - NohiddenL<- c(NohiddenL,list(Spaceline(Edge))) - } - } - EdgeL<- list() # from 13.03.30 - for(K in Looprange(1,length(VELHI))){ - Edge<- Op(1,VELHI[[K]]) - P<- Edge[[1]]; Q<- Edge[[2]] - if(Norm(P-Q)>Eps){ - EdgeL<- c(EdgeL,list(Edge)) - } - } - for(K in Looprange(1,length(EdgeL))){ - Edge<- EdgeL[[K]] - P<- Edge[[1]]; Q<- Edge[[2]] - Cflg<- 0 - for(J in Looprange(K+1,length(EdgeL))){ - Ej<- EdgeL[[J]] - Pj<- Ej[[1]]; Qj<- Ej[[2]] - if(Norm(Crossprod(Q-P,Qj-Pj))>Eps){ - next - } - if(Norm(Q-Pj)0){ - break - } - } - Urg<- Stripblanks(Op(Jrg,FdL)) - StrV<- strsplit(Urg,"=",fixed=TRUE)[[1]] - Uname<- StrV[1] - Vrg<- Stripblanks(Op(Jrg+1,FdL)) - StrV<- strsplit(Vrg,"=",fixed=TRUE)[[1]] - Vname<- StrV[1] - if(Jrg==2){ - Tmp<- Stripblanks(Op(1,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Zf<- StrV[2] - Tmp<- list(Uname,Vname,Zf,Urg,Vrg) - Out<- c(Out,Tmp) - }else if(Jrg==4){ - Tmp<- Stripblanks(Op(1,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Zf<- StrV[2] - Tmp<- Stripblanks(Op(2,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Xname<- StrV[1] - Xf<- StrV[2] - Tmp<- Stripblanks(Op(3,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Yname<- StrV[1] - Yf<- StrV[2] - Tmp<- gsub(Xname,paste("(",Xf,")",sep=""),Zf,fixed=TRUE) - Zf<- gsub(Yname,paste("(",Yf,")",sep=""),Tmp,fixed=TRUE) - Tmp<- list(Xf,Yf,Zf,Urg,Vrg) - Out<- c(Out,Tmp) - }else{ - Tmp<- Stripblanks(Op(2,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Xf<- StrV[2] - Tmp<- Stripblanks(Op(3,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Yf<- StrV[2] - Tmp<- Stripblanks(Op(4,FdL)) - StrV<- strsplit(Tmp,"=",fixed=TRUE)[[1]] - Zf<- StrV[2] - Tmp<- list(Xf,Yf,Zf,Urg,Vrg) - Out<- c(Out,Tmp) - } - DrwS<- "enws" - BdyL<- c() - for (I in Looprange(Jrg+2,Mixlength(FdL))){ - Tmp<- Op(I,FdL) - if(mode(Tmp)=="character"){ - if(length(Tmp)==0){ - Tmp<- " " - } - DrwS<- Tmp - } - if(mode(Tmp)=="numeric" && Ncol(Tmp)>1){ - BdyL<- Tmp - } - } - Tmp<- list(DrwS,BdyL) - Out<- c(Out,Tmp) - return(Out) -} - -#################################### - -Initangle<- function (){ - PHI<<- 30*pi/180 - THETA<<- 60*pi/180 -} - -########################## - -Invparapt<- function(...){ - varargin<- list(...) - Eps<- 10^(-4) - Fk<- varargin[[length(varargin)]] - NFk<- Numptcrv(Fk) - Tmp<- varargin[[1]] - if(mode(Tmp)=="numeric" && length(Tmp)==1){ # debug - Ph<- Tmp - Fh<- varargin[[2]] - }else{ - Fh<- Projpara(Fk) - if(NFk>2){ - Tmp1<- Nearestpt(Tmp,Fh) - Ph<- Tmp1[[2]] - }else{ - Ah<- Ptcrv(1,Fh); Bh=Ptcrv(2,Fh) - V1<- Tmp-Ah; V2<- Bh-Ah - Tmp1<- Crossprod(V1,V2) - if(abs(Tmp1)>Eps){ - print("Not on the line") - return(c()) - }else{ - Ph<- Dotprod(V1,V2)/Norm(V2)^2+1 - } - } - } - if(NFk>2){ - N<- trunc(Ph) - S0<- Ph-N - if(Ph>Numptcrv(Fh)-Eps){ - Out<- list(Ptend(Fk),Numptcrv(Fh)) - return(Out) - } - }else{ - N<- 1 - S0<- Ph-1 - } - Ak<- Ptcrv(N,Fk); Bk=Ptcrv(N+1,Fk) - Ah<- Ptcrv(N,Fh); Bh=Ptcrv(N+1,Fh) - Ph<- (1-S0)*Ah+S0*Bh - T2<- S0 - Pk<- (1-T2)*Ak+T2*Bk - Out<- list(Pk,N+T2) - return(Out) -} - -################################# - -#100815 -Invperspt<- function(...){ - varargin<-list(...) - Eps<- 10^(-4) - Fk<- varargin[[length(varargin)]] - NFk<- Numptcrv(Fk) - Tmp<- varargin[[1]] - if(mode(Tmp)=="numeric" && length(Tmp)==1){ - Ph<- varargin[[1]] - Fh<- varargin[[2]] - }else{ - Fh<- Projpers(Fk) - if(NFk>2){ - Tmp1<- Nearestpt(Tmp,Fh) - Ph<- Tmp1[[2]] - }else{ - Ah<- Ptcrv(1,Fh); Bh<- Ptcrv(2,Fh) - V1<- Tmp-Ah; V2<- Bh-Ah - Tmp1<- Crossprod(V1,V2) - if(abs(Tmp1)>Eps){ - print("Not on the line") - Out<- c() - return(Out) - }else{ - Ph<- Dotprod(V1,V2)/Norm(V2)^2+1# 09.11.12 - } - } - } - if(NFk>2){ - N<- trunc(Ph) - S0<- Ph-N - if(Ph>Numptcrv(Fh)-Eps){ - Out<- list(Ptend(Fk),Numptcrv(Fh)) - return(Out) - } - }else{ - N<- 1 - S0<- Ph-1 # 09.11.12 - } - Ak<- Ptcrv(N,Fk); Bk<- Ptcrv(N+1,Fk) - Ah<- Ptcrv(N,Fh); Bh<- Ptcrv(N+1,Fh) - Ph<- (1-S0)*Ah+S0*Bh - Phc<- Cancoordpers(c(Ph,0)) - Ahc<- Cancoordpers(c(Ah,0)) - Bhc<- Cancoordpers(c(Bh,0)) - Vp<- Phc-EyePoint - Va<- Ak-EyePoint - AB<- Bk-Ak - Cp<- Crossprod(Vp,AB) - Nmr<- Crossprod(Va,Vp) - Mx<- max(abs(Cp)) - if(abs(Cp[1])==Mx){ - T2<- Nmr[1]/Cp[1] - }else if(abs(Cp[2])==Mx){ - T2<- Nmr[2]/Cp[2] - }else{ - T2<- Nmr[3]/Cp[3] - } - Pk<- (1-T2)*Ak+T2*Bk - Out<- list(Pk,N+T2) - return(Out) -} - -######################### - -Kukannozoku<- function(Jokyo,KukanL){ - Eps<- 10^(-6) - N<- Nrow(KukanL) - T1<- Jokyo[1]; T2<- Jokyo[2] - Tmp<- KukanL[1,] - T1<- max(T1,Tmp[1]) - Tmp<- KukanL[N,] - T2<- min(T2,Tmp[2]) - Res<- c() - Flg<- 0 - for (I in Looprange(1,N)){ - Ku<- KukanL[I,] - if(Flg==0){ - if(Ku[2]T2+Eps){ - Tmp<- c(T2,Ku[2]) - Res<- rbind(Res,Tmp) - } - } - }else if(Flg==1){ - if(Ku[2]0){ - for (J in 1:Mixlength(KC)){ - P<- Op(1,Op(J,KC)) - Tmp<- Op(2,Op(J,KC)) - if(Tmp<1+Eps && Ns==1){ - next - } - if(Tmp>Numptcrv(P1)-Eps && Ns==(Nrow(PhL)-1)){ - next - } - N1<- Ns - N2<- Op(3,Op(J,KC)) - Pa<- Plt2[N1,1:2] - Za<- Plt2[N1,3] - Pb<- Plt2[N1+1,1:2] - Zb<- Plt2[N1+1,3] - if(Norm(Pa-Pb)Eps^2){ - Tmp1<- P1[2,]-P1[1,] - Tmp2<- Pb-Pa - Tmp3<- Dotprod(Tmp1,Tmp2) - Tmp3<- Tmp3/Norm(Tmp1)/Norm(Tmp2) - Tmp<- 1-0.5*Tmp3^2 - ClipL<- rbind(ClipL,c(P,N1,T1,R0/Tmp)) - } - } - } - } - } - } - Te<- Nrow(Plt2) - KukanL<- rbind(c(),c(1.0,Te)) - P1<- PhL - if(Nrow(ClipL)>0){ - for (I in 1:Nrow(ClipL)){ - P<- ClipL[I,1:2] - NN<- ClipL[I,3] - T<- NN+ClipL[I,4] - R<- ClipL[I,5] - Flg<- 0 - for (J in NN:1){ - Q<- Pointoncurve(J,P1) - if(Norm(P-Q)Eps){ - Tmp<- Pointoncurve(T2,P1) - PtL<- c(PtL,list(Tmp)) - } - Res<- c(Res,list(Listplot(PtL))) - } - Allres<- c(Allres,Res) - } - return(Allres) -} - -######################### - -#100815 -Makeskeletonpersdata<- function(Obj2L,Plt2L,R0,Eps2){ - Eps<- 10.0^(-3) - Dmat<- c() - Dind<- c() - for (I in Looprange(1,Mixlength(Plt2L))){ - Dt<- Op(I,Plt2L) - N1<- Nrow(Dmat)+1 - Dmat<- rbind(Dmat,Dt) - N2<- Nrow(Dmat) - Dind<- rbind(Dind,c(N1,N2)) - } - Nind<- Nrow(Dind) - Allres<- list() - for (Nobj in Looprange(1,Mixlength(Obj2L))){ - Plt2<- Op(Nobj,Obj2L) - PhL<- Plt2[,1:2] - ClipL<- c() - for (Ns in Looprange(1,Nrow(PhL)-1)){ - P1<- PhL[Ns:(Ns+1),] - for (I in Looprange(1,Nrow(Dind))){ - Tmp<- Dmat[Dind[I,1]:Dind[I,2],] - P2<- Tmp[,1:2] - KC<- IntersectcrvsPp(P1,P2,Eps) - if(Mixlength(KC)>0){ - for (J in Looprange(1,Mixlength(KC))){# - P<- Op(1,Op(J,KC)) - Tmp<- Op(2,Op(J,KC)) - if(Tmp<(1+Eps) && Ns==1){ - next - } - if(Tmp>Numptcrv(P1)-Eps && Ns==(Nrow(PhL)-1)){ - next - } - N1<- Ns - N2<- Op(3,Op(J,KC)) - Pa<- Plt2[N1,1:2] - Za<- Plt2[N1,3] - Pb<- Plt2[N1+1,1:2] - Zb<- Plt2[N1+1,3] - if(Norm(Pa-Pb)1-Eps){ - Pk<- Pkb - }else{ - Tmp1<- Listplot(c(Pa,Pb)) - Tmp2<- Spaceline(c(Pka,Pkb)) - Tmp<- Invperspt(1+T1,Tmp1,Tmp2) - Pk<- Op(1,Tmp) - } - Z1<- Zperspt(Pk) - Tmp<- Dmat[Dind[I,1]:Dind[I,2],] - Pa<- Tmp[N2,1:2] - Za<- Tmp[N2,3] - Pb<- Tmp[N2+1,1:2] - Zb<- Tmp[N2+1,3] - if(Norm(Pa-Pb)(1-Eps)){ - Pk<- Pkb - }else{ - Tmp1<- Listplot(c(Pa,Pb)) - Tmp2<- Spaceline(c(Pka,Pkb)) - Tmp<- Invperspt(1+T2,Tmp1,Tmp2) - Pk<- Op(1,Tmp) - } - Z2<- Zperspt(Pk) - if(Z1<(Z2-Eps2)){ - if(length(ClipL)==0){ - Tmp<- 1 - }else{ - Tmp1<- ClipL[,1]-P[1] - Tmp2<- ClipL[,2]-P[2] - Tmp3<- Tmp1^2+Tmp2^2 - Tmp<- min(Tmp3) - } - if(Tmp>Eps^2){ - Tmp1<- P1[2,]-P1[1,] - Tmp2<- Pb-Pa - Tmp3<- Dotprod(Tmp1,Tmp2) - Tmp3<- Tmp3/Norm(Tmp1)/Norm(Tmp2) - Tmp<- 1-0.5*Tmp3^2 - ClipL<- rbind(ClipL,c(P,N1,T1,R0/Tmp)) - } - } - } - } - } - } - Te<- Nrow(Plt2) - KukanL<- rbind(c(),c(1.0,Te)) - P1<- PhL - if(Nrow(ClipL)>0){ - for (I in Looprange(1,Nrow(ClipL))){ - P<- ClipL[I,1:2] - NN<- ClipL[I,3] - T<- NN+ClipL[I,4] - R<- ClipL[I,5] #added 10.08.17 - Flg<- 0 - for (J in NN:1){ - Q<- Pointoncurve(J,P1) - if(Norm(P-Q)Eps){ - Tmp<- Pointoncurve(T2,P1) - PtL<- c(PtL,list(Tmp))#Mixadd(PtL,Tmp) - } - Res<- c(Res,list(Listplot(PtL)))#Res<- Mixadd(Res,Listplot(PtL)) - } - Allres<- c(Allres,Res)#Allres<- Mixjoin(Allres,Res) - } - return(Allres) -} - -##############################3 - -MakeveLfaceL<- function(VfL){ -# // Out format -# // VeL Edge, Face num(as numlist), VeL num -# // FL Face (Vertexs) - Eps<- 10^(-4) - Tmp<- VfL[[length(VfL)]] - Tmp1<- Tmp[[1]] - if(mode(Tmp1)=="numeric"){ - FvL<- list(VfL) - }else{ - FvL<- VfL - } - EL<- list(); FL<- list() - for (Nn in Looprange(1,length(FvL))){ - Tmp<- FvL[[Nn]] - VL<- Tmp[[1]] - if(length(VL)>0){ - FnL<- Tmp[[2]] - FaceL<- list() - for (I in Looprange(1,length(FnL))){ - Tmp1<- FnL[[I]] - PtL<- list() - for (J in Looprange(1,length(Tmp1))){ - Tmp2<- Tmp1[[J]] - PtL[[J]]<- VL[[Tmp2]] - } - FaceL[[I]]<- PtL - } - }else{ - FaceL<- list(Tmp[[2]]) - } - for (I in Looprange(1,length(FaceL))){ - Face<- FaceL[[I]] - Face<- c(Face,list(Face[[1]])) - FL<- c(FL,list(Face)) - for (J in Looprange(1,length(Face)-1)){ - Edge<- list(Face[[J]],Face[[J+1]]) - Flg<- 0 - for (K in Looprange(1,length(EL))){ - Tmp<- EL[[K]] - Tmp1<- Tmp[[1]] - Tmp2<- Norm(Edge[[1]]-Tmp1[[1]])+Norm(Edge[[2]]-Tmp1[[2]]) - Tmp3<- Norm(Edge[[1]]-Tmp1[[2]])+Norm(Edge[[2]]-Tmp1[[1]]) - if(Tmp21-Eps){# // P3, Q3 are necessary - Flg<- I - break - } - if(abs(Te-Ts)>Eps0){ - if((I%%2)==1){ - Out1<- c(Out1,list(list(Pe3,P3))) - }else{ - if(length(Qe3)==0){ - Tmp<- Op(2,TenL[[I-1]]) - if(Ptype==-1){ - Tmp1<- Invperspt(Tmp,Spaceline(Face)) - }else{ - Tmp1<- Invparapt(Tmp,Spaceline(Face)) - } - Qe3<- Tmp1[[1]] - } - PM<- 0.5*(Pe3+P3); QM<- 0.5*(Qe3+Q3) - if(Ptype==-1){ - Z1<- Zperspt(PM); Z2<- Zperspt(QM) - }else{ - Z1<- Zparapt(PM); Z2<- Zparapt(QM) - } - if(Z1>Z2){ - Out1<- c(Out1, list(list(Pe3,P3))) - }else{ - Out2<- c(Out2, list(list(Pe3,P3))) - }## - } - } - Te<- Ts; Pe3<- P3; Qe3<- Q3 - } - if(Flg==0){ - if(Norm(Pe3-Edge[[2]])>Eps0){ - Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) - } - }else{ - if((Flg%%2)==1){ - Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) - }else{ - PM<- 0.5*(Pe3+P3); QM<- 0.5*(Qe3+Q3) - if(Ptype==-1){ - Z1<- Zperspt(PM); Z2<- Zperspt(QM) - }else{ - Z1<- Zparapt(PM); Z2<- Zparapt(QM) - } - if(Z1>Z2){ - Out1<- c(Out1, list(list(Pe3,Edge[[2]]))) - }else{ - Out2<- c(Out2, list(list(Pe3,Edge[[2]]))) - } - } - } - for (I in Looprange(1,length(Out1))){ - Tmp<- Out1[[I]] - if(I==1){ - SeL<- Tmp - }else{ - if(Norm(SeL[[2]]-Tmp[[1]])0){ - Out1L<- c(Out1L, list(list(SeL,Ne,NNe))) - } - for (I in Looprange(1,length(Out2))){ - Tmp<- Out2[[I]] - if(I==1){ - SeL<- Tmp - }else{ - if(Norm(SeL[[2]]-Tmp[[1]])0){ - Out2L<- c(Out2L, list(list(SeL,Ne,NNe))) - } - } - VELNO<<- Out1L - VELHI<<- Out2L -} - -################################### - -Parapt<- function(Plist){ # 18.02.19 changed (for point list) - if(!is.list(Plist)){Plist=list(Plist)} - Out=list() - for(jj in 1:length(Plist)){ - P=Op(jj,Plist) - x<- P[1] - y<- P[2] - z<- P[3] - Xz<- -x*sin(PHI)+y*cos(PHI) - Yz<- -x*cos(PHI)*cos(THETA)-y*sin(PHI)*cos(THETA)+z*sin(THETA) - Out<- c(Out,list(c(Xz,Yz))) - } - if(length(Out)==1){Out=Op(1,Out)} - return(Out) -} - -################################### - -Partcrv3<- function(T1,T2,Fk){ - Eps0=10^(-4) -#// Tmp=Mixop(1,Fk) -#// new part from - if(T1>(T2+Eps0)){ - Npt<- Nrow(Fk) - Out1<- Partcrv3(T1,Npt,Fk) - Out2<- Partcrv3(1,T2,Fk) - Tmp<- Fk[1,]-Fk[Npt,] - if(Norm(Tmp)(Ie+Eps0)){ - P<- (1-T2+Ie)*Fk[Ie,]+(T2-Ie)*Fk[Ie+1,] - PL<- Appendrow(PL,P) - } - } - return(PL) -} - -################################### - -#100815 -Perspt<- function(P){ - Tmp<- P-FocusPoint - X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] - Tmp<- EyePoint-FocusPoint - E1<- Tmp[1];F1<- Tmp[2];G1<- Tmp[3] - Ca<- E1/sqrt(E1^2+F1^2) - Sa<- F1/sqrt(E1^2+F1^2) - X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 - E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 - Cb<- E2/sqrt(E2^2+G2^2) - Sb<- G2/sqrt(E2^2+G2^2) - X3<- X2*Cb+Z2*Sb; Y3<- Y2; Z3<- -X2*Sb+Z2*Cb - E3<- E2*Cb+G2*Sb; F3<- F2; G3<- -E2*Sb+G2*Cb - Yz<- E3/(E3-X3)*Y3 - Zz<- E3/(E3-X3)*Z3 - Out<- c(Yz,Zz) - return(Out) -} - - -################################# - -Phcutdata<- function(VL,FaceL,PlaneD){ - Out<- list() - EL<- list() - Eps<- 10^(-4) - for (I in Looprange(1,Mixlength(FaceL))){ - Face<- Op(I,FaceL) - for (J in Looprange(1,length(Face))){ - Nj<- J+1 - if(J==length(Face)){ - Nj<- 1 - } - N1<- Face[J]; N2<- Face[Nj] - Tmp<- c(N1,N2) - Flg<- 0 - for (K in Looprange(1,Mixlength(EL))){ - Tmp1<- Op(K,EL) - Tmp2<- Tmp1[2:1] - if(all(Tmp==Tmp1) || all(Tmp==Tmp2)){ - Flg<- 1 - break - } - } - if(Flg==0){ - EL<- c(EL,list(Tmp)) - } - } - } - Out0<- list() - for (I in Looprange(1,Mixlength(EL))){ - Tmp<- Op(I,EL) - Tmp1<- Op(Tmp[1],VL) - Tmp2<- Op(Tmp[2],VL) - Out0<- c(Out0, list(Spaceline(Tmp1,Tmp2))) - } - if(Mixtype(PlaneD)!=1){ - V1<- Op(1,PlaneD) - Tmp<- Op(2,PlaneD) - if(length(Tmp)>1){ - d<- V1[1]*Tmp[1]+V1[2]*Tmp[2]+V1[3]*Tmp[3] - }else{ - d<- Tmp - } - }else if(mode(PlaneD)=="numeric"){ - V1<- PlaneD[1:3] - d<- PlaneD[4] - }else{ - StrV<- strsplit(PlaneD,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Tmp1<- StrV[1] - Tmp2<- StrV[2] - PlaneD<- paste(Tmp1,"-(",Tmp2,")",sep="") - } - x<- 0; y<- 0; z<- 0 - d<- -eval(parse(text=PlaneD)) - x<- 1; y<- 0; z<- 0; - Tmp1<- eval(parse(text=PlaneD))+d - x<- 0; y<- 1; z<- 0 - Tmp2<- eval(parse(text=PlaneD))+d - x<- 0; y<- 0; z<- 1 - Tmp3<- eval(parse(text=PlaneD))+d - V1<- c(Tmp1,Tmp2,Tmp3) - } - if(all(V1==c(0,0,0))){ - return(Out0) - } - V3<- c(1,0,0) - Out1<- Rotate3data(Out0,V1,V3) - Tmp2<- Rotate3pt(c(1,0,0),V3,V1) - Tmp<- V1[1]*Tmp2[1]+V1[2]*Tmp2[2]+V1[3]*Tmp2[3] - x0<- d/Tmp - PtL<- list() - for (I in Looprange(1,Mixlength(Out1))){ - Tmp<- Op(I,Out1) - Tmp1<- Tmp[1,]; Tmp2<- Tmp[2,] - P<- list(Tmp1,Tmp2-Tmp1) - Tmp<- list(Tmp1[1],Tmp2[1]-Tmp1[1]) - if(abs(Tmp[[2]]) < Eps){ - Tmp<- c() - }else{ - Tmp1<- Tmp[[2]] - Tmp2<- x0-Tmp[[1]] - Tmp<- c(Tmp2/Tmp1) - } - if(length(Tmp)>0){ - Tmp<- Tmp[1] - if(Tmp>-Eps && Tmp<(1+Eps)){ - Tmp3<- P[[1]]+Tmp*P[[2]] - Tmp3<- Rotate3pt(Tmp3,V3,V1) - if(Tmp1-Eps){ - Tmp1<- Op(I,EL) - Tmp1<- Tmp1[2] - Tmp4<- list(c(Tmp1,Tmp1),Tmp3) - }else{ - Tmp4<- list(Op(I,EL),Tmp3) - } - } - Flg<- 0 - for (J in Looprange(1,Mixlength(PtL))){ - Tmp<- Op(J,PtL) - Tmp<- Op(2,Tmp) - if(Norm(Tmp3-Tmp)1){ - d<- V1[1]*Tmp[1]+V1[2]*Tmp[2]+V1[3]*Tmp[3] - }else{ - d<- Tmp - } - }else if(mode(PlaneD)=="numeric"){ - V1<- PlaneD[1:3] - d<- PlaneD[4] - }else{ - StrV<- strsplit(PlaneD,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Tmp1<- StrV[1] - Tmp2<- StrV[2] - PlaneD<- paste(Tmp1,"-(",Tmp2,")",sep="") - } - x<- 0; y<- 0; z<- 0 - d<- -eval(parse(text=PlaneD)) - x<- 1; y<- 0; z<- 0 - Tmp1<- eval(parse(text=PlaneD))+d - x<- 0; y<- 1; z<- 0 - Tmp2<- eval(parse(text=PlaneD))+d - x<- 0; y<- 0; z<- 1 - Tmp3<- eval(parse(text=PlaneD))+d - V1<- c(Tmp1,Tmp2,Tmp3) - } - for (I in Looprange(1,Mixlength(FaceL))){ - Face<- Op(I,FaceL) - TmpL<- list() - for (J in Looprange(1,length(Face))){ - N1<- Face[J] - if(J==length(Face)){ - N2<- Face[1] - }else{ - N2<- Face[J+1] - } - for (K in Looprange(1,Mixlength(PtL))){ - Pd<- Op(K,PtL) - Tmp<- Op(1,Pd) - if(Tmp[1]==Tmp[2]){ - if(Tmp[1]==N1){ - TmpL<- c(TmpL,list(list(J,c(N1,N2),Op(2,Pd)))) - } - }else{ - if(all(Tmp==c(N1,N2)) || all(Tmp==c(N2,N1))){ - TmpL<- c(TmpL,list(list(J,c(N1,N2),Op(2,Pd)))) - } - } - } - } - if(Mixlength(TmpL)<2){ - Flg<- 0 - for (J in Looprange(1,length(Face))){ - Tmp<- Op(Face[J],VL) - Tmp1<- Fugou*(Dotprod(V1,Tmp)-d) - if(Tmp1< -Eps){ - Flg<- 1 - break - } - } - if(Flg==0){ - OutfL<- c(OutfL,list(Face)) - } - next - } - Pd<- Op(1,TmpL) - Qd<- Op(2,TmpL) - Outf1<- c(Op(3,Pd)) - Nf<- Op(1,Pd)+1 - Tmp<- Op(2,Pd) - JJ<- 0 - while (!all(Tmp==Op(2,Qd))){ - JJ<- JJ+1 - if(JJ>20){ - print("bug") - return() - } - Tmp1<- Tmp[2] - if(Outf1[length(Outf1)]!=Tmp1){ - Outf1<- c(Outf1,Tmp1) - } - Tmp<- c(Face[Nf]) - Nf<- Nf+1 - if(Nf>length(Face)){ - Nf<- 1 - } - Tmp<- c(Tmp,Face[Nf]) - } - Tmp1<- Op(3,Qd) - if(Outf1[length(Outf1)]!=Tmp1){ - Outf1<- c(Outf1,Tmp1) - } - Outf2<- c(Op(3,Pd)) - Nf<- Op(1,Pd) - Tmp<- Op(2,Pd) - JJ<- 0 - while (!all(Tmp==Op(2,Qd))){ - JJ<- JJ+1 - if(JJ>20){ - print("bug") - return() - } - Tmp1<- Tmp[1] - if(Outf2[length(Outf2)]!=Tmp1){ - Outf2<- c(Outf2,Tmp1) - } - Tmp<- c(Face[Nf]) - Nf<- Nf-1 - if(Nf<1){ - Nf<- length(Face) - } - Tmp<- c(Face[Nf],Tmp) - } - Tmp1<- Op(3,Qd) - if(Outf2[length(Outf2)]!=Tmp1){ - Outf2<- c(Outf2,Tmp1) - } - if(length(Outf1)<3 || length(Outf2)<3){ - Face<- Outf1 - if(length(Outf1)=4){ - C<- 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) - Ans<- c() - for (J in Looprange(1,Nrow(PD))){ - if(is.matrix(PD)){ # 11.08.27 - P<- PD[J,] - } - else{ - P<- PD - } - Tmp<- Rotate3pt(P,W1,W2,C) # 14.03.23 - Ans<- rbind(Ans,Tmp) - } # 11.08.27 - rownames(Ans)<- 1:Nrow(Ans) #10.08.16 - Out<- c(Out,list(Ans)) - } - if(Mixlength(Out)==1){ - Out<- Op(1,Out) - } - return(Out) -} - -####################################### - -Rotate3pt<- function(...){ - varargin<-list(...) - Eps<-10^(-4) - Nargs<-length(varargin) - P<- varargin[[1]] - W1<- varargin[[2]] - W2<- varargin[[3]] - C<- c(0,0,0) - if(Nargs>=4){ - C<- varargin[[4]] - } - if(mode(W2)=="numeric" && length(W2)==1){ - Ct<- cos(W2) - St<- sin(W2) - V3<- 1/Norm(W1)*W1 - if(V3[1]==0){ - Tmp<- c(1,0,0) - }else{ - Tmp<- c(0,1,0) - } - W1<- c(Tmp[2]*V3[3]-Tmp[3]*V3[2], - Tmp[3]*V3[1]-Tmp[1]*V3[3], - Tmp[1]*V3[2]-Tmp[2]*V3[1]) - V1<- 1/Norm(W1)*W1 - V2<- c(V3[2]*V1[3]-V3[3]*V1[2], - V3[3]*V1[1]-V3[1]*V1[3], - V3[1]*V1[2]-V3[2]*V1[1]) - }else{ - Tmp<- c(W1[2]*W2[3]-W1[3]*W2[2], - W1[3]*W2[1]-W1[1]*W2[3], - W1[1]*W2[2]-W1[2]*W2[1]) - if(Norm(Tmp)=3){ - Ndu<- varargin[[2]] - Ndv<- varargin[[3]] - } - if(Nargs>=4){ - Np<- varargin[[4]] - if(mode(Np)=="numeric" && length(Np)==1){ - Np<- c(Np,Np) - } - } - Du<- (Umax-Umin)/Ndu - Dv<- (Vmax-Vmin)/Ndv - PL <- c()#PL <- [] - Assign("Vmin",Vmin,"Vmax",Vmax) - Trgstr<- Assign("t=c(Vmin,Vmax)") - PL <- list() - for (I in Looprange(0,Ndu)){ - U0 <- paste("(",as.character(Umin+I*Du),")",sep="") - Tmp<- gsub(U,U0,Xf,fixed=TRUE) - Tmp1<- gsub(V,"t",Tmp,fixed=TRUE) - Tmp<- gsub(U,U0,Yf,fixed=TRUE) - Tmp2<- gsub(V,"t",Tmp,fixed=TRUE) - Tmp<- gsub(U,U0,Zf,fixed=TRUE) - Tmp3<- gsub(V,"t",Tmp,fixed=TRUE) - Tmp<- paste("c(",Tmp1,",",Tmp2,",",Tmp3,")",sep="") - PD<- Spacecurve(Tmp,Trgstr,paste("N=",as.character(Np[2]))) - PL<- c(PL,list(PD)) - } - Assign("Umin",Umin,"Umax",Umax) - Trgstr<- Assign("t=c(Umin,Umax)") - for (J in Looprange(0,Ndv)){ - V0<- paste("(",as.character(Vmin+J*Dv),")",sep="") - Tmp<- gsub(V,V0,Xf,fixed=TRUE) - Tmp1<- gsub(U,"t",Tmp,fixed=TRUE) - Tmp<- gsub(V,V0,Yf,fixed=TRUE) - Tmp2<- gsub(U,"t",Tmp,fixed=TRUE) - Tmp<- gsub(V,V0,Zf,fixed=TRUE) - Tmp3<- gsub(U,"t",Tmp,fixed=TRUE) - Tmp<- paste("c(",Tmp1,",",Tmp2,",",Tmp3,")") - PD<- Spacecurve(Tmp,Trgstr,paste("N=",as.character(Np[1]))) - PL<- c(PL,list(PD)) - } - return(PL) -} - -################################### - -Skeletonparadata<- function(...){ - varargin<-list(...) - Nargs<- length(varargin) - Out<- list() - ObjL<- Flattenlist(varargin[[1]]) - Plt3L<- Flattenlist(varargin[[2]]) - R<- 0.075*1000/2.54/MilliIn - if(Nargs>2){ - R<- R*varargin[[3]] - } - Eps2<- 0.05 - if(Nargs>3){ - Eps2<- varargin[[4]] - } - Obj2L<- list() - for (I in Looprange(1,Mixlength(ObjL))){ - Tmp<- ProjcoordCurve(Op(I,ObjL)) - Obj2L<- c(Obj2L,list(Tmp)) - } - Plt2L<- list() - for (I in Looprange(1,Mixlength(Plt3L))){ - Tmp<- ProjcoordCurve(Op(I,Plt3L)) - Plt2L<- c(Plt2L,list(Tmp)) - } - Out<- Makeskeletondata(Obj2L,Plt2L,R,Eps2) - return(Out) -} - -################################ - -Skeletonpara3data<- function(...){ - varargin<-list(...) - Nargs<- length(varargin) - ObjL<- Flattenlist(varargin[[1]]) - Plt3L<- Flattenlist(varargin[[2]]) - R<- 0.075*1000/2.54/MilliIn - if(Nargs>2){ - R=R*varargin[[3]] - } - Eps2<- 0.05 - if(Nargs>3){ - Eps2<- varargin[[4]] - } - Plt2L<- list() - for (I in Looprange(1,Mixlength(Plt3L))){ - Tmp<- ProjcoordCurve(Op(I,Plt3L)) - Plt2L<- c(Plt2L,list(Tmp)) - } - Out<- list() - for (I in Looprange(1,Mixlength(ObjL))){ - Obj3<- Op(I,ObjL) - Tmp<- ProjcoordCurve(Obj3) - Data<- Makeskeletondata(list(Tmp),Plt2L,R,Eps2) - for (J in Looprange(1,Mixlength(Data))){ - Gd<- Op(J,Data) - PtD<- c() - for (J in Looprange(1,Nrow(Gd))){ - Tmp<- Ptcrv(J,Gd) - Tmp1<- Invparapt(Tmp,Obj3) - Tmp1<- Op(1,Tmp1) - PtD<- c(PtD,Tmp1) - } - PtD<- matrix(PtD,ncol=3,byrow=TRUE) - Out<- c(Out,list(PtD)) - } - } - return(Out) -} - -################################# - -#100815 -Skeletonpersdata<- function(...){ - varargin<-list(...) - Nargs<- length(varargin) - Out<- list() - ObjL<- Flattenlist(varargin[[1]]) - Plt3L<- Flattenlist(varargin[[2]]) - R<- 0.075*1000/2.54/MilliIn - if(Nargs>2){ - R<- R*varargin[[3]] - } - Eps2<- 0.05 - if(Nargs>3){ - Eps2<- varargin[[4]] - } - Obj2L<- list() - for (I in Looprange(1,Mixlength(ObjL))){ - Tmp<- CameracoordCurve(Op(I,ObjL)) - Obj2L<- c(Obj2L,list(Tmp)) - } - Plt2L<- list() - for (I in Looprange(1,Mixlength(Plt3L))){ - Tmp<- CameracoordCurve(Op(I,Plt3L)) - Plt2L<- c(Plt2L,list(Tmp)) - } - Out<- Makeskeletonpersdata(Obj2L,Plt2L,R,Eps2) - return(Out) -} - -##################### -#100815 -Skeletonpers3data<- function(...){ - varargin<-list(...) - Nargs<- length(varargin) - Out<- list() - ObjL<- Flattenlist(varargin[[1]]) - Plt3L<- Flattenlist(varargin[[2]]) - R<- 0.075*1000/2.54/MilliIn - if(Nargs>2){ - R<- R*varargin[[3]] - } - Eps2<- 0.05 - if(Nargs>3){ - Eps2<- varargin[[4]] - } - Plt2L<- list() - for (I in Looprange(1,Mixlength(Plt3L))){ - Tmp<- CameracoordCurve(Op(I,Plt3L)) - Plt2L<- c(Plt2L,list(Tmp)) - } - Out<- list() - for (I in Looprange(1,Mixlength(ObjL))){ - Obj3<- Op(I,ObjL) - Tmp<- CameracoordCurve(Obj3) - Data<- Makeskeletonpersdata(list(Tmp),Plt2L,R,Eps2) - for (J in Looprange(1,Mixlength(Data))){ - Gd<- Op(J,Data) - PtD<- c() - for (J in Looprange(1,Nrow(Gd))){ - Tmp<- Gd[J,] - Tmp1<- Invperspt(Tmp,Obj3) - Tmp1<- Op(1,Tmp1) - PtD<- rbind(PtD,Tmp1) - } - Out<- c(Out,list(PtD)) - } - } - return(Out) -} - -################################# - -Spacecurve<- function(...){ - Eps<- 10^(-5) - varargin<-list(...) - Nargs<- length(varargin) - Fnstr<- varargin[[1]] - Rgstr<- varargin[[2]] - Range<- c(0,2*pi) - N<- 50 #Numpoints - E<- c() #Exclusions - D<- Inf #Discont (Changed) - for(I in Looprange(3,Nargs)){ - Tmp<- varargin[[I]] - StrV<- strsplit(Tmp,"=",fixed=TRUE) - StrV<- StrV[[1]] - Tmp1<- toupper(StrV[1]) - Lhs<- substr(Tmp1,1,1) - Str<- paste(Lhs,"=",StrV[2],sep="") - eval(parse(text=Str)) - } - StrV<- strsplit(Rgstr,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Vname<- StrV[1] - Rng<- eval(parse(text=StrV[2])) - } - else{ - Vname<- Rgstr - Rng<- c(XMIN,XMAX) - } - T1<- Rng[1]; T2<- Rng[2] - Dt<- (T2-T1)/N #17.09.22 - Str<- gsub(Vname,"t",Fnstr) - Str=gsub("[","c(",Str,fixed=TRUE) #17.12.22(2lines) - Str=gsub("]",")",Str,fixed=TRUE) - if(abs(Dt)0 && P[Nrow(P),1]!=Inf){ - Pa<- c(Inf,Inf,Inf) - } - } - if(t-E[Ke]>Eps){ - Pa<- eval(parse(text=Str)) - Ke<- Ke+1 - } - if(length(Pa)>0){ - if(Pa[1]==Inf){ - P<- rbind(P,Pa) - }else if(length(P)==0){ - P<- rbind(c(),c(Pa)) - } - else{ - Tmp<- P[Nrow(P),] - if(Tmp[1]==Inf){ - P<- rbind(P,Pa) - } - else if( Norm(Tmp-Pa)1) StrV<- StrV[2] - Tmp<- eval(parse(text=StrV)) - Py<- c(0,Tmp[1],0) - Qy<- c(0,Tmp[2],0) - StrV<-strsplit(Zrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1) StrV<- StrV[2] - Tmp<- eval(parse(text=StrV)) - Pz<- c(0,0,Tmp[1]) - Qz<- c(0,0,Tmp[2]) - Out<- list(Spaceline(Px,Qx),Spaceline(Py,Qy),Spaceline(Pz,Qz)) - return(Out) -} - -################################### - -Xyzaxparaname<- function(...){ - varargin<- list(...) - Nargs<- length(varargin) - Eps<- 10.0^(-6) - Dr<- 0.19*1000/2.54/MilliIn - Tmp<- varargin[[Nargs]] - if(Nargs>1 && is.numeric(Tmp)){ - Dr<- Dr*Tmp - Nargs<- Nargs-1 - } - if(mode(varargin[[1]])=="character"){ - Xname<- "x" - Yname<- "y" - Zname<- "z" - Xrange<- varargin[[1]] - Yrange<- varargin[[2]] - Zrange<- varargin[[3]] - StrV<-strsplit(Xrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Xname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Px<- c(Tmp[1],0,0) - Qx<- c(Tmp[2],0,0) - StrV<-strsplit(Yrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Yname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Py<- c(0,Tmp[1],0) - Qy<- c(0,Tmp[2],0) - StrV<-strsplit(Zrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Zname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Pz<- c(0,0,Tmp[1]) - Qz<- c(0,0,Tmp[2]) - }else{ - Data<- varargin[[1]] - Xname<- "x"; Yname<- "y"; Zname<- "z" - if(Nargs>1){ - if(varargin[[2]]!=""){ - Xname<- varargin[[2]] - } - if(varargin[[3]]!=""){ - Yname<- varargin[[3]] - } - if(varargin[[4]]!=""){ - Zname<- varargin[[4]] - } - } - Tmp<- Op(1,Data) - Px<- Tmp[1,]; Qx<- Tmp[2,] - Tmp<- Op(2,Data) - Py<- Tmp[1,] - Qy<- Tmp[2,] - Tmp<- Op(3,Data) - Pz<- Tmp[1,] - Qz<- Tmp[2,] - } - Ph<- Parapt(Px); Qh<- Parapt(Qx); R<-Norm(Ph-Qh) - Kekka<- list() - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Xname) - } - Ph<- Parapt(Py); Qh<- Parapt(Qy); R<- Norm(Ph-Qh) - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Yname) - } - Ph<- Parapt(Pz); Qh<- Parapt(Qz); R<- Norm(Ph-Qh) - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Zname) - } -# return(Kekka) -} - -################################### - -Xyzaxpersname<- function(...){ - varargin<- list(...) - Eps<- 10.0^(-6) - Nargs<- length(varargin) - Dr<- 0.19*1000/2.54/MilliIn - Tmp<- varargin[[Nargs]] - if(Nargs>1 && mode(Tmp)=="numeric"){ - Dr<- Dr*Tmp - Nargs<- Nargs-1 - } - if(mode(varargin[[1]])=="character"){ - Xname<- "x" - Yname<- "y" - Zname<- "z" - Xrange<- varargin[[1]] - Yrange<- varargin[[2]] - Zrange<- varargin[[3]] - StrV<-strsplit(Xrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Xname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Px<- c(Tmp[1],0,0) - Qx<- c(Tmp[2],0,0) - StrV<-strsplit(Yrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Yname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Py<- c(0,Tmp[1],0) - Qy<- c(0,Tmp[2],0) - StrV<-strsplit(Zrange,"=",fixed=TRUE) - StrV<- StrV[[1]] - if(length(StrV)>1){ - Zname<- StrV[1] - StrV<- StrV[2] - } - Tmp<- eval(parse(text=StrV)) - Pz<- c(0,0,Tmp[1]) - Qz<- c(0,0,Tmp[2]) - }else{ - Data<- varargin[[1]] - Xname<- "x"; Yname<- "y"; Zname<- "z" - if(Nargs>1){ - if(varargin[[2]]!=""){ - Xname<- varargin[[2]] - } - if(varargin[[3]]!=""){ - Yname<- varargin[[3]] - } - if(varargin[[4]]!=""){ - Zname<- varargin[[4]] - } - } - Tmp<- Op(1,Data) - Px<- Tmp[1,]; Qx<- Tmp[2,] - Tmp<- Op(2,Data) - Py<- Tmp[1,] - Qy<- Tmp[2,] - Tmp<- Op(3,Data) - Pz<- Tmp[1,] - Qz<- Tmp[2,] - } - Ph<- Perspt(Px) - Qh<- Perspt(Qx) - R<- Norm(Ph-Qh) - Kekka<- list() - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Xname) - } - Ph<- Perspt(Py) - Qh<- Perspt(Qy) - R<- Norm(Ph-Qh) - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Yname) - } - Ph<- Perspt(Pz) - Qh<- Perspt(Qz) - R<- Norm(Ph-Qh) - if(R>Eps){ - Ch<- Qh+Dr/R*(Qh-Ph) - Kekka<- c(Kekka,list(Pointdata(Ch))) - Expr(Ch,"c",Zname) - } -# return(Kekka) -} - -######################### -#100815 -Zparapt<- function(P){#function Out=Zparapt(P) - x<- P[1]; y<- P[2]; z<- P[3] - Out<- x*cos(PHI)*sin(THETA)+y*sin(PHI)*sin(THETA)+z*cos(THETA) - return(Out) -} - -######################### -#100815 -Zperspt<- function(P){ - Tmp<- P-FocusPoint - X1<- Tmp[1]; Y1<- Tmp[2]; Z1<- Tmp[3] - Tmp<- EyePoint-FocusPoint - E1<- Tmp[1]; F1<- Tmp[2]; G1<- Tmp[3] - Ca<- E1/sqrt(E1^2+F1^2) - Sa<- F1/sqrt(E1^2+F1^2) - X2<- X1*Ca+Y1*Sa; Y2<- -X1*Sa+Y1*Ca; Z2<- Z1 - E2<- E1*Ca+F1*Sa; F2<- -E1*Sa+F1*Ca; G2<- G1 - Cb<- E2/sqrt(E2^2+G2^2) - Sb<- G2/sqrt(E2^2+G2^2) - X3<- X2*Cb+Z2*Sb - return(X3) -} - -########################################## - - - -########################################## - -# Stat Package - -########################################## - -# 2010.04.12 - -# new - -# Htickmarklower, Vtickmarkleft, HtickmarklowerV -# VtickmarkleftV, Insertcom, Replacecom -# Maketexfile, Formatting -# Drwhistframe, Histplotdata, Drwhistplot - -Htickmarklower<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - ArgsL<- varargin - if(mode(ArgsL[[1]])=="character"){ - Str<- ArgsL[[1]] - Tmp<- strsplit(Str,"m") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - I<- nchar(Tmp[1])+1 - } - else{ - I<- 0 - } - Tmp<- strsplit(Str,"n") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - J<- nchar(Tmp[1])+1 - } - else{ - J<- 0 - } - Tmp<- strsplit(Str,"r") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - K=nchar(Tmp[1])+1 - } - else{ - K<- 0 - } - if(K>0){ - S<- substr(Str,K+1,nchar(Str)) - R<- as.numeric(S) - if(is.na(R)){ - R<- 1 - } - } - else{ - R<- 1 - K<- nchar(Str)+1 - } - if(J>0){ - S<- substr(Str,J+1,K-1) - Dn<- as.numeric(S) - if(is.na(Dn)){ - Dn<- 1 - } - } - else{ - Dn<- 1000 - J<- nchar(Str)+1 - } - S<- substr(Str,I+1,J-1) - Dm<- as.numeric(S) - if(is.na(Dm)){ - Dm<- 1 - } - ArgsL<- list() - for (I in Looprange(1, floor((XMAX-GENTEN[1])/Dm))){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - for (I in seq(-1,ceiling((XMIN-GENTEN[1])/Dm),by=-1)){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - } - MemoriList<- list() - Memori<- list() - for (N in 1:length(ArgsL)){ - Dt<- ArgsL[[N]] - if(mode(Dt)=="numeric" && length(Dt)>1){ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt) - next - } - if(mode(Dt)=="character"){ - Memori<- Mixjoin(Memori,Dt) - } - else{ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt,GENTEN[2]) - } - } - MemoriList<- Mixjoin(MemoriList,list(Memori)) - for (N in 1:length(MemoriList)){ - Dt<- MemoriList[[N]] - Ndt<- length(Dt) - X=Op(1,Dt) - Y=Op(2,Dt) - Tmp<-Doscaling(c(X,Y)) - X<- Tmp[1] - Y<- Tmp[2] - Moji<- Op(Ndt,Dt) - Tmp1<- Unscaling(c(X,Y)) - Tmp2<- Unscaling(c(X,Y-2*MARKLEN)) - Fd<- Listplot(c(Tmp1,Tmp2)) - Drwline(Fd) - if(Ndt==3){ - Tmp<-Unscaling(c(X,Y-2*MARKLEN)) - Expr(Tmp,"s",Moji) - } - if(Ndt==4){ - Houkou<- Op(3,Dt) - Tmp<-grep("s",Houkou) - if(length(Tmp)>0){ - Tmp<-Unscaling(c(X,Y-2*MARKLEN)) - Expr(Tmp,Houkou,Moji) - } - else{ - Tmp<- Unscaling(c(X,Y)) - Expr(Tmp,Houkou,Moji) - } - } - cat("%\n",file=Wfile,append=TRUE) - } -} - -Vtickmarkleft<- function(...) -{ ## Scaling is implemented - varargin<- list(...) - Nargs<- length(varargin) - ArgsL<- varargin - if(mode(ArgsL[[1]])=="character"){ - Str<- ArgsL[[1]] - Tmp<- strsplit(Str,"m") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - I<- nchar(Tmp[1])+1 - } - else{ - I<- 0 - } - Tmp<- strsplit(Str,"n") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - J<- nchar(Tmp[1])+1 - } - else{ - J<- 0 - } - Tmp<- strsplit(Str,"r") - Tmp<- Tmp[[1]] - if(length(Tmp)>1){ - K=nchar(Tmp[1])+1 - } - else{ - K<- 0 - } - if(K>0){ - S<- substr(Str,K+1,nchar(Str)) - R<- as.numeric(S) - if(is.na(R)){ - R<- 1 - } - } - else{ - R<- 1 - K<- nchar(Str)+1 - } - if(J>0){ - S<- substr(Str,J+1,K-1) - Dn<- as.numeric(S) - if(is.na(Dn)){ - Dn<- 1 - } - } - else{ - Dn<- 1000 - J<- nchar(Str)+1 - } - S<- substr(Str,I+1,J-1) - Dm<- as.numeric(S) - if(is.na(Dm)){ - Dm<- 1 - } - ArgsL<- list() - for (I in 1:floor((YMAX-GENTEN[2])/Dm)){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - for (I in seq(-1,ceiling((YMIN-GENTEN[2])/Dm))){ - ArgsL<- Mixjoin(ArgsL,I*Dm) - if(I-floor(I/Dn)*Dn==0){ - Str<- as.character(I*Dm*R) - ArgsL<- Mixjoin(ArgsL,Str) - } - } - } - MemoriList<- list() - Memori<- list() - for (N in 1:length(ArgsL)){ - Dt<- ArgsL[[N]] - if(mode(Dt)=="numeric" && length(Dt)>1){ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(Dt) - next - } - if(mode(Dt)=="character"){ - Memori<- Mixjoin(Memori,Dt) - } - else{ - if(length(Memori)>0){ - MemoriList<- Mixjoin(MemoriList,list(Memori)) - } - Memori<- list(GENTEN[1],Dt) - } - } - MemoriList<- Mixjoin(MemoriList,list(Memori)) - for (N in 1:length(MemoriList)){ - Dt<- MemoriList[[N]] - Ndt<- length(Dt) - X=Op(1,Dt) - Y=Op(2,Dt) - Tmp<-Doscaling(c(X,Y)) - X<- Tmp[1] - Y<- Tmp[2] - Moji<- Op(Ndt,Dt) - Tmp1<- Unscaling(c(X,Y)) - Tmp2<- Unscaling(c(X-2*MARKLEN,Y)) - Fd<- Listplot(c(Tmp1,Tmp2)) - Drwline(Fd) - if(Ndt==3){ - Tmp<-Unscaling(c(X-2*MARKLEN,Y)) - Expr(Tmp,"w",Moji) - } - if(Ndt==4){ - Houkou<- Op(3,Dt) - Tmp<-grep("w",Houkou) - if(length(Tmp)>0){ - Tmp<-Unscaling(c(X-2*MARKLEN,Y)) - Expr(Tmp,Houkou,Moji) - } - else{ - Tmp<- Unscaling(c(X,Y)) - Expr(Tmp,Houkou,Moji) - } - } - cat("%\n",file=Wfile,append=TRUE) - } -} - -HtickmarklowerV<- function(Vec,digits=2,nsmall=2) -{ - for (I in 1:length(Vec)){ - Tmp<- Vec[I] - Htickmarklower(Tmp, Formatting(Tmp,digits,nsmall)) - } -} - -HtickLV<- function(...) -{ - HtickmarklowerV(...) -} - -VtickmarkleftV<- function(Vec,digits=2,nsmall=2) -{ - for (I in 1:length(Vec)){ - Tmp<- Vec[I] - Vtickmarkleft(Tmp, Formatting(Tmp,digits,nsmall)) - } -} - -VtickLV<- function(...) -{ - VtickmarkleftV(...) -} - -Insertcom<- function(CmdM,Npos,Str) -{ - if(is.matrix(CmdM)){ - Cmd<- CmdM - } - else{ - C<- paste("Cmd<- ",CmdM) - eval(parse(text=C)) - } - Out<- Cmd[Looprange(1,Npos-1),] - Out<- c(Out,Str) - Tmp<- Cmd[Looprange(Npos,nrow(Cmd)),] - Out<- c(Out,Tmp) - Out<- matrix(Out) - if(!is.matrix(CmdM)){ - C<- paste(CmdM,"<<- Out") - eval(parse(text=C)) - } - return(Out) -} - -Replacecom<- function(CmdM,Npos,Str) -{ - if(is.matrix(CmdM)){ - Cmd<- CmdM - } - else{ - C<- paste("Cmd<- ",CmdM) - eval(parse(text=C)) - } - Out<- Cmd[Looprange(1,Npos-1),] - Out<- c(Out,Str) - Tmp<- Cmd[Looprange(Npos+1,nrow(Cmd)),] - Out<- c(Out,Tmp) - Out<- matrix(Out) - if(!is.matrix(CmdM)){ - C<- paste(CmdM,"<<- Out") - eval(parse(text=C)) - } - return(Out) -} - -Deletecom<- function(CmdM,Npos) -{ - if(is.matrix(CmdM)){ - Cmd<- CmdM - } - else{ - C<- paste("Cmd<- ",CmdM) - eval(parse(text=C)) - } - Out<- Cmd[Looprange(1,Npos-1),] - Tmp<- Cmd[Looprange(Npos+1,nrow(Cmd)),] - Out<- c(Out,Tmp) - Out<- matrix(Out) - if(!is.matrix(CmdM)){ - C<- paste(CmdM,"<<- Out") - eval(parse(text=C)) - } - return(Out) -} - -Maketexfile<- function(commands="",texfile="") -{ - Openfile(texfile) - Execmd(commands) - Closefile() -} - -Formatting<- function(X,D=2,N=2) -{ - if(D>0){ - Xs <- format(X,digits=D,nsmall=N) - } - else{ - Xs<- as.character(X) - } - return(Xs) -} - -################################ - -Boxplotdata1 <-function(DataF1,CenterX,Width,...) -{ - Xr <- Width - Temp <- boxplot(DataF1[1],plot=FALSE) - Stats <- Temp$stats - rownames(Stats) <- c("Lhige","Q1","Q2","Q3","Uhige") - Out <- Temp$out - Lhige <- Stats["Lhige",1] - Uhige <- Stats["Uhige",1] - Q1 <- Stats["Q1",1] - Q2 <- Stats["Q2",1] - Q3 <- Stats["Q3",1] - CenterY <- (Q1+Q3)/2 - C <- c(CenterX,CenterY) - V <- c(0,(Q3-Q1)/2) - G1 <- Framedata(C,Xr/2,V[2]) # box - Temp1 <- c(0,Q1-Lhige) - Temp2 <- c(0,Uhige-Q3) - G2 <- Listplot(C-V,C-V-Temp1) # - G3 <- Listplot(C+V,C+V+Temp2) # - Temp3 <- c(Xr/4,0) - G4 <- Listplot(C-V-Temp1-Temp3,C-V-Temp1+Temp3) # - G5 <- Listplot(C+V+Temp2-Temp3,C+V+Temp2+Temp3) # - Temp4 <- c(0,Q3-Q2) - Temp5 <- c(Xr/2,0) - G6 <- Listplot(C+V-Temp4-Temp5,C+V-Temp4+Temp5) # - G7 <- list() - for(j in Looprange(1,length(Out))){ - G7 <- c(G7,list(c(CenterX, Out[j]))) - } - G7 <- G7[order(Out,decreasing=TRUE)] - list(median=G6,box=G1,uwhisker=G2,lwhisker=G3,lwp=G4,uwp=G5,outliers=G7) -} - -Boxplotdata2 <- function(Data,Ratio, ...) -{ - DataF<- Flattenlist(Data) # 11.07.21(from) - ymin<- Inf - ymax<- -Inf - for(J in 1:length(DataF)){ - Tmp<- DataF[[J]] - ymin<- min(ymin, min(Tmp)) - ymax<- max(ymax,max(Tmp)) - } # 11.07.21(until) - dy <- ymax-ymin - Setwindow(c(0,XMAX-XMIN),c(ymin-0.1*dy,ymax+0.1*dy)) - R1<- (YMAX-YMIN)/(XMAX-XMIN) - R<- Ratio/R1 - Setscaling(R) - Delta <- XMAX/length(DataF) - W <- 0.6*Delta - PdL <- list() - for(i in 1:length(DataF)){ # 11.07.21 - X <- (0.5+i-1)*Delta - G <- Boxplotdata1(DataF[i],X,W,...) - PdL <- c(PdL,list(G)) - } - G <- Framedata() - Tmp<- list(frame=G) - PdL <-c(PdL,list(Tmp)) - Epsi <-0 - Setwindow(c(XMIN-Epsi,XMAX+Epsi),c(YMIN-Epsi,YMAX+Epsi)) - return(PdL) -} - -Drwboxframe<-function(BoxDataL) -{ - Setorigin(c(XMIN,YMIN)) - Tmp<- Unscaling(c(0.2,0.2)) - Setwindow(c(XMIN-0.2,XMAX),c(YMIN-Tmp[2],YMAX)) - Hako<- BoxDataL$plotdata - title<- BoxDataL$title - cap<- BoxDataL$cap - ylab<- BoxDataL$ylab - if(mode(title)!="list") title<- list(title) - if(mode(cap)!="list") cap<- list(cap) - if(mode(ylab)!="list") ylab<- list(ylab) - if(length(title)==0) title<- list("") - if(length(title)==1) title<- c(title, list("n")) - if(length(title)==2) title<- c(title, list("")) - if(length(cap)==0) cap<- list("") - if(length(cap)==1) cap<- c(cap, list("n"),0) # 11.11.27 - if(length(cap)==2) cap<- c(cap, 0) # 11.11.27 - if(length(ylab)==0) ylab<- list("") - if(length(ylab)==1) ylab <- c(ylab, list("n")) - if(length(ylab)==2) ylab<- c(ylab, list("")) - Temp <- Hako[[length(Hako)]] - Drwline(Temp$frame) - Fontsize(cap[[2]]) - for(i in Looprange(1,length(Hako)-1)){ - Temp <- Hako[[i]] - attach(Temp) - Dashline(uwhisker,lwhisker) - Drwline(median,2) - Drwline(box,lwp,uwp) - Drwpt(outliers,0) - X <- uwhisker[1,1] - detach(Temp) - Htickmarklower(X) - if(nchar(cap[[1]])<1) next # 2011.03.08 - if(length(cap)==2 || cap[[3]]==0){ - pos<- 1 - if(length(cap)>=4) pos<- cap[[4]] - Tmp<- paste("s",as.character(pos),sep="") - Letter(c(X,YMIN),Tmp, Op(i,cap[[1]])) - } - else{ - rotate<- cap[[3]] - if(length(cap)==3){ - pos<- 0 - } - else{ - pos<- cap[[4]] - } - Temp1 <- rotate*pi/180 - Temp <- c(cos(Temp1),sin(Temp1)) - Letterrot(c(X,YMIN-pos),Temp,Op(i,cap[[1]])) - } - } - if(nchar(ylab[[1]])>0){ - Fontsize(ylab[[2]]) - Tmp1<- ylab[[1]] - Tmp3<- ylab[[3]] - if(nchar(Tmp3)>0){ - Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") - } - Letter(c(XMIN, YMAX),"n2",Tmp1) - Fontsize("n") - } - if(nchar(title[[1]])>0){ - Fontsize(title[[2]]) - Tmp1<- title[[1]] - Tmp3<- title[[3]] - if(nchar(Tmp3)>0){ - Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") - } - Letter(c((XMIN+XMAX)/2,YMAX),"n2",Tmp1) - } - Fontsize("n") -} - -Drwboxplot<- function(dataf,var,size, - title=list(""), cap=list(colnames(dataf)), - ylab=list(""), ptsize=5,plot=TRUE,...) - #Return : title,cap,ylab,commands,plotdata,info -{ - Tmp <- boxplot(dataf, plot=FALSE, ...) - Stats <- Tmp$stats - DataF<- Flattenlist(dataf) # 11.07.21(from) - ymin<- Inf - ymax<- -Inf - for(J in 1:length(DataF)){ - Tmp<- DataF[[J]] - ymin<- min(ymin, min(Tmp)) - ymax<- max(ymax,max(Tmp)) - } # 11.07.21(until) - Hako<- Boxplotdata2(dataf, size[2]/size[1], ...) - if(plot){ - Windisp(Hako) - } - Tmp<- Formatting(size[1]/(XMAX-XMIN),5,5) - unit<- paste(Tmp,"cm",sep="") - Setunitlen(unit) - Exstr<- c( - "","", - paste("Beginpicture(","'",unit,"')",sep=""), - paste("Setpt(",as.character(ptsize),")",sep=""), - "","", - paste("Drwboxframe(",var,")",sep=""), - paste("VtickLV(c(",as.character(ymin),",", as.character(ymax),"),0,0)",sep=""), - "","","","", - "Setpt(1)", - "Endpicture(0)" - ) - Exstr<- matrix(Exstr) - Xpos<- c() - for(i in Looprange(1,length(Hako)-1)){ - Temp <- Hako[[i]] - Temp1 <- Temp[[5]] - Xpos <- c(Xpos,Temp1[1,1]) - } - Info<- list(stats=Stats,window=matrix(c(XMIN,XMAX,YMIN,YMAX),nrow=2),xpos=Xpos) - Tmp<- paste(var,"<<- ", - "list(title=title,cap=cap,ylab=ylab,", - "commands=Exstr,plotdata=Hako,info=Info)",sep="") - eval(parse(text=Tmp)) -} - - -########################################### - -Histplotdata <- function(DataV,Ratio,freq=TRUE,densplot=FALSE,...) -# 10.12.07 freq -{ - Temp <- hist(DataV,plot=FALSE,...) - Breaks <- Temp$breaks - Counts <- Temp$counts - Density <- Temp$density - Mids <- Temp$mids - if(!freq){ - Data<- Density - } - else{ - Data<- Counts - } - Ghist <- list() - for(i in Looprange(1,length(Breaks)-1)){ - Tmp1 <- c(Breaks[i],Breaks[i+1]) - Tmp2 <- c(0,Data[i]) - G1 <- Framedata(Tmp1,Tmp2) #bar - Ghist <- c(Ghist,list(G1)) - } - Bin <- Breaks[2]-Breaks[1] - Eps <- 0.7*Bin # 0.7 times Bin - Temp1 <- c(min(Breaks)-Eps,max(Breaks)+Eps) # Put Eps at both sides - Temp2 <- c(0,max(Data)*1.02) - Setwindow(Temp1,Temp2) - Setorigin(c(Temp1[1],0)) - R1<- (YMAX-YMIN)/(XMAX-XMIN) - R<- Ratio/R1 - Setscaling(R) - VEps <- 0.05*(XMAX-XMIN)/5 - Temp1<- Temp1-c(VEps,0) - Temp2<- Temp2-1/R*c(VEps,0) - Setwindow(Temp1,Temp2) - Fpt <- c(Mids[1]-Bin,0) - Lpt <- c(Mids[length(Mids)]+Bin,0) - Fp <- matrix(Fpt,nrow=1) - for(i in Looprange(1,length(Mids))){ - Tmp <- c(Mids[i],Data[i]) - Fp <- rbind(Fp,Tmp) - } - Fp <- rbind(Fp,Lpt) - rownames(Fp)<- c(1:nrow(Fp)) - if(densplot){ - Temp <- density(DataV) - X <- matrix(Temp$x) - Y <- matrix(Temp$y) - Gdens <- cbind(X,Y) - } - else{ - Gdens <- list() - } - list(plotdata=list(histplot=Ghist,fpplot=list(Fp),densityplot=list(Gdens)), - breaks=Breaks,counts=Counts,density=Density,mids=Mids) -} - -Drwhistframe<-function(HistDataL) -{ - title<- HistDataL$title - xlab<- HistDataL$xlab - ylab<- HistDataL$ylab - if(mode(title)!="list") title<- list(title) - if(mode(xlab)!="list") cap<- list(xlab) - if(mode(ylab)!="list") cap<- list(ylab) - if(length(title)==0) title<- list("") - if(length(title)==1) title<- c(title, list("n")) - if(length(title)==2) title<- c(title, list("")) - if(length(xlab)==0) xlab<- list("") - if(length(xlab)==1) xlab<- c(xlab, list("n")) - if(length(xlab)==2) xlab<- c(xlab, list("")) - if(length(xlab)==3) xlab<- c(xlab, list(8)) - if(length(ylab)==0) ylab<- list("") - if(length(ylab)==1) ylab<- c(ylab, list("n")) - if(length(ylab)==2) ylab<- c(ylab, list("")) - if(nchar(title[[1]])>0){ - Fontsize(title[[2]]) - Tmp1<- title[[1]] - Tmp3<- title[[3]] - if(nchar(Tmp3)>0){ - Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") - } - Letter(c((XMIN+XMAX)/2,YMAX),"n2",Tmp1) - Fontsize("n") - } - if(nchar(xlab[[1]])>0){ - Fontsize(xlab[[2]]) - Tmp1<- xlab[[1]] - Tmp3<- xlab[[3]] - if(nchar(Tmp3)>0){ - Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") - } - Tmp4<- paste("s",as.character(xlab[[4]]),sep="") - Letter(c((XMIN+XMAX)/2,YMIN),Tmp4,Tmp1) - Fontsize("n") - } - if(nchar(ylab[[1]])>0){ - Fontsize(ylab[[2]]) - Tmp1<- ylab[[1]] - Tmp3<- ylab[[3]] - if(nchar(Tmp3)>0){ - Tmp1<- paste("{\\",Tmp3," ",Tmp1,"}",sep="") - } - Tmp<- Setorigin() - Letter(c(Tmp[1], YMAX),"n2",Tmp1) - Fontsize("n") - } - - Setax(2," ") - Setax(4," ") - Setax(6," ") -} - -Drwhistplot<- function(datav,var,size,freq=TRUE, - title=list(""), xlab=list(""), ylab=list(""), - plot=TRUE,densplot=FALSE,fpplot=TRUE,...) - #Output : title,xlab,ylab,commands,plotdata,info -{ - H <- Histplotdata(datav, size[2]/size[1], freq=freq,densplot=densplot,...) - Pd<- H$plotdata - Ghist <- list(histplot=Pd$histplot,densityplot=Pd$densityplot) # 10.12.07 - if(fpplot){ - Ghist<- c(Ghist,list(fpplot=Pd$fpplot)) - } - if(plot){ - Windisp(Ghist) - } - Tmp<- Formatting(size[1]/(XMAX-XMIN),5,5) - unit<- paste(Tmp,"cm",sep="") - Setunitlen(unit) - Infostr<- paste(var,"$info",sep="") - Brkstr<- paste(Infostr,"$breaks",sep="") - Midstr<- paste(Infostr,"$mids",sep="") - if(!freq){ - Digits<- ",2,2" - Denstr<- paste(Infostr,"$density",sep="") - } - else{ - Digits<- ",0,0" - Denstr<- paste(Infostr,"$counts",sep="") - } - - if(fpplot) Prefp<- "" else Prefp<- "#" - Exstr<- c( - "","", - paste("Beginpicture(","'",unit,"')",sep=""), - "","", - paste("Drwhistframe(",var,")",sep=""), - paste("HtickLV(",Midstr,",1,1)",sep=""), - paste("VtickLV(max(",Denstr,")",Digits,")",sep=""), - paste("Drwline(",var,"[['plotdata']]","$histplot)",sep=""), - paste(Prefp,"Dashline(",var,"[['plotdata']]","$fpplot)",sep=""), - paste("#Drwline(",var,"[['plotdata']]","$densityplot,2)",sep=""), - "","","","", - "Endpicture(1)" - ) - Exstr<- matrix(Exstr) - Info<- list(breaks=H$breaks,counts=H$counts,density=H$density,mids=H$mids, - window=matrix(c(XMIN,XMAX,YMIN,YMAX),nrow=2)) - Tmp<- paste(var,"<<- ", - "list(title=title,xlab=xlab,ylab=ylab,", - "commands=Exstr,plotdata=Ghist,info=Info)",sep="") - eval(parse(text=Tmp)) -} - -########################## -#17.09.30 - -Bezierpt<- function(t,Ptlist,Ctrlist){ - if(length(Ptlist)==6){ - P0=Ptlist[1:3] - P3=Ptlist[4:6] - P1=Ctrlist[1:3] - if(length(Ctrlist)==3){ - P2=P3 - flg3=0 - }else{ - P2=Ctrlist[4:6] - flg3=1 - } - }else{ - P0=Ptlist[1:2] - P3=Ptlist[3:4] - P1=Ctrlist[1:2] - if(length(Ctrlist)==2){ - P2=P3 - flg3=0 - }else{ - P2=Ctrlist[3:4] - flg3=1 - } - } - P4=(1-t)*P0+t*P1 - P5=(1-t)*P1+t*P2 - P6=(1-t)*P2+t*P3 - P7=(1-t)*P4+t*P5 - P8=(1-t)*P5+t*P6 - P9=(1-t)*P7+t*P8 - if(flg3==0){ - Out=P7 - }else{ - Out=P9 - } - return(Out) -} - -Bezier<- function(...){ - varargin<- list(...) - Nargs=length(varargin) - Ptlist=varargin[[1]] - Ctrlist=varargin[[2]] - Num=10 - for(J in Looprange(3,Nargs)){ - Tmp=varargin[[J]] - K=strsplit(Tmp,'=',fixe=TRUE) - K=K[[1]] - Tmp1=substring(K[1],1,1) - Lhs=toupper(Tmp1) - if(Lhs=="N"){ - Num=eval(parse(text=K[2])) - } - } - if(length(Num)==1){ - Num=rep(Num,length(Ctrlist)) #17.10.08 - } - Out=c() - for(ii in Looprange(1,length(Ctrlist))){ - Tmp1=c(Ptlist[[ii]],Ptlist[[ii+1]]) - Tmp2=Ctrlist[[ii]] - if(ii==1){ - St=0 - }else{ - St=1 - } - for(J in Looprange(St,Num[ii])){ - Tmp=Bezierpt(J/Num[ii],Tmp1,Tmp2) - Out=Appendrow(Out,Tmp) - } - } - return(Out) -} - -####################### -# 17.10.02 - -Connectseg<- function(...){ - varargin=list(...) - Nargs=length(varargin) - Pdata=varargin[[1]] - Eps=10^(-4) - if(Nargs>=2){ - Eps=varargin[[2]] - } - if(is.matrix(Pdata)){ - Din=Dataindex(Pdata) - tmp1=list() - for(J in 1:nrow(Din)){ - tmp=Pdata[Din[J,1]:Din[J,2],] - tmp1=c(tmp1,list(tmp)) - } - Pdata=tmp1 - } - PlotL=list(Op(1,Pdata)) - VI=Looprange(2,length(Pdata)) - while(length(VI)>0){ - Qd=Op(Length(PlotL),PlotL) - Ah=Op(1,Qd); Ao=Op(Length(Qd),Qd) - Flg=0 - for(J in 1:length(VI)){ - Tmp1=Op(VI[J],Pdata) - P=Op(1,Tmp1); Q=Op(Length(Tmp1),Tmp1) - if(Norm(P-Ao)0){ - Qd=Appendrow(Qd,Tmp) - } - PlotL[[length(PlotL)]]=Qd - VI=VI[-J] - Flg=1 - break - } - if(Norm(Q-Ao)Eps){ - if(vL[kk+1]< -Eps){ - tmp=1/(vL[kk]-vL[kk+1])* - (-vL[kk+1]*pL[[kk]]+vL[kk]*pL[[kk+1]]) - qL=Appendrow(qL,tmp) - } - }else{ - if(vL[kk+1]>Eps){ - tmp=1/(-vL[kk]+vL[kk+1])* - (vL[kk+1]*pL[[kk]]-vL[kk]*pL[[kk+1]]) - qL=Appendrow(qL,tmp) - } - } - } - } - xval1=xval2 - eval11=eval21 - eval12=eval22 - if(Length(qL)==2){ - out=c(out,list(qL)) - } - } - } - if(length(out)>0){ - out=Connectseg(out) - } - if(length(out)==1){ - out=out[[1]] - } - return(out) -} - -######################### -# 17.10.06 - -Deqdata=function(deq,rng,initt,initf,Num){ - Eps=10^(-3) - inf=10^3 - tmp=strsplit(deq,"=")[[1]] - tmp1=gsub("`","",tmp[1],fixed=TRUE) - tmp1=substring(tmp1,3,nchar(tmp1)-1) - Xname=strsplit(tmp1,",")[[1]] - func=tmp[2] - for(J in 1:(length(Xname))){ - tmp1=paste("X[",as.character(J),"]",sep="") - func=gsub(Xname[J],tmp1,func,fixed=TRUE) - } - tmp=strsplit(rng,"=")[[1]] - tname=tmp[1] - tmp=eval(parse(text=tmp[2])) - t1=tmp[1] - t2=tmp[2] - tmp=paste("function(",tname,",X){",func,"}",sep="") - funP=eval(parse(text=tmp)) - tmp=paste("function(",tname,",X){-",func,"}",sep="") - funN=eval(parse(text=tmp)) - dt=(t2-t1)/Num - tt=initt - X0=initf - pdL=c(tt,X0) - for(J in Looprange(1,floor((t2-initt)/dt))){ - kl1=dt*funP(tt,X0) - kl2=dt*funP(tt+dt/2,X0+kl1/2) - kl3=dt*funP(tt+dt/2,X0+kl2/2) - kl4=dt*funP(tt+dt,X0+kl3) - X0=X0+(kl1+2*kl2+2*kl3+kl4)/6 - tt=initt+J*dt - tmp=c(tt,X0) - if(Norm(tmp)>inf){break} - pdL=Appendrow(pdL,tmp) - } - tt=initt - X0=initf - for(J in Looprange(1,floor((initt-t1)/dt))){ - kl1=dt*funN(tt,X0) - kl2=dt*funN(tt+dt/2,X0+kl1/2) - kl3=dt*funN(tt+dt/2,X0+kl2/2) - kl4=dt*funN(tt+dt,X0+kl3) - X0=X0+(kl1+2*kl2+2*kl3+kl4)/6 - tt=initt-J*dt - tmp=c(tt,X0) - if(Norm(tmp)>inf){break} - pdL=Appendrow(tmp,pdL) - } - pdL -} - -Deqplot=function(...){ - varargin=list(...) - deq=varargin[[1]] - rng=varargin[[2]] - initt=varargin[[3]] - initf=varargin[[4]] - Num=50 - Sel=c(1,2) - for(J in Looprange(5,length(varargin))){ - tmp1=varargin[[J]] - if(is.character(tmp1)){ - tmp=strsplit(tmp1,"=")[[1]] - Num=eval(parse(text=tmp[2])) - }else{ - SeL=tmp1 - } - } - pdL=Deqdata(deq,rng,initt,initf,Num) - pdL=pdL[,SeL] -} - - -############## obj ############### - -Openobj<- function(Fnm){ - OBJFMT<<- "%7.4f" - NPOINT<<- 0 - NNORM<<- 0 - OBJSCALE<<- 1 - OBJFIGNO<<- 0 - OBJJOIN<<- 0 - Wfile<<- Fnm - Tmp=grep(".obj",Fnm,fixed=TRUE) - if(length(Tmp)==0){ - if(nchar(Fnm)>0){ - Wfile<<- paste(Fnm,".obj",sep="") - } - } - cat("",file=Wfile,sep="") - Wfile -} - -Closeobj<- function(){ - Wfile="" -} - -Writeobjpoint<- function(P){ - X=sprintf(OBJFMT,P[1]*OBJSCALE) - Y=sprintf(OBJFMT,P[2]*OBJSCALE) - Z=sprintf(OBJFMT,P[3]*OBJSCALE) - Str=paste("v",X,Y,Z,sep=" ") - Printobjstr(Str) - NPOINT<<- NPOINT+1 - return(NPOINT) -} - -Printobjstr<- function(Str){ - cat(Str,"\n",sep="",file=Wfile,append=TRUE) -} - -Objname<- function(){ - if(OBJJOIN==0){ - OBJFIGNO<<- OBJFIGNO+1 - Gname=paste("ketfig",as.character(OBJFIGNO),sep="") - Printobjstr(paste("# ",Gname,sep="")) - Printobjstr(paste("g ",Gname,sep="")) - } -} - -Objjoin<- function(...){ - varargin=list() - if(length(varargin)>0){ - OBJJOIN<<- abs(sign(varargin[[1]])) - } - OBJJOIN -} - -Objsurf<- function(...){ #17.12.18 - Args<- list(...) - Nargs<- length(Args) - Sel=Args[[Nargs]]; Nargs=Nargs-1 - Rf=Args[[1]] - N=2 - Mg=0; Ng=0 - if(is.numeric(Args[[N]])){ - if(length(Args[[N]])>2){ - U=Args[[N]] - Mg=length(U)-1 - N=N+1 - }else if(length(Args[[N]])==2){ - Intab=Args[[N]] - Ag=Intab[1]; Bg=Intab[2] - N=N+1 - }else{ - Ag=Args[N]; Bg=Args[N+1] - N=N+2 - } - }else{ - Tmp0=Args[[N]] - Tmp=grep("=",Tmp0,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1=strsplit(Tmp0,"=") - Tmp0=Tmp1[[1]][2] - } - Intab=eval(parse(text=Tmp0)) - Ag=Intab[1]; Bg=Intab[2] - N=N+1 - } - if(is.numeric(Args[[N]])){ - if(length(Args[[N]])>2){ - V=Args[[N]] - Ng=length(V)-1 - N=N+1 - }else if(length(Args[[N]])==2){ - Intab=Args[[N]] - Cg=Intab[1]; Dg=Intab[2] - N=N+1 - }else{ - Cg=Args[[N]]; Dg=Args[[N+1]] - N=N+2 - } - }else{ # the case of is.character(Args[[N]]) - Tmp0=Args[[N]] - Tmp=grep("=",Tmp0,fixed=TRUE) - if(length(Tmp)>0){ - Tmp2=strsplit(Tmp0,"=") - Tmp0=Tmp2[[1]][2] - } - Intab=eval(parse(text=Tmp0)) - Cg=Intab[1]; Dg=Intab[2] - N=N+1 - } - if(Mg==0){ - Mg=Args[[N]] - N=N+1 - U=c() - for(J in Looprange(1,Mg+1)){ - U=c(U,Ag+(J-1)/Mg*(Bg-Ag)) - } - } - if(Ng==0){ - Ng=Args[[N]] - V=c() - for(K in Looprange(1,Ng+1)){ - V=c(V,Cg+(K-1)/Ng*(Dg-Cg)) - } - } - Objname() - PL=list() - for(J in Looprange(1,Mg+1)){ - for(K in Looprange(1,Ng+1)){ - P=Rf(U[J],V[K]) - Np=Writeobjpoint(P) - PL=c(PL,list(c(P,Np))) - } - } - Idx=1+(Ng+1)*(0:Mg) - Pus=PL[Idx] - Idx=(Ng+1)*(1:(Mg+1)) - Pue=PL[Idx] - Idx=1:(Ng+1) - Pvs=PL[Idx] - Idx=((Ng+1)*Mg+1):((Ng+1)*(Mg+1)) - Pve=PL[Idx] - Printobjstr("vt 0 0") - Printobjstr("vt 1 0") - Printobjstr("vt 1 1") - Printobjstr("vt 0 1") - for(J in Looprange(1,Mg)){ - for(K in Looprange(1,Ng)){ - P1=sprintf("%1d",Op(4,PL[[(Ng+1)*(J-1)+K]])) - P2=sprintf("%1d",Op(4,PL[[(Ng+1)*J+K]])) - P3=sprintf("%1d",Op(4,PL[[(Ng+1)*J+K+1]])) - P4=sprintf("%1d",Op(4,PL[[(Ng+1)*(J-1)+K+1]])) - N1=""; N2=""; N3=""; N4="" - if(Sel=="+"){ - Str=paste("f ",P1,"/1/",N1," ",P2,"/2/",N2," ",sep="") - Str=paste(Str,P3,"/3/",N3," ",P4,"/4/",N4,sep="") - }else{ - Str=paste("f ",P1,"/1/",N1," ",P4,"/4/",N4," ",sep="") - Str=paste(Str,P3,"/3/",N3," ",P2,"/2/",N2,sep="") - } - Printobjstr(Str) - } - } - list(U,V,Pus,Pue,Pvs,Pve) -} - -Objthicksurf<- function(...){ - Args=list(...) - Nargs=length(Args) - Sel=Args[[Nargs]]; Nargs=Nargs-1 - Selsurf=substring(Sel,1,1) - Selside=c("0","0","0","0") - Tmp=grep("w",Sel,fixed=TRUE) - if(length(Tmp)>0){ - Selside[1]="w" - } - Tmp=grep("e",Sel,fixed=TRUE) - if(length(Tmp)>0){ - Selside[2]="e" - } - Tmp=grep("s",Sel,fixed=TRUE) - if(length(Tmp)>0){ - Selside[3]="s" - } - Tmp=grep("n",Sel,fixed=TRUE) - if(length(Tmp)>0){ - Selside[4]="n" - } - Nfth=Args[[Nargs-2]] - Thick1=Args[[Nargs-1]] - Thick2=Args[[Nargs]] - Nargs=Nargs-3 - Rfth=Args[[1]] - N=2 - Mg=0; Ng=0 - if(is.numeric(Args[[N]])){ - if(length(Args[[N]])>2){ - U=Args[[N]] - Mg=length(U)-1 - N=N+1 - }else if(length(Args[[N]])==2){ - Intab=Args[[N]] - Ag=Intab[1]; Bg=Intab[2] - N=N+1 - }else{ - Ag=Args[[N]]; Bg=Args[[N+1]] - N=N+2 - } - }else{ - Tmp0=Args[[N]] - Tmp=strsplit(Tmp0,"=",fixe=TRUE) - if(length(Tmp)>0){ - Tmp0=Tmp[[1]][2] - } - Intab=eval(parse(text=Tmp0)) - Ag=Intab[1]; Bg=Intab[2] - N=N+1 - } - if(is.numeric(Args[[N]])){ - if(length(Args[[N]])>2){ - V=Args[[N]] - Ng=length(V)-1 - N=N+1 - }else if(length(Args[[N]])==2){ - Intab=Args[[N]] - Cg=Intab[1]; Dg=Intab[2] - N=N+1 - }else{ - Cg=Args[[N]]; Dg=Args[[N+1]] - N=N+2 - } - }else{ - Tmp0=Args[[N]] - Tmp=strsplit(Tmp0,"=",fixed=TRUE) - if(length(Tmp)>0){ - Tmp0=Tmp[[1]][2] - } - Intab=eval(parse(text=Tmp0)) - Cg=Intab[1]; Dg=Intab[2] - N=N+1 - } - if(Mg==0){ - Mg=Args[[N]] - N=N+1 - U=c() - for(J in Looprange(1,Mg+1)){ - U=c(U,Ag+(J-1)/Mg*(Bg-Ag)) - } - } - if(Ng==0){ - Ng=Args[[N]] - V=c() - for(K in Looprange(1,Ng+1)){ - V=c(V,Cg+(K-1)/Ng*(Dg-Cg)) - } - } - Objname() - Join=OBJJOIN - OBJJOIN<<- 1 - F1=function(u,v){ - Rfth(u,v)+Thick1*Nfth(u,v) - } - F2=function(u,v){ - Rfth(u,v)+Thick2*Nfth(u,v) - } - Dt1=Objsurf(F1,U,V,Selsurf) - if(Selsurf=="+"){ - Tmp="-" - }else{ - Tmp="+" - } - Dt2=Objsurf(F2,U,V,Tmp); - Out=list(Dt1,Dt2); - - if(Selside[1]!="0"){ - Dt=Objrecs(Op(3,Dt1),Op(3,Dt2),Selside[1]) - Out=c(Out,list(Dt)) - } - if(Selside[2]!="0"){ - Dt=Objrecs(Op(4,Dt1),Op(4,Dt2),Selside[2]) - Out=c(Out,list(Dt)) - } - if(Selside[3]!="0"){ - Dt=Objrecs(Op(5,Dt1),Op(5,Dt2),Selside[3]) - Out=c(Out,list(Dt)) - } - if(Selside[4]!="0"){ - Dt=Objrecs(Op(6,Dt1),Op(6,Dt2),Selside[4]) - Out=c(Out,list(Dt)) - } - OBJJOIN<<- Join -} - -Objrecs<- function(...){ - Eps=10^(-6) - Args=list(...) - Nargs=length(Args) - Tmp=Args[[1]] - PtL=Flattenlist(Tmp) - for(J in Looprange(1,length(PtL))){ #17.12.23from - Tmp=PtL[[J]] - if(!is.matrix(Tmp)){ - PtL[[J]]=matrix(Tmp,nrow=1) - } - } #17.12.23until - PL1=list() - for(J in Looprange(1,length(PtL))){ - Tmp=PtL[[J]] - for(K in Looprange(1,nrow(Tmp))){ - PL1=c(PL1,list(Tmp[K,])) - } - } - Sel=Args[[Nargs]]; Nargs=Nargs-1 - Objname() - for(J in Looprange(1,length(PL1))){ - P=PL1[[J]] - if((length(P)<4) || (P[4]==0)){ - Np=Writeobjpoint(P) - PL1[[J]]=c(P[1:3],Np) - } - } - Tmp=Args[[2]] - if((is.numeric(Tmp)) && (length(Tmp)==1)){ - Drv=Tmp - Len=Norm(Drv) - PL2=list() - for(J in Looprange(1,length(PL1))){ - Tmp=PL1[[J]] - P=Tmp[1:3]+Drv - Np=Writeobjpoint(P) - PL2=c(PL2,list(c(P[1:3],Np))) - if(JEps){ - Tmp1=Crossprod(Drv,Vec) - Tmp2=Crossprod(Tmp1,Vec) - Tmp3=Dotprod(Tmp2,Drv) - if(Tmp3<-Eps){ - Tmp2=-Tmp2 - } - Drv=Len/Norm(Tmp2)*Tmp2 - } - } - } - }else{ - PtL=Flattenlist(Tmp) - for(J in Looprange(1,length(PtL))){ #17.12.23from - Tmp=PtL[[J]] - if(!is.matrix(Tmp)){ - PtL[[J]]=matrix(Tmp,nrow=1) - } - } #17.12.23until - PL2=list() - for(J in Looprange(1,length(PtL))){ - Tmp=PtL[[J]] - for(K in Looprange(1,nrow(Tmp))){ - PL2=c(PL2,list(Tmp[K,])) - } - } - for(J in Looprange(1,length(PL2))){ - P=PL2[[J]] - if((length(P)<4) || (P[4]==0)){ - Np=Writeobjpoint(P) - PL2[[J]]=c(P[1:3],Np) - } - } - } - Printobjstr("vt 0 0") - Printobjstr("vt 1 0") - Printobjstr("vt 1 1") - Printobjstr("vt 0 1") - for(J in Looprange(2,length(PL1))){ - P1=sprintf("%1d",Op(4,PL1[[J-1]])) - P2=sprintf("%1d",Op(4,PL2[[J-1]])) - P3=sprintf("%1d",Op(4,PL2[[J]])) - P4=sprintf("%1d",Op(4,PL1[[J]])) - N1=""; N2=""; N3=""; N4="" - if(Sel=="+"){ - Str=paste("f ",P1,"/1/",N1," ",P2,"/2/",N2," ",sep="") - Str=paste(Str,P3,"/3/",N3," ",P4,"/4/",N4,sep="") - }else{ - Str=paste("f ",P1,"/1/",N1," ",P4,"/4/",N4," ",sep="") - Str=paste(Str,P3,"/3/",N3," ",P2,"/2/",N2,sep="") - } - Printobjstr(Str) - } - list(PL1,PL2) -} - -Objpolygon<- function(...){ - Eps=10^(-6) - Args=list(...) - Nargs=length(Args) - Tmp=Args[[1]] - PtL=Flattenlist(Tmp) - for(J in Looprange(1,length(PtL))){ #17.12.23from - Tmp=PtL[[J]] - if(!is.matrix(Tmp)){ - PtL[[J]]=matrix(Tmp,nrow=1) - } - } #17.12.23until - PL=list() - for(J in Looprange(1,length(PtL))){ - Tmp=PtL[[J]] - for(K in Looprange(1,nrow(Tmp))){ - PL=c(PL,list(Tmp[K,])) - } - } - Sel=Args[[Nargs]]; Nargs=Nargs-1 - Objname() - for(J in Looprange(1,length(PL))){ - P=PL[[J]] - if((length(P)<4) || (P(4)==0)){ - Np=Writeobjpoint(P) - PL[[J]]=c(P[1:3],Np) - } - } - if(Nargs==1){ - Tmp=PL[[1]] - Cen=Tmp[1:3] - Nc=Tmp[4] - }else{ - Tmp=Args[[2]] - if(length(Tmp)==1){ - Tmp1=PL[[Tmp]] - Cen=Tmp1[1:3] - Nc=Tmp[4] - }else{ - Cen=Tmp - Nc=Writeobjpoint(Cen) - } - } - for(J in Looprange(1,length(PL))){ - if(J=2){ - Sz=Args[[2]] - } - if(Nargs>=3){ - Np=Args[[3]] - } - Assign("Sz",Sz) - if(Pstr=="xy"){ - Vz=c(0,0,1) - Fs=Assign("c(Sz*cos(t),Sz*sin(t),0)") - } - if(Pstr=="yz"){ - Vz=c(1,0,0) - Fs=Assign("c(0,Sz*cos(t),Sz*sin(t))") - } - if(Pstr=="zx"){ - Vz=c(0,1,0) - Fs=Assign("c(Sz*sin(t),0,Sz*cos(t))") - } - 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]] - PQ1=Q-P - if(!Closed){ - PQ2=PQ1 - }else{ - PQ2=P-R - } - Vp=PQ1/Norm(PQ1)+PQ2/Norm(PQ2) - Vp1=Vp/Norm(Vp) - Theta=acos(min(Dotprod(Vz,Vp1),1)); - Vj=Crossprod(Vz,Vp1) - if(Norm(Vj)Eps0){ - dt=Crossprod(tmp3,tmp2) - ds=Crossprod(tmp1,tmp3) - t=dt/d - s=ds/d - pt=p1+v1*t - out=list(pt,t,s) - }else{ - tmp1=Crossprod(p2-p1,v1)/Norm(v1) - out=list(abs(tmp1)) - } - return(out) -} - -Intersectseg<- function(...){ - varargin=list(...) - Nargs=length(varargin) - Eps0=10^(-4) - Eps1=0.01 - seg1=varargin[[1]] - seg2=varargin[[2]] - if(Nargs>2){Eps1=varargin[[3]]} - p1=Op(1,seg1); q1=Op(2,seg1) - p2=Op(1,seg2); q2=Op(2,seg2) - if((Norm(q1-p1)1){ - pt=Op(1,tmp); t=Op(2,tmp); s=Op(3,tmp) - if((t*(t-1)1){ - if(Op(3,tmp)*(Op(3,tmp)-1)1){ - if(Op(3,tmp)*(Op(3,tmp)-1)1){ - if(Op(3,tmp)*(Op(3,tmp)-1)1){ - if(Op(3,tmp)*(Op(3,tmp)-1)1)&&(tmp[[3]]*(tmp[[3]]-1)1)&&(tmp[[3]]*(tmp[[3]]-1)1)&&(tmp[[3]]*(tmp[[3]]-1)1)&&(tmp[[3]]*(tmp[[3]]-1)Eps1){ - out=list(dist) - }else{ - tmp=c(); - for(j in 1:length(pts)){ - tmp=Appendrow(tmp,Op(1,pts[[j]])) - } - tmp1=sum(tmp[,1])/(length(pts)) - tmp2=sum(tmp[,2])/(length(pts)) - tmp3=c(tmp1,tmp2) - tmp=Nearestpt(tmp3,seg1) - tmp1=tmp[[2]] - tmp=Nearestpt(tmp3,seg2) - tmp2=tmp[[2]] - out=list(dist,tmp3,tmp1,tmp2) - } - } - } - } - return(out) -} - -Osplineseg<- function(...){ - varargin=list(...) - Nargs=length(varargin) - Eps=10^(-2) - Eps0=10^(-6) - Ptlist=varargin[[1]] - Numstr="Num=20" - if(Nargs>1){ - Numstr=varargin[[2]] - } - p0=Op(1,Ptlist); p1=Op(2,Ptlist); p2=Op(3,Ptlist); p3=Op(4,Ptlist) - tmp=Norm(p2-p0)*Norm(p3-p1) - tmp=1+sqrt((1+Dotprod(p2-p0,p3-p1)/tmp)/2) - cc=4*Norm(p2-p1)/3/(Norm(p2-p0)+Norm(p3-p1))/tmp - pQ=p1+cc*(p2-p0) - pR=p2+cc*(p1-p3) - ctrL=list(c(pQ,pR)) - out=Bezier(list(p1,p2),ctrL,Numstr) - return(out) -} - -Intersectpartseg<- function(...){ - varargin=list(...) - Nargs=length(varargin) - crv1=varargin[[1]] - crv2=varargin[[2]] - ii=varargin[[3]] - jj=varargin[[4]] - Eps1=varargin[[5]] - Eps2=varargin[[6]] - Dist=10*Eps2 - if(Nargs>6){Dist=varargin[[7]]} - Eps00=10^(-8) - Eps0=10^(-4) - out=list() - seg1=Listplot(Op(ii,crv1),Op(ii+1,crv1)) - seg2=Listplot(Op(jj,crv2),Op(jj+1,crv2)) - tmp1=Op(2,seg1)-Op(1,seg1) - tmp2=Op(2,seg2)-Op(1,seg2) - snang=abs(Crossprod(tmp1,tmp2))/(Norm(tmp1)*Norm(tmp2)) - tmp=Intersectseg(seg1,seg2,Eps1) - dst=Op(1,tmp) - if(dstDist-Eps0)){ - os1=seg1 - }else{ - p1=Op(1,seg1); p2=Op(2,seg1) - if(ii==1){ - p3=Op(3,crv1) - tmp=p2-p1 - tmp=(p1+p2)/2+c(Op(2,tmp),-Op(1,tmp)) - p0=Reflectdata(p3,c((p1+p2)/2,tmp)) - }else{ - if(ii==Length(crv1)-1){ - p0=Op(ii-1,crv1) - tmp=p2-p1 - tmp=(p1+p2)/2+c(Op(2,tmp),-Op(1,tmp)) - p3=Reflectdata(p0,c((p1+p2)/2,tmp)) - }else{ - p0=Op(ii-1,crv1); p3=Op(ii+2,crv1) - } - } - os1=Osplineseg(list(p0,p1,p2,p3)) - } - if((Length(crv2)==2)||(Norm(Op(2,seg2)-Op(1,seg2))>Dist-Eps0)){ - os2=seg2 - }else{ - p1=Op(1,seg2); p2=Op(2,seg2) - if(jj==1){ - p3=Op(3,crv2) - tmp=p2-p1 - tmp=(p1+p2)/2+c(Op(2,tmp),-Op(1,tmp)) - p0=Reflectdata(p3,c((p1+p2)/2,tmp)) - }else{ - if(jj==Length(crv2)-1){ - p0=Op(jj-1,crv2) - tmp=p2-p1 - tmp=(p1+p2)/2+c(Op(2,tmp),-Op(1,tmp)) - p3=Reflectdata(p0,c((p1+p2)/2,tmp)) - }else{ - p0=Op(jj-1,crv2); p3=Op(jj+2,crv2) - } - } - os2=Osplineseg(list(p0,p1,p2,p3)) - } - tmp2=list() - for(kk in Looprange(1,Length(os1)-1)){ - for(ll in Looprange(1,Length(os2)-1)){ - seg1=Listplot(Op(kk,os1),Op(kk+1,os1)) - seg2=Listplot(Op(ll,os2),Op(ll+1,os2)) - tmp=Intersectseg(seg1,seg2,Eps1) - if((Op(1,tmp)1)){ #18.02.05 - if(Op(1,tmp)0){ - tmp1=c() - for(nn in Looprange(1,length(tmp2))){ - tmp1=Appendrow(tmp1,Op(2,tmp2[[nn]])) - } - tmp=sum(tmp1[,1])/length(tmp2) - tmp=c(tmp,sum(tmp1[,2])/length(tmp2)) - out=list(tmp) - p1=Op(ii,crv1); p2=Op(ii+1,crv1) - tmp=c(Op(2,p2-p1),-Op(1,p2-p1)) - tmp=Intersectline(Op(1,out),tmp,p1,p2-p1) - tmp=min(max(Op(3,tmp),0),1) - out=c(out,list(ii+tmp)) - p1=Op(jj,crv2); p2=Op(jj+1,crv2) - tmp=c(Op(2,p2-p1),-Op(1,p2-p1)) - tmp=Intersectline(Op(1,out),tmp,p1,p2-p1) - tmp=min(max(Op(3,tmp),0),1) - out=c(out,list(jj+tmp,dst,snang)) - } - } - } - return(out) -} - -if(1==0){ #start of skip - -Collectnear<- function(ptdL,Eps2){ - gL=list(Op(1,ptdL)) - rL=ptdL[Looprange(2,length(ptdL))] #18.02.07 - for( ii in Looprange(1,length(ptdL)-1)){ - numL=c() - for(jj in Looprange(1,length(rL))){ - tmp1=100 - for(kk in Looprange(1,length(gL))){ - tmp=Norm(Op(1,gL[[kk]])-Op(1,rL[[jj]])) - if(tmps1)&&(tmp1s2)&&(tmp22){Eps1=varargin[[3]]} - if(Nargs>3){Eps2=varargin[[4]]} - if(Nargs>4){Dist=varargin[[5]]} - tmp1=varargin[[1]] - crv1=matrix(Op(1,tmp1),nrow=1) - for(ii in Looprange(2,Length(tmp1))){ - tmp=Op(Length(crv1),crv1) - if(Norm(tmp-Op(ii,tmp1))>Eps0){ - crv1=Appendrow(crv1,Op(ii,tmp1)) - } - } - tmp2=varargin[[2]] - crv2=matrix(Op(1,tmp2),nrow=1) - for(ii in Looprange(2,Length(tmp2))){ - tmp=Op(Length(crv2),crv2) - if(Norm(tmp-Op(ii,tmp2))>Eps0){ - crv2=Appendrow(crv2,Op(ii,tmp2)) - } - } - if(Length(crv1)!=Length(crv2)){ - self=0 - }else{ - self=1 - for(ii in Looprange(1,Length(crv1))){ - if(Norm(Op(ii,crv1)-Op(ii,crv2))>0){ - self=0 - break - } - } - } - out=list() - for(ii in Looprange(1,Length(crv1)-1)){ - if(self==0){ - loopL=Looprange(1,Length(crv2)-1) - }else{ - loopL=Looprange(ii+2,Length(crv2)-1) - } - for(jj in loopL){ - tmp=Intersectpartseg(crv1,crv2,ii,jj,Eps1,Eps2,Dist) - if(length(tmp)>1){ #18.02.05 - if(length(out)==0){ - out=list(tmp) - }else{ - tmp1=Op(length(out),out) - if(Norm(Op(1,tmp1)-Op(1,tmp))>Eps1){ - out=c(out,list(tmp)) - } - } - if(self==1){ - tmp=list(Op(1,tmp),Op(3,tmp),Op(2,tmp),Op(4,tmp),Op(5,tmp)) - out=c(out,list(tmp)) - } - } - } - } - tmp2=out - out=list() - tmp1=tmp2 - for(ii in Looprange(1,length(tmp2))){ - tmp=Collectsameseg(tmp1) - out=c(out,list(Op(1,tmp))) - if(length(Op(2,tmp))==0){ - break - }else{ - tmp1=Op(2,tmp) - } - } - for(ii in Looprange(1,length(out))){ - tmp1=Op(ii,out) - if(length(tmp1)==1){ - out[[ii]]=Op(1,tmp1) - }else{ - tmp=c() - for(jj in Looprange(1,length(tmp1))){ - tmp=c(tmp,Op(4,tmp1[[jj]])) - } - dst=min(tmp) - tmp=c() - for(jj in Looprange(1,length(tmp1))){ - if(Op(4,tmp1[[jj]])1){ -# Start=tmp - }else{ - if(flg==0){Eps1=tmp} - if(flg==1){Eps2=tmp} - flg=flg+1 - } - } - flg=0 - AnsL=c() - if(length(plist)==1){ - Fdata=plist[[1]] - tmp1=Op(1,Fdata) - tmp2=Op(Length(Fdata),Fdata) - if(Norm(tmp1-tmp2)1){ - KL=Quicksort(KL,2) - if(length(Start)==0){ - tmp=Op(1,KL) - tst=Op(2,tmp) - Start=Pointoncurve(tst,Fdata) - }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)) - } - } - tmp=Op(1,tmp1) - tst=Op(2,tmp) - Start=Pointoncurve(tst,Fdata) - } - } - } - } - if(flg==0){ - t1=tst - for(nn in Looprange(1,length(plist))){ - Fdata=Op(nn,plist) - if(nn==length(plist)){ - nxtno=1 - }else{ - nxtno=nn+1 - } - Gdata=Op(nxtno,plist) - KL=IntersectcurvesPp(Fdata,Gdata) - if(length(KL)==0){ - tmp=matrix(Op(Length(Fdata),Fdata),nrow=1) #18.02.02from - Gdata=Appendrow(tmp,Gdata) - plist[[nxtno]]=Gdata - t2=Length(Fdata) - ss=1 #18.02.02until - }else{ - tmp=Op(1,KL) - t2=Op(2,tmp) - ss=Op(3,tmp) - if(abs(t2-t1)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 - } - } - } - if(flg==0){ - tmp=Partcrv(t1,t2,Fdata) - if(nn==1){ - AnsL=tmp - }else{ - tmp=tmp[2:Length(tmp),] - AnsL=Appendrow(AnsL,tmp) - } - t1=ss - } - } - } - return(AnsL) -} - -############## end of Enclosing2 ############# - -############## start of surface drawing ############# - -Fullformfunc<- function(FdL){ - ADDPOINT<<- list() #18.02.19 - Out=list(Op(1,FdL)) - N=length(FdL) - for(Jrg in Looprange(1,N)){ - Tmp=grep("c(",Op(Jrg,FdL),fixed=TRUE) - if(length(Tmp)>0){ - break - } - } - Urg=Stripblanks(Op(Jrg,FdL)) - Tmp=strsplit(Urg,"=",fixed=TRUE) - UNAME<<- Tmp[[1]][1] - URNG<<- eval(parse(text=Tmp[[1]][2])) - Urg=paste(UNAME,"=c(",sprintf("%6.7f",URNG[1]),",", - sprintf("%6.7f",URNG[2]),")",sep="") - Vrg=Stripblanks(Op(Jrg+1,FdL)) - Tmp=strsplit(Vrg,"=",fixed=TRUE) - VNAME<<- Tmp[[1]][1] - VRNG<<- eval(parse(text=Tmp[[1]][2])) - Vrg=paste(VNAME,"=c(",sprintf("%6.7f",VRNG[1]),",", - sprintf("%6.7f",VRNG[2]),")",sep="") - if(Jrg==2){ - Xf=UNAME - Yf=VNAME - Tmp=Stripblanks(Op(1,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Zf=Tmp[[1]][2] - Tmp=list(UNAME,VNAME,Zf,Urg,Vrg) - Out=c(Out,Tmp) - }else if(Jrg==4){ - Tmp=Stripblanks(Op(1,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Zf=Tmp[[1]][2] - Tmp=Stripblanks(Op(2,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Xname=Tmp[[1]][1] - Xf=Tmp[[1]][2] - Tmp=Stripblanks(Op(3,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Yname=Tmp[[1]][1] - Yf=Tmp[[1]][2] - Tmp=gsub(Xname,paste("(",Xf,")",sep=""),Zf,fixed=TRUE) - Zf=gsub(Yname,paste("(",Yf,")",sep=""),Tmp,fixed=TRUE) - Tmp=list(Xf,Yf,Zf,Urg,Vrg) - Out=c(Out,Tmp) - }else{ - Tmp=Stripblanks(Op(2,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Xf=Tmp[[1]][2] - Tmp=Stripblanks(Op(3,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Yf=Tmp[[1]][2] - Tmp=Stripblanks(Op(4,FdL)) - Tmp=strsplit(Tmp,"=",fixed=TRUE) - Zf=Tmp[[1]][2] - Tmp=list(Xf,Yf,Zf,Urg,Vrg) - Out=c(Out,Tmp) - } - tmp=paste("Xfunc<<- function(",UNAME,",",VNAME,"){",Xf,"}",sep='') - eval(parse(text=tmp)) - tmp=paste("Yfunc<<- function(",UNAME,",",VNAME,"){",Yf,"}",sep='') - eval(parse(text=tmp)) - tmp=paste("Zfunc<<- function(",UNAME,",",VNAME,"){",Zf,"}",sep='') - eval(parse(text=tmp)) - tmp=paste("XYZfunc<<- function(",UNAME,",",VNAME,"){",sep='') - tmp=paste(tmp,"c(",Xf,",",Yf,",",Zf,")}",sep='') - eval(parse(text=tmp)) - XYZstr<<- c(Xf,Yf,Zf) - DRWS<<- "enws" - BdyL=list() - for(I in Looprange(Jrg+2,length(FdL))){ - Tmp=Op(I,FdL) - if(is.character(Tmp)){ - if(nchar(Tmp)==0){ - Tmp=" " - } - DRWS<<- list(Tmp) - } - if((is.numeric(Tmp))&&(Length(Tmp)>1)){ - BdyL=list(Tmp) - } - } - BDYL<<- BdyL - Tmp=c(DRWS,BDYL) - Out=c(Out,Tmp) - return(Out) -} - -Addpoints<- function(ptlist){ - ADDPOINT<<- ptlist -} - -Makexybdy<- function(Np){ - Eps0=10^(-4) - Xystr=XYZstr[1:2] - Umin=URNG[1]; Umax=URNG[2] - Vmin=VRNG[1]; Vmax=VRNG[2] - Cflg=0 - EhL=list() - Tmp=grep("e",DRWS,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1="c(" - for(jj in 1:2){ - Tmp=gsub(UNAME,paste("(",sprintf("%7.7f",Umax),")",sep=""),Xystr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",VRNG) - Tmp2=paste(VNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[2])) - Tmp=Paramplot(Tmp1,Tmp2,Tmp3) - if(Norm(Op(1,Tmp)-Op(Length(Tmp),Tmp))0){ - Tmp1="c(" - for(jj in 1:2){ - Tmp=gsub(VNAME,paste("(",sprintf("%7.7f",Vmax),")",sep=""),Xystr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",URNG) - Tmp2=paste(UNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[1])) - Tmp=Paramplot(Tmp1,Tmp2,Tmp3) - if(Cflg>0){ - Tmp1=Op(length(EhL),EhL) - Tmp=Joincrvs(Tmp1,Tmp) - if(Norm(Op(1,Tmp)-Op(Length(Tmp),Tmp))0){ - Tmp1="c(" - for(jj in 1:2){ - Tmp=gsub(UNAME,paste("(",sprintf("%7.7f",Umin),")",sep=""),Xystr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",VRNG) - Tmp2=paste(VNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[2])) - Tmp=Paramplot(Tmp1,Tmp2,Tmp3) - if(Cflg>0){ - Tmp1=Op(length(EhL),EhL) - Tmp=Joincrvs(Tmp1,Tmp) - if(Norm(Op(1,Tmp)-Op(Length(Tmp),Tmp))0){ - Tmp1="c(" - for(jj in 1:2){ - Tmp=gsub(VNAME,paste("(",sprintf("%7.7f",Vmin),")",sep=""),Xystr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",URNG) - Tmp2=paste(UNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[1])) - Tmp=Paramplot(Tmp1,Tmp2,Tmp3) - if(Cflg>0){ - Tmp1=Op(length(EhL),EhL) - Tmp=Joincrvs(Tmp1,Tmp) - if(Norm(Op(1,Tmp)-Op(Length(Tmp),Tmp))2){ - Eps1=varargin[[3]] - } - Eps2=0.1 - if(Nargs>3){ - Eps2=varargin[[4]] - } - if(Nargs>4){ - Ns=varargin[[5]] - if(Ns>0){#18.02.21from - Other=Op(Ns,OTHERPARTITION) - }else{ - Other=c() - }#18.02.21until - }else{ - Ns=1 - Other=c() - } - Npt=Length(Fig) - ParL=c(1,Npt,Other) - for(N in Looprange(max(1,Ns),Length(GL))){ #18.02.21 - G=Op(N,GL) - KouL=IntersectcurvesPp(Fig,G,Eps1,Eps2) - Tmp1=c(); Tmp2=c() - for(jj in Looprange(1,length(KouL))){ - tmp=Op(2,KouL[[jj]]) - if((tmp>1+Eps0)&&(tmp1+Eps0)&&(tmp0)&&(N>Ns)&&(length(Tmp2)>0)){ #18.02.21 - tmp=OTHERPARTITION[[N]] - OTHERPARTITION[[N]]<<- c(tmp,Tmp2) - } - } - tmp1=sort(ParL) - ParL=c() - tmp2=-1 - for(jj in Looprange(1,length(tmp1))){ - tmp=Op(jj,tmp1) - if(abs(tmp-tmp2)>Eps1){ - ParL=c(ParL,tmp) - tmp2=tmp - } - } - return(ParL) -} - -Evlptablepara<- function(...){ - varargin=list(...) - Nargs=length(varargin) - Tmp=varargin[[1]] - Mdv=50 - Ndv=50 - if(Nargs>=2){ - Tmp=varargin[[2]] - if(is.list(Tmp)){Tmp=Op(1,Tmp)} - if(length(Tmp)>1){ - Mdv=Tmp[1] - Ndv=Tmp[2] - }else{ - Mdv=Tmp - if(Nargs==2){ - Ndv=Mdv - }else{ - Tmp1=varargin[[3]] - if((is.numeric(Tmp1)) && (length(Tmp1)==1)){ - Ndv=Tmp1 - }else{ - Ndv=Mdv - } - } - } - } - U1=URNG[1]; U2=URNG[2] - V1=VRNG[1]; V2=VRNG[2] - Du=(U2-U1)/(Mdv) - Dv=(V2-V1)/(Ndv) - sph=sprintf("%7.7f",sin(PHI)) - cph=sprintf("%7.7f",cos(PHI)) - sth=sprintf("%7.7f",sin(THETA)) - cth=sprintf("%7.7f",cos(THETA)) - xstr=paste("-(",XYZstr[1],")*(",sph,")+(",XYZstr[2],")*(",cph,")",sep="") - tmp=paste("-(",XYZstr[1],")*(",cph,")*(",cth,")-(",XYZstr[2],")*(",sph,")*(",cth,")",sep="") - ystr=paste(tmp,"+(",XYZstr[3],")*(",sth,")",sep="") - dxu=Diff(xstr,UNAME) - dxv=Diff(xstr,VNAME) - dyu=Diff(ystr,UNAME) - dyv=Diff(ystr,VNAME) - I=1 - Zval=c() - for(jj in 1:(Ndv+1)){ - v=V1+(jj-1)*Dv - ZuL=c() - for(ii in 1:(Mdv+1)){ - u=U1+(ii-1)*Du - tmp1=paste(UNAME,"=(",sprintf("%7.7f",u),")",sep="") - tmp2=paste(VNAME,"=(",sprintf("%7.7f",v),")",sep="") - Dxu=Funvalue(dxu,tmp1,tmp2) - Dxv=Funvalue(dxv,tmp1,tmp2) - Dyu=Funvalue(dyu,tmp1,tmp2) - Dyv=Funvalue(dyv,tmp1,tmp2) - Tmp=Dxu*Dyv-Dxv*Dyu - ZuL=c(ZuL,Tmp) - } - Zval=Appendrow(Zval,ZuL) - } - Yval=c() - for(jj in 1:(Ndv+1)){ - v=V1+(jj-1)*Dv - Yval=c(Yval,v) - } - Xval=c() - for(ii in 1:(Mdv+1)){ - u=U1+(ii-1)*Du - Xval=c(Xval,u) - } - return(list(Zval,Xval,Yval)) -} - -Evlpfun<- function(u,v){ - tmp1=paste(UNAME,"=(",sprintf("%7.7f",u),")",sep="") - tmp2=paste(VNAME,"=(",sprintf("%7.7f",v),")",sep="") - Dxu=Funvalue(dxu,tmp1,tmp2) - Dxv=Funvalue(dxv,tmp1,tmp2) - Dyu=Funvalue(dyu,tmp1,tmp2) - Dyv=Funvalue(dyv,tmp1,tmp2) - Tmp=Dxu*Dyv-Dxv*Dyu - return(Tmp) -} - -Envelopedata<- function(...){ - varargin=list(...) - Eps0=10^(-4) - Nargs=length(varargin) - Fd=varargin[[1]] - Fullformfunc(Fd) - Mdv=50 - Ndv=50 - if(Nargs>=2){ - Tmp=varargin[[2]] - if(is.list(Tmp)){Tmp=Op(1,Tmp)} - if(length(Tmp)>1){ - Mdv=Tmp[1] - Ndv=Tmp[2] - }else{ - Mdv=Tmp - if(Nargs==2){ - Ndv=Mdv - }else{ - Tmp1=varargin[[3]] - if((is.numeric(Tmp1)) && (length(Tmp1)==1)){ - Ndv=Tmp1 - }else{ - Ndv=Mdv - } - } - } - } - sph=sprintf("%7.7f",sin(PHI)) - cph=sprintf("%7.7f",cos(PHI)) - sth=sprintf("%7.7f",sin(THETA)) - cth=sprintf("%7.7f",cos(THETA)) - xstr=paste("-(",XYZstr[1],")*(",sph,")+(",XYZstr[2],")*(",cph,")",sep="") - tmp=paste("-(",XYZstr[1],")*(",cph,")*(",cth,")-(",XYZstr[2],")*(",sph,")*(",cth,")",sep="") - ystr=paste(tmp,"+(",XYZstr[3],")*(",sth,")",sep="") - dxu<<- Diff(xstr,UNAME) - dxv<<- Diff(xstr,VNAME) - dyu<<- Diff(ystr,UNAME) - dyv<<- Diff(ystr,VNAME) - U1=URNG[1]; U2=URNG[2] - V1=VRNG[1]; V2=VRNG[2] - Du=(U2-U1)/Mdv - Dv=(V2-V1)/Ndv - Out=c() - for(J in 1:(Ndv)){ - Vval1=VRNG[1]+(J-1)*Dv - Vval2=VRNG[1]+J*Dv - Uval1=URNG[1] - Eval11=Evlpfun(Uval1,Vval1) - Eval12=Evlpfun(Uval1,Vval2) - for(I in 1:(Mdv)){ -# Uval1=URNG[1]+(I-1)*Du - Uval2=URNG[1]+I*Du -# Eval11=Evlpfun(Uval1,Vval1) -# Eval12=Evlpfun(Uval1,Vval2) - Eval21=Evlpfun(Uval2,Vval1) - Eval22=Evlpfun(Uval2,Vval2) - a1=Uval1;b1=Vval1;c1=Eval11 - a2=Uval2;b2=Vval1;c2=Eval21 - a3=Uval2;b3=Vval2;c3=Eval22 - a4=Uval1;b4=Vval2;c4=Eval12 - PL=matrix(c(a1,b1,a2,b2,a3,b3,a4,b4,a1,b1),ncol=2,byrow=TRUE) - VL=c(c1,c2,c3,c4,c1) - QL=c() - for(K in 1:4){ - if(abs(VL[K])<=Eps0){ - QL=Appendrow(QL,PL[K,]) - }else if(VL[K]>Eps0){ - if(VL[K+1]< -Eps0){ - Tmp=1/(VL[K]-VL[K+1])*(-VL[K+1]*PL[K,]+VL[K]*PL[K+1,]) - QL=Appendrow(QL,Tmp) - } - }else{ - if(VL[K+1]>Eps0){ - Tmp=1/(-VL[K]+VL[K+1])*(VL[K+1]*PL[K,]-VL[K]*PL[K+1,]) - QL=Appendrow(QL,Tmp) - } - } - } - Uval1=Uval2 - Eval11=Eval21 - Eval12=Eval22 - if(Length(QL)==2){ - Out=Appendrow(Out,c(Inf,Inf)) - Out=Appendrow(Out,QL) - } - } - } - Out=Out[2:nrow(Out),] - if(Length(Out)>0){ - Out=Connectseg(Out) - }else{ - Out=c() - } - return(Out) -} - -Dropnumlistcrv<- function(QdL,Eps1){ - Eps0=10^(-4) - if(!is.list(QdL)){ - PdL=list(QdL) - }else{ - PdL=QdL - } - OutL=list() - for(I in Looprange(1,length(PdL))){ - Pd=Op(I,PdL) - PtL=c(1) - P=Op(1,Pd) - for(K in Looprange(2,Length(Pd)-1)){ - if(Norm(P-Op(K,Pd))>Eps1){ - PtL=c(PtL,K) - P=Op(K,Pd) - } - } - K=Length(Pd) - if(Norm(P-Op(K,Pd))>Eps1){ #18.02.12 eps - PtL=c(PtL,K) - } -# if(length(PtL)==1){ #180306 -# } - OutL=c(OutL,list(PtL)) - } - return(OutL) -} - -Cuspsplitpara<- function(...){ - varargin=list(...) - Nargs=length(varargin); - Gdxy=varargin[[1]] - if(!is.list(Gdxy)){ - Gdxy=list(Gdxy) - } - Eps0=10^(-4) - Eps1=0.01 - if(Nargs>2){Eps1=varargin[[2]]} - N=2 - CUSPSPLITPT<<- list() - OutkL=list() - for(Ng in Looprange(1,length(Gdxy))){ - PtxyL=Op(Ng,Gdxy) - PtkL=c() - PthL=c() - for(I in Looprange(1,Length(PtxyL))){ - Tmp=Op(I,PtxyL) - Tmp1=paste(UNAME,'=',sprintf("%7.7f",Tmp[1]),sep="") - eval(parse(text=Tmp1)) - Tmp1=paste(VNAME,'=',sprintf("%7.7f",Tmp[2]),sep="") - eval(parse(text=Tmp1)) - Tmp2=c(eval(parse(text=XYZstr[1]))) - Tmp2=c(Tmp2,eval(parse(text=XYZstr[2]))) - Tmp2=c(Tmp2,eval(parse(text=XYZstr[3]))) - Tmp3=Parapt(Tmp2) - if(I==1){ - PtkL=matrix(Tmp2,nrow=1) - PthL=matrix(Tmp3,nrow=1) - }else{ - Tmp4=Op(Length(PthL),PthL) - if(Norm(Tmp3-Tmp4)>Eps0){ - PtkL=Appendrow(PtkL,Tmp2) - PthL=Appendrow(PthL,Tmp3) - } - } - } - if(Length(PthL)==0){ - return(list()) - } - Ps=Op(1,PthL); Pe=Op(Length(PthL),PthL) - Cflg=0 - if(Norm(Ps-Pe)90){ - Cuspflg=1 - break - } - Q=Op(J,PthL) - if(Norm(P-Q)>Eps1){ - break - } - V1=Q-Op(J-1,PthL) - V2=Op(J+1,PthL)-Q - Tmp3=Dotprod(V1,V2)/(norm(V1)*norm(V2)) - Tmp=acos(Tmp3)*180/pi - if(Crossprod(V1,V2)<0){ - Tmp=-Tmp - } - Kaku=Kaku+Tmp - } - if(Cuspflg==1){ - Tmp=trunc((I+J)*0.5) - I=J - if(length(CuspL)==0){ - CuspL=c(Tmp) - }else{ - CuspL=c(CuspL,Tmp) - } - } - } - } - if(Cflg==0){ - CuspL=c(1,CuspL,Length(PthL)) - }else if(length(CuspL)==0){ - CuspL=c(1,Length(PthL)) - }else if(Op(1,CuspL)==1){ - CuspL=c(CuspL,Length(PthL)) - }else{ - Tmp=Op(1,CuspL) - Tmp1=PthL[Tmp:Length(PthL),] - Tmp2=PthL[2:Tmp,] - PthL=Appendrow(Tmp1,Tmp2) - Tmp1=PtkL[Tmp:Length(PthL),] - Tmp2=PtkL[2:Tmp,] - PtkL=Appendrow(Tmp1,Tmp2) - CuspL=CuspL-Tmp+1 - CuspL=c(CuspL,Length(PthL)) - } - if(length(CuspL)==2){ - Tmp4=PthL[Length(PthL),] - if(Length(PtkL)>=2){ - CUSPSPLITPT<<- c(CUSPSPLITPT,list(Tmp4)) - OutkL=c(OutkL,list(PtkL)) - } - next - } - Outk=list() - Is=1 - for(I in Looprange(1,length(CuspL)-1)){ - Tmp1=CuspL[Is]; Tmp2=CuspL[I+1] - Tmp3=Op(Tmp1,PthL); Tmp4=Op(Tmp2,PthL) - if(Norm(Tmp3-Tmp4)>Eps1){ - Tmpk=PtkL[Tmp1:Tmp2,] - Outk=c(Outk,list(Tmpk)) - CUSPSPLITPT<<- c(CUSPSPLITPT,list(Tmp4)) - Is=I+1 - } - } - OutkL=c(OutkL,Outk) - } - Tmp1=Dropnumlistcrv(Projpara(OutkL),Eps1*0.5) - Tmp=list() - for(I in Looprange(1,length(OutkL))){ - Tmp2=Op(I,OutkL) - Tmp3=Op(I,Tmp1) - Tmp4=c() - for(J in Looprange(1,Length(Tmp3))){ - Tmp5=Op(Tmp3[J],Tmp2) - Tmp4=Appendrow(Tmp4,Tmp5) - } - if(Length(Tmp4)>0){ - Tmp=c(Tmp,list(Tmp4)) - } - } - return(Tmp) -} - -PthiddenQ<- function(PtA,Vec,Uveq,Np,Eps1,Eps2){ - Eps0=10^(-4) - Out=c() - Vec=1/Norm(Vec)*Vec - if(length(Np)==1){ - Np=c(Np,Np) - } - Tmp=paste("Eqfun<- function(U,V){",sep='') - if((abs(Vec[2])>Eps0) || (abs(Vec[1])>Eps0)){ - Vstr=sprintf("%6.6f",Vec) - Pstr=sprintf("%6.6f",PtA) - Tmp=paste(Tmp,"(",Vstr[2],")*(Xfunc(U,V)-(",Pstr[1],"))",sep='') - Tmp=paste(Tmp,"-(",Vstr[1],")*(Yfunc(U,V)-(",Pstr[2],"))}",sep='') - }else{ - Tmp=paste(Tmp,"Xfunc(U,V)}",sep='') - } - eval(parse(text=Tmp)) - Dx=(URNG[2]-URNG[1])/Np[1] - Dy=(VRNG[2]-VRNG[1])/Np[2] - for(J in Looprange(1,Np[2])){ #180227 - Vval1=VRNG[1]+(J-1)*Dy - Vval2=VRNG[1]+J*Dy - Uval1=URNG[1] #180306(3lines) - Eval11=Eqfun(Uval1,Vval1) - Eval12=Eqfun(Uval1,Vval2) - Uval1=URNG[1] #180305(3lines) - for(I in Looprange(1,Np[1])){ #180227 -# Uval1=URNG[1]+(I-1)*Dx - Uval2=URNG[1]+I*Dx -# Eval11=Eqfun(Uval1,Vval1) -# Eval12=Eqfun(Uval1,Vval2) - Eval21=Eqfun(Uval2,Vval1) - Eval22=Eqfun(Uval2,Vval2) - a1=Uval1;b1=Vval1;c1=Eval11 - a2=Uval2;b2=Vval1;c2=Eval21 - a3=Uval2;b3=Vval2;c3=Eval22 - a4=Uval1;b4=Vval2;c4=Eval12 - PL=matrix(c(a1,b1,a2,b2,a3,b3,a4,b4,a1,b1),ncol=2,byrow=TRUE) - VL=c(c1,c2,c3,c4,c1) - QL=c() - for(K in 1:4){ - P1=Op(K,PL); P2=Op(K+1,PL) - M1=Op(K,VL); M2=Op(K+1,VL) - if(abs(M1) 0) && (M2> 0)){ - next - } - if((M1< 0) && (M2< 0)){ - next - } - Tmp=1/(M1-M2)*(-M2*P1+M1*P2) - QL=Appendrow(QL,Tmp) - } - Uval1=Uval2 #180306(3lines) - Eval11=Eval21 - Eval12=Eval22 - if(Length(QL)==2){ - Puv1=Op(1,QL); Puv2=Op(2,QL) - Tmp1=Op(1,Puv1) - Tmp2=Op(2,Puv1) - Xv=Xfunc(Tmp1,Tmp2) - Yv=Yfunc(Tmp1,Tmp2) - Zv=Zfunc(Tmp1,Tmp2) - P1=c(Xv,Yv,Zv) - Tmp1=Op(1,Puv2) - Tmp2=Op(2,Puv2) - Xv=Xfunc(Tmp1,Tmp2) - Yv=Yfunc(Tmp1,Tmp2) - Zv=Zfunc(Tmp1,Tmp2) - P2=c(Xv,Yv,Zv) - V1=Vec[1]; V2=Vec[2]; V3=Vec[3] - if(abs(V1)>Eps0){ - M1=PtA[3]+V3/V1*(P1[1]-PtA[1])-P1[3] - M2=PtA[3]+V3/V1*(P2[1]-PtA[1])-P2[3] - }else if(abs(V2)>Eps0){ - M1=PtA[3]+V3/V2*(P1[2]-PtA[2])-P1[3] - M2=PtA[3]+V3/V2*(P2[2]-PtA[2])-P2[3] - }else{ - M1=PtA[2]-P1[2] - M2=PtA[2]-P2[2] - } - if(M1*M2>= 0){ - if(((M1>0) && (M2>0)) || ((M1< 0) && (M2< 0))){ - next - } - if(M1==0){ - Pt=P1; Ptuv=Puv1 - }else{ - Pt=P2; Ptuv=Puv2 - } - }else{ - Pt=1/(M1-M2)*(-M2*P1+M1*P2) - Ptuv=1/(M1-M2)*(-M2*Puv1+M1*Puv2) - } - if(is.character(Uveq)){ - Tmp1=paste('(',sprintf("%6.6f",Ptuv[1]),')',sep='') - Tmp2=paste('('+sprintf("%6.6f",Ptuv[2]),')',sep='') - Tmp=gsub(UNAME,Tmp1,Uveq,fixed=TRUE) - Tmp=gsub(VNAME,Tmp2,Tmp,fixed=TRUE) - Tmp=eval(parse(text=Tmp)) - if(Tmp< -Eps0){ - next - } - } - Tmp1=Crossprod(Pt-PtA,Vec) - if(Norm(Tmp1)Zparapt(PtA)+Eps2){ - return(list(1,Pt,Zparapt(Pt),Zparapt(PtA))) - }else{ - Out=Appendrow(Out,Pt) - } - } - } - } - } - if(Length(Out)==0){ - return(list(0,c())) - } - return(c(list(0,Out))) -} - -Nohiddenpara2<- function (Par,Fk,Uveq,Np,Eps1,Eps2){ - Eps0=10^(-4) - Fh=Projpara(Fk) - P1=Ptstart(Fh) - P2=Ptend(Fh) - Csp=CUSPPT - if(!is.list(Csp)){Csp=list(Csp)} - Cspflg=1 - for(I in Looprange(1,length(Csp))){ - Tmp=Op(I,Csp) - if(Norm(Tmp-P1)Eps0){ #180227 - PaL=c(PaL,tmp1) - tmp2=tmp1 - } - } - tmp1=PaL[length(PaL)] #18.02.26from - tmp2=Par[length(Par)] - if(abs(tmp1-tmp2)0){ - if(Norm(P-Q)>Eps0){ #18.02.14 - FigL=c(FigL,list(Partcrv(P,Q,Fh))) - Tmp3=Invparapt(SP,Fh,Fk) - TP=Op(2,Tmp3) - Tmp3=Invparapt(SQ,Fh,Fk) - TQ=Op(2,Tmp3) - FigkL=c(FigkL,list(Partcrv3(TP,TQ,Fk))) - }else{ - FigL=c(FigL,list(Fh)) - FigkL=c(FigkL,list(Fk)) - } - } - Tmp=c() - for(I in Looprange(1,length(PaL)-1)){ - if(!Member(I,SeL)){ - Tmp=c(Tmp,I) - } - } - SeL=Tmp - HIDDENDATA<<- list() - for(I in Looprange(1,length(SeL))){ - Tmp=PaL[SeL[I]] - Tmp1=Pointoncurve(Tmp,Fh) - Tmp=PaL[SeL[I]+1] - Tmp2=Pointoncurve(Tmp,Fh) - if(I==1){ - P=Tmp1; SP=PaL[SeL[I]] - Q=Tmp2; SQ=PaL[SeL[I]+1] - }else{ - if(Member(SeL[I]-1,SeL)){ - Q=Tmp2; SQ=PaL[SeL[I]+1] - }else{ - Tmp=Invparapt(SP,Fh,Fk) - TP=Op(2,Tmp) - Tmp=Invparapt(SQ,Fh,Fk) - TQ=Op(2,Tmp) - HIDDENDATA<<- c(HIDDENDATA,list(Partcrv3(TP,TQ,Fk))) - P=Tmp1; SP=PaL[SeL[I]] - Q=Tmp2; SQ=PaL[SeL[I]+1] - } - } - } - if(length(SeL)>0){ - if(Norm(P-Q)>Eps0){ #18.02.14 - Tmp=Invparapt(SP,Fh,Fk) - TP=Op(2,Tmp) - Tmp=Invparapt(SQ,Fh,Fk) - TQ=Op(2,Tmp) - HIDDENDATA<<- c(HIDDENDATA,list(Partcrv3(TP,TQ,Fk))) - }else{ - HIDDENDATA<<- c(HIDDENDATA,list(Fk)) - } - } - return(FigkL) -} - -Borderparadata<- function(...){ - varargin=list(...) - Nargs=length(varargin) - FkL=varargin[[1]] - Np=c(50,50) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(2,Nargs)){ - tmp=varargin[[jj]] - if((length(tmp)>1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - Umin=URNG[1]; Umax=URNG[2] - Vmin=VRNG[1]; Vmax=VRNG[2] - EkL=list() - Tmp=grep("e",DRWS,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1="c(" - for(jj in 1:3){ - Tmp=gsub(UNAME,paste("(",sprintf("%7.7f",Umax),")",sep=""),XYZstr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",VRNG) - Tmp2=paste(VNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[2]),sep="") - Tmp=Spacecurve(Tmp1,Tmp2,Tmp3) - EkL=c(EkL,list(Tmp)) - } - Tmp=grep("n",DRWS,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1="c(" - for(jj in 1:3){ - Tmp=gsub(VNAME,paste("(",sprintf("%7.7f",Vmax),")",sep=""),XYZstr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",URNG) - Tmp2=paste(UNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[1]),sep="") - Tmp=Spacecurve(Tmp1,Tmp2,Tmp3) - EkL=c(EkL,list(Tmp)) - } - Tmp=grep("w",DRWS,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1="c(" - for(jj in 1:3){ - Tmp=gsub(UNAME,paste("(",sprintf("%7.7f",Umin),")",sep=""),XYZstr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",VRNG) - Tmp2=paste(VNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[2])) - Tmp=Spacecurve(Tmp1,Tmp2,Tmp3) - EkL=c(EkL,list(Tmp)) - } - Tmp=grep("s",DRWS,fixed=TRUE) - if(length(Tmp)>0){ - Tmp1="c(" - for(jj in 1:3){ - Tmp=gsub(VNAME,paste("(",sprintf("%7.7f",Vmin),")",sep=""),XYZstr[jj]) - Tmp1=paste(Tmp1,Tmp,",",sep="") - } - Tmp=substring(Tmp1,1,Length(Tmp1)-1) - Tmp1=paste(Tmp,")",sep="") - Tmp=sprintf("%6.6f",URNG) - Tmp2=paste(UNAME,"=c(",Tmp[1],",",Tmp[2],")",sep='') - Tmp3=paste('N=',as.character(Np[1])) - Tmp=Spacecurve(Tmp1,Tmp2,Tmp3) - EkL=c(EkL,list(Tmp)) - } - if(length(EkL)>0){ - FkL=c(FkL,EkL) - } - Fall=Projpara(FkL) - if(is.numeric(Fall)){ - Fall=list(Fall) - } - Fbdxy=Makexybdy(Np) - BORDERPT<<- list() - Tmp1=list() - for(I in Looprange(1,length(Fall))){ - Tmp1=c(Tmp1,list(c())) - } - OTHERPARTITION<<- Tmp1 - FsL=list() - BORDERHIDDENDATA<<- list() - starttime=proc.time() - for(I in Looprange(1,length(FkL))){ - Tmp=Op(I,FkL) - Tmp=Projpara(Tmp) - Par=Partitionseg(Tmp,Fall,Eps1,Eps2,I) - Tmp1=Op(I,FkL) - Tmp=Nohiddenpara2(Par,Tmp1,1,Np,Eps1,Eps2) - if(length(HIDDENDATA)>0){ - BORDERHIDDENDATA<<- c(BORDERHIDDENDATA,HIDDENDATA) - } - if(length(Tmp)>0){ - FsL=c(FsL,Tmp) - } - Tmp=paste('Border',formatC(I,width=2,flag="0"),'/',sep='') - Tmp=paste(Tmp,as.character(length(FkL)),' obtained : Time =',sep='') - Tmp1=proc.time()-starttime - print(paste(Tmp,sprintf("%6.3f",Tmp1[1]),sep='')) - } - return(FsL) -} - -Sfbdparadata<- function(...){ - varargin=list(...) - Nargs=length(varargin) - Fd=varargin[[1]] - FdL=Fullformfunc(Fd) - Np=c(50,50) - Eps0=10^(-4) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(2,Nargs)){ - tmp=varargin[[jj]] - if((length(tmp)>1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - starttime=proc.time() -# tmp=Evlptablepara(Np) -# Zval=tmp[[1]]; Xval=tmp[[2]]; Yval=tmp[[3]] -# Out3=Implicitplot(Zval,Xval,Yval) - Out3=Envelopedata(Fd) #180306 - tmp3=list() - pts=list() #180306 - for(jj in Looprange(1,length(Out3))){ - tmp1=Op(jj,Out3) - tmp2=c() - for(kk in Looprange(1,Length(tmp1))){ - tmp=Op(kk,tmp1) - tmp2=Appendrow(tmp2,XYZfunc(tmp[1],tmp[2])) - } - Nlist=Dropnumlistcrv(tmp2,Eps1) - Nlist=Nlist[[1]] - if(Length(Nlist)==1){ #180306from - tmp=Op(1,Nlist) - tmp=Op(tmp,tmp1) - pts=c(pts,list(tmp)) -# pts=c(pts,list(XYZfunc(tmp[1],tmp[2])))#180306until - }else{ - tmp=c() - for(kk in Looprange(1,length(Nlist))){ - tmp=Appendrow(tmp,Op(Nlist[kk],tmp1)) #18.02.18 - } - if(Length(tmp)>0){ - tmp3=c(tmp3,list(tmp)) - } - } - } - Out3=tmp3 - tmp3=pts #180306from - pts=list() - for(ii in Looprange(1,length(tmp3))){ - tmp=Op(ii,tmp3) - tmp1=XYZfunc(tmp[1],tmp2[]) - flg=0 - for(jj in Looprange(1,length(pts))){ - tmp=Op(jj,pts) - tmp2=XYZfunc(tmp[1],tmp2[]) - if(Norm(tmp1-tmp2)Eps0) || (abs(Vec[1])>Eps0)){ - Vstr=sprintf("%6.6f",Vec) - Pstr=sprintf("%6.6f",PtA) - Tmp=paste(Tmp,"(",Vstr[2],")*(Xfunc(U,V)-(",Pstr[1],"))",sep='') - Tmp=paste(Tmp,"-(",Vstr[1],")*(Yfunc(U,V)-(",Pstr[2],"))}",sep='') - }else{ - Tmp=paste(Tmp,"Xfunc(U,V)}",sep='') - } - eval(parse(text=Tmp)) - Dx=(URNG[2]-URNG[1])/Np[1] - Dy=(VRNG[2]-VRNG[1])/Np[2] - for(J in Looprange(1,Np[2])){ - Vval1=VRNG[1]+(J-1)*Dy - Vval2=VRNG[1]+J*Dy - Uval1=URNG[1] #180305(3lines) - Eval11=Eqfun(Uval1,Vval1) - Eval12=Eqfun(Uval1,Vval2) - for(I in Looprange(1,Np[1])){ -# Uval1=URNG[1]+(I-1)*Dx - Uval2=URNG[1]+I*Dx -# Eval11=Eqfun(Uval1,Vval1) -# Eval12=Eqfun(Uval1,Vval2) - Eval21=Eqfun(Uval2,Vval1) - Eval22=Eqfun(Uval2,Vval2) - a1=Uval1;b1=Vval1;c1=Eval11 - a2=Uval2;b2=Vval1;c2=Eval21 - a3=Uval2;b3=Vval2;c3=Eval22 - a4=Uval1;b4=Vval2;c4=Eval12 - PL=matrix(c(a1,b1,a2,b2,a3,b3,a4,b4,a1,b1),ncol=2,byrow=TRUE) - VL=c(c1,c2,c3,c4,c1) - QL=c() - for(K in 1:4){ - P1=Op(K,PL); P2=Op(K+1,PL) - M1=Op(K,VL); M2=Op(K+1,VL) - if(abs(M1) 0) && (M2> 0)){ - next - } - if((M1< 0) && (M2< 0)){ - next - } - Tmp=1/(M1-M2)*(-M2*P1+M1*P2) - QL=Appendrow(QL,Tmp) - } - Uval1=Uval2 #180306(3lines) - Eval11=Eval21 - Eval12=Eval22 - if(Length(QL)==2){ - Puv1=Op(1,QL); Puv2=Op(2,QL) - Tmp1=Op(1,Puv1) - Tmp2=Op(2,Puv1) - Xv=Xfunc(Tmp1,Tmp2) - Yv=Yfunc(Tmp1,Tmp2) - Zv=Zfunc(Tmp1,Tmp2) - P1=c(Xv,Yv,Zv) - Tmp1=Op(1,Puv2) - Tmp2=Op(2,Puv2) - Xv=Xfunc(Tmp1,Tmp2) - Yv=Yfunc(Tmp1,Tmp2) - Zv=Zfunc(Tmp1,Tmp2) - P2=c(Xv,Yv,Zv) - V1=Vec[1]; V2=Vec[2]; V3=Vec[3] - if(abs(V1)>Eps0){ - M1=PtA[3]+V3/V1*(P1[1]-PtA[1])-P1[3] - M2=PtA[3]+V3/V1*(P2[1]-PtA[1])-P2[3] - }else if(abs(V2)>Eps0){ - M1=PtA[3]+V3/V2*(P1[2]-PtA[2])-P1[3] - M2=PtA[3]+V3/V2*(P2[2]-PtA[2])-P2[3] - }else{ - M1=PtA[2]-P1[2] - M2=PtA[2]-P2[2] - } - if(M1*M2>= 0){ #18.02.21 - if(((M1>0) && (M2>0)) || ((M1< 0) && (M2< 0))){ - next - } - if(M1==0){ - Pt=P1; Ptuv=Puv1 - }else{ - Pt=P2; Ptuv=Puv2 - } - }else{ - Pt=1/(M1-M2)*(-M2*P1+M1*P2) - Ptuv=1/(M1-M2)*(-M2*Puv1+M1*Puv2) - } - if(is.character(Uveq)){ - Tmp1=paste('(',sprintf("%6.6f",Ptuv[1]),')',sep='') - Tmp2=paste('('+sprintf("%6.6f",Ptuv[2]),')',sep='') - Tmp=gsub(UNAME,Tmp1,Uveq,fixed=TRUE) - Tmp=gsub(VNAME,Tmp2,Tmp,fixed=TRUE) - Tmp=eval(parse(text=Tmp)) - if(Tmp< -Eps0){ - next - } - } - Tmp1=Crossprod(Pt-PtA,Vec) - if(Norm(Tmp1)-Eps0)&&(Tmp1=2){ - Fbdy=Joincrvs(FigL) - }else{ - Fbdy=Op(1,FigL) - } - if(!is.list(ObjL)){ - ObjL=list(ObjL) - } - if(!is.list(FigL)){ - FigL=list(FigL) - } - OutL=list() - for(Nobj in Looprange(1,length(ObjL))){ - Obj=Op(Nobj,ObjL) - ParL=c(1,Length(Obj)) - Tmp=IntersectcurvesPp(Obj,Fbdy,Eps1,Eps2) - for(J in Looprange(1,length(Tmp))){ - Tmp1=Op(J,Tmp) - ParL=c(ParL,Op(2,Tmp1)) - } - ParL=sort(ParL) - Tmp=c(1) - for(I in Looprange(1,length(ParL))){ - Tmp1=Op(length(Tmp),Tmp) - Tmp2=ParL[I] - if(Tmp2-Tmp1>Eps0){ - Tmp=c(Tmp,Tmp2) - } - } - ParL=Tmp - Tmp1=Op(length(ParL),ParL) - Tmp2=Length(Obj) - if(abs(Tmp1-Tmp2)1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - Out=list() - CRVSFHIDDENDATA<<- list() - for(Nn in Looprange(1,length(FkL))){ - Fk=Op(Nn,FkL) - Tmp=Projpara(Fk) - Par=Partitionseg(Tmp,Fbdy,Eps1,Eps2,0) - if(Sepflg==0){ - for(I in Looprange(1,Length(Fk)-1)){ - Pa=Op(I,Fk) - Pb=Op(I+1,Fk) - PtL=Meetpoints(Pa,Pb,1,Np,Eps1) - for(J in Looprange(1,Length(PtL))){ - Tmp=Op(J,PtL) - Tmp=Parapt(Tmp) - Tmp1=Paramoncurve(Tmp,I,Projpara(Fk)) - Tmp2=min(abs(Par-Tmp1)) - if(Tmp2*Norm(Parapt(Pb-Pa))>Eps0) { #180227 - Par=c(Par,Tmp1) - } - } - Par=sort(Par) - } - } - for(jj in Looprange(1,length(ADDPOINT))){ #18.02.19from - tmp=Parapt(Op(jj,ADDPOINT)) - tmp=Nearestpt(tmp,Projpara(Fk)) - if(tmp[[3]]Eps0){ #180227 - Par=c(Par,tmp) - tmp2=tmp - } - } - Tmp1=Nohiddenpara2(Par,Fk,1,Np,Eps1,Eps2) - Out=c(Out,Tmp1) - CRVSFHIDDENDATA<<- c(CRVSFHIDDENDATA,HIDDENDATA) - Tmp=paste('Crvsfdata',formatC(Nn,width=2,flag="0"),'/',sep='') - Tmp=paste(Tmp,as.character(length(FkL)),' obtained : Time =',sep='') - Tmp1=proc.time()-starttime - print(paste(Tmp,sprintf("%6.3f",Tmp1[1]),sep='')) - } - return(Out) -} - -Crv3onsfparadata<- function(...){ - starttime=proc.time() - varargin=list(...) - Nargs=length(varargin) - Fk=varargin[[1]] - if(!is.list(Fk)){ - FkL=list(Fk) - }else{ - FkL=Fk - } - Fbdy=Projpara(varargin[[2]]) - Fd=varargin[[3]] - Fullformfunc(Fd) #18.02.17 - Np=c(50,50) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(4,Nargs)){ - tmp=varargin[[jj]] - if((length(tmp)>1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - Out=list() - CRVONSFHIDDENDATA<<- list() - for(Nn in Looprange(1,length(FkL))){ - Fk=Op(Nn,FkL) - Tmp=Projpara(Fk) - Par=Partitionseg(Tmp,Fbdy,Eps1,Eps2,0) - for(jj in Looprange(1,length(ADDPOINT))){ - tmp=Parapt(Op(jj,ADDPOINT)) - tmp=Nearestpt(tmp,Projpara(Fk)) - if(tmp[[3]]1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - Out=Crv3onsfparadata(FkL,Fbdy3,Fd,Np,Eps1,Eps2) - return(Out) -} - -Wireparadata<- function(...){ - starttime=proc.time() - varargin=list(...) - Nargs=length(varargin) - Fbdy3=varargin[[1]] - Fd=varargin[[2]] - FdL=Fullformfunc(Fd) - DuL=varargin[[3]] - DvL=varargin[[4]] - Np=c(50,50) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(5,Nargs)){ - tmp=varargin[[jj]] - if((length(tmp)>1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - if(is.numeric(DuL)){ - tmp1=DuL - DuL=list() - for(jj in Looprange(1,tmp1)){ - tmp=jj*(URNG[2]-URNG[1])/(tmp1+1) - DuL=c(DuL,list(tmp)) - } - } - if(is.numeric(DvL)){ - tmp1=DvL - DvL=list() - for(jj in Looprange(1,tmp1)){ - tmp=jj*(VRNG[2]-VRNG[1])/(tmp1+1) - DvL=c(DvL,list(tmp)) - } - } - Fuv=list() - for(jj in Looprange(1,length(DuL))){ - tmp1=paste("c(",as.character(Op(jj,DuL)),",",VNAME,")",sep="") - tmp2=paste("N=",as.character(Np[2]),sep="") - tmp1=Paramplot(tmp1,Op(6,FdL),tmp2) - tmp2=c() - for(kk in Looprange(1,Length(tmp1))){ - tmp=Op(kk,tmp1) - tmp2=Appendrow(tmp2,tmp) - } - Fuv=c(Fuv,list(tmp2)) - } - FkL=list() - for(jj in Looprange(1,length(Fuv))){ - tmp1=Op(jj,Fuv) - tmp2=c() - for(kk in Looprange(1,Length(tmp1))){ - tmp=Op(kk,tmp1) - tmp2=Appendrow(tmp2,XYZfunc(tmp[1],tmp[2])) - } - FkL=c(FkL,list(tmp2)) - } - Tmp1=proc.time()-starttime - cat(UNAME,"direction started","\n") - Out1=Crv3onsfparadata(FkL,Fbdy3,Fd,Np,Eps1,Eps2) - WIREHIDDENDATA<<- CRVONSFHIDDENDATA - Fuv=list() - for(jj in Looprange(1,length(DvL))){ - tmp1=paste("c(",UNAME,",",as.character(Op(jj,DvL)),")",sep="") - tmp2=paste("N=",as.character(Np[2]),sep="") - tmp1=Paramplot(tmp1,Op(5,FdL),tmp2) - tmp2=c() - for(kk in Looprange(1,Length(tmp1))){ - tmp=Op(kk,tmp1) - tmp2=Appendrow(tmp2,tmp) - } - Fuv=c(Fuv,list(tmp2)) - } - FkL=list() - for(jj in Looprange(1,length(Fuv))){ - tmp1=Op(jj,Fuv) - tmp2=c() - for(kk in Looprange(1,Length(tmp1))){ - tmp=Op(kk,tmp1) - tmp2=Appendrow(tmp2,XYZfunc(tmp[1],tmp[2])) - } - FkL=c(FkL,list(tmp2)) - } - cat(VNAME,"direction started","\n") - Out2=Crv3onsfparadata(FkL,Fbdy3,Fd,Np,Eps1,Eps2) - WIREHIDDENDATA<<- c(WIREHIDDENDATA, CRVONSFHIDDENDATA) - Out=c(Out1,Out2) - return(Out) -} - -Intersectcrvsf<- function(...){ - # bdyeq is the equation of boundary f(x,y,z) =0 - starttime=proc.time() - varargin=list(...) - Nargs=length(varargin) - crv=varargin[[1]] - Fd=varargin[[2]] - Fullformfunc(Fd) - bdyflg=0 - bdyeq=varargin[[Nargs]] - if(is.character(bdyeq)){ - Nargs=Nargs-1 - bdyflg=1 - tmp=strsplit(bdyeq,"=",fixed=TRUE) - tmp=tmp[[1]] - if(length(tmp)>1){ - bdyeq=paste("(",tmp[1],")-(",tmp[2],")",sep="") - } - tmp=paste("bdyeq<- function(P){x=P[1];y=P[2];z=P[3];",bdyeq,"}",sep="") - eval(parse(text=tmp)) - } - Eps0=10^(-4) - Np=c(50,50) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(3,Nargs)){ - tmp=varargin[[jj]] - if((length(tmp)>1)||(tmp>1)){ - Np=tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=tmp} - if(ctr==2){Eps2=tmp} - } - } - PtL=list() - for(I in Looprange(1,Length(crv)-1)){ - Pa=Op(I,crv) - Pb=Op(I+1,crv) - if(bdyflg==0){ - tmp=Meetpoints(Pa,Pb,1,Np,Eps1) - }else{ - M1=bdyeq(Pa); M2=bdyeq(Pb) - if(M1*M2>= 0){ #18.02.21 - if(((M1>0) && (M2>0)) || ((M1< 0) && (M2< 0))){ - next - } - if(M1==0){ - tmp=list(Pa) - }else{ - tmp=list(Pb) - } - }else{ - while(Norm(Pb-Pa)>Eps0){ - if(bdyeq(Pa)==0){ - tmp=list(Pa) - break - } - if(bdyeq(Pa)*bdyeq((Pa+Pb)/2)>0){ - Pa=(Pa+Pb)/2 - }else{ - Pb=(Pa+Pb)/2 - } - } - tmp=list(1/(M1-M2)*(-M2*Pa+M1*Pb)) - } - } - PtL=c(PtL,tmp) - } - Tmp=paste('Intersectcrvsf obtained : Time =',sep='') - Tmp1=proc.time()-starttime - print(paste(Tmp,sprintf("%6.3f",Tmp1[1]),sep='')) - return(PtL) -} - -Sfcutparadata<- function(...){ - varargin=list(...) - Nargs=length(varargin) - CutD=varargin[[1]] - Fbdy3=varargin[[2]] - Fd=varargin[[3]] - FdL=Fullformfunc(Fd) - Np=c(50,50) - Eps0=10^(-4) - Eps1=0.01 - Eps2=0.05 - ctr=0 - for(jj in Looprange(4,Nargs)){ - Tmp=varargin[[jj]] - if((length(Tmp)>1)||(Tmp>1)){ - Np=Tmp - if(length(Np)==1){ - Np=c(Np,Np) - } - }else{ - ctr=ctr+1 - if(ctr==1){Eps1=Tmp} - if(ctr==2){Eps2=Tmp} - } - } - starttime=proc.time() - Tmp=strsplit(CutD,'=') - Tmp=Tmp[[1]] - if(length(Tmp)==1){ - Eq=CutD - }else{ - Eq=paste("(",Tmp[1],")-(",Tmp[2],")",sep="") - } - Eq=gsub("x","Xfunc(U,V)",Eq,fixed=TRUE) - Eq=gsub("y","Yfunc(U,V)",Eq,fixed=TRUE) - Eq=gsub("z","Zfunc(U,V)",Eq,fixed=TRUE) - Tmp=paste("Eqfun<<- function(U,V){",Eq,"}",sep="") - eval(parse(text=Tmp)) - Du=(URNG[2]-URNG[1])/Np[1] - Dv=(VRNG[2]-VRNG[1])/Np[2] - Out=list();Out2=list() - for(J in Looprange(1,Np[2])){ - Vval1=VRNG[1]+(J-1)*Dv - Vval2=VRNG[1]+J*Dv - Uval1=URNG[1] #180305(3lines) - Eval11=Eqfun(Uval1,Vval1) - Eval12=Eqfun(Uval1,Vval2) - for(I in Looprange(1,Np[1])){ -# Uval1=URNG[1]+(I-1)*Du - Uval2=URNG[1]+I*Du -# Eval11=Eqfun(Uval1,Vval1) -# Eval12=Eqfun(Uval1,Vval2) - Eval21=Eqfun(Uval2,Vval1) - Eval22=Eqfun(Uval2,Vval2) - a1=Uval1;b1=Vval1;c1=Eval11 - a2=Uval2;b2=Vval1;c2=Eval21 - a3=Uval2;b3=Vval2;c3=Eval22 - a4=Uval1;b4=Vval2;c4=Eval12 - PL=matrix(c(a1,b1,a2,b2,a3,b3,a4,b4,a1,b1),ncol=2,byrow=TRUE) - VL=c(c1,c2,c3,c4,c1) - QL=c() - for(K in 1:4){ - P1=Op(K,PL); P2=Op(K+1,PL) - M1=Op(K,VL); M2=Op(K+1,VL) - if(abs(M1) 0) && (M2> 0)){ - next - } - if((M1< 0) && (M2< 0)){ - next - } - Tmp=1/(M1-M2)*(-M2*P1+M1*P2) - QL=Appendrow(QL,Tmp) - } - Uval1=Uval2 #180306(3lines) - Eval11=Eval21 - Eval12=Eval22 - if(Length(QL)==2){ - q11=QL[1,1];q12=QL[1,2];q21=QL[2,1];q22=QL[2,2] - if(((q11==a1)&&(q21==a1))||((q11==a3)&&(q21==a3))){ - if(((q21==b1)&&(q22==b1))||((q21==b3)&&(q22==b3))){ - Out2=c(Out2,list(QL)) - }else{ - Out=c(Out,list(QL)) - } - next - } - if(((q12==b1)&&(q22==b1))||((q12==b3)&&(q22==b3))){ - if(((q11==a1)&&(q21==a1))||((q11==a3)&&(q21==a3))){ - Out2=c(Out2,list(QL)) - }else{ - Out=c(Out,list(QL)) - } - next - } - Out=c(Out,list(QL)) - } - } - } - while(length(Out2)>0){ - tmp1=Out2[[1]] - Out=c(Out,list(tmp1)) - Out2=Out2[-1] - rmv=c() - for(jj in Looprange(1,length(Out2))){ - tmp2=Out2[[jj]] - diff1=Norm(tmp2[1,]-tmp1[1,])+Norm(tmp2[2,]-tmp1[2,]) - diff2=Norm(tmp2[1,]-tmp1[2,])+Norm(tmp2[2,]-tmp1[1,]) - if((diff10){ - if(Norm(Op(Length(Tmp3),Tmp3)-Tmp)