# 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(18.02.26)"
print(ThisVersion)
# 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)
}
Crossprod<-function(a,b)
{
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)
}
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]
}
}
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 upto
}
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 upto
}
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.24upto
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 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<- Data[[2]]
P<- Ptstart(Tmp)
Q<- Ptend(Tmp)
if(Norm(P2-P)>Eps && Norm(P2-Q)>Eps){
Tmp< Nrow(PL)
PL<-PL[Tmp:1,]
Pfirst<- Ptstart(PL)
Plast<- Ptend(PL)
}
}
}
else{
if(Norm(P1-Plast)Eps){
Np<- Nrow(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,Q,Pfirst)
PL<- Tmp
}
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,Q,Pfirst)
PL<- Tmp
}
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,Q,Pfirst)
PL<- Tmp
}
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,Q,Pfirst)
PL<- Tmp
}
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 2:Nrow(PL)){
P<- Op(J,PL)
Q<- Op(Nrow(Tmp),Tmp)
if(Norm(P-Q)>Eps){
Tmp1<-Appendrow(Tmp,P)
Tmp<-Tmp1
}
}
PL<-Tmp
PLall<-Mixjoin(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.07upto
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.13upto
varname=cmd
tmp=paste(varname,"<<- list()",sep="")
eval(parse(text=tmp))
Ctr=0
if(flg==0){ # 17.10.07from
flg=1
}else{
} # 17.10.07upto
}
}
}
# 17.12.13from
tmp=paste("if(length(",varname,")==1){",varname,"<<- ",varname,"[[1]]}",sep="")
eval(parse(text=tmp))
# 17.12.13upto
}
####################################################
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);
}
#########################################
Shade<- 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 upto
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(upto)
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(upto)
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)=4){
Tmp=Op(4,MS)
if(Length(Tmp)>1){ #18.02.09
Mdv=Op(1,Tmp)
Ndv=Op(2,Tmp)
}else{
Mdv=Tmp
if(Nargs==4){
Ndv=Mdv
}else{
Tmp1=Op(5,MS)
if((is.numeric(Tmp1))&&(length(Tmp1)==1)){
Ndv=Tmp1
}else{
Ndv=Mdv
}
}
}
}
X1=Xrange[1]; X2=Xrange[2]
Y1=Yrange[1]; Y2=Yrange[2]
Dx=(X2-X1)/Mdv
Dy=(Y2-Y1)/Ndv
Xval=c()
Tmp=X1
for(ii in 1:(Mdv+1)){
Tmp=X1+(ii-1)*Dx
Xval=c(Xval,Tmp)
}
Yval=c()
Tmp=Y1
for(jj in 1:(Ndv+1)){
Tmp=Y1+(jj-1)*Dy
Yval=c(Yval,Tmp)
}
Zval=matrix(nrow=Ndv+1,ncol=Mdv+1)
I=1
for(y in Yval){
J=1
for(x in Xval){
Zval[I,J]=eval(parse(text=Fstr))
J=J+1
}
I=I+1
}
return(list(Zval,Xval,Yval))
}
Implicitplot<- function(...){
varargin=list(...)
Eps0=10^(-4)
Nargs=length(varargin)
Fstr=varargin[[1]]
if(is.list(Fstr)){
MS=Fstr
Tmp=Makevaltable(MS)
Zval=Tmp[[1]]; Xval=Tmp[[2]]; Yval=Tmp[[3]]
}else if(is.character(Fstr)){
# MS=list()
# for(I in 1:Nargs){
# MS=c(MS,varargin[I])
# }
# Tmp=Makevaltable(MS)
Tmp=Makevaltable(varargin) #18.02.24
Zval=Tmp[[1]]; Xval=Tmp[[2]]; Yval=Tmp[[3]]
}else{
Zval=varargin[[1]]
Xval=varargin[[2]]
Yval=varargin[[3]]
}
Out=c()
for(J in Looprange(1,length(Yval)-1)){
for(I in Looprange(1,length(Xval)-1)){
a1=Xval[I]; b1=Yval[J]; c1=Zval[J,I]
a2=Xval[I+1]; b2=Yval[J]; c2=Zval[J,I+1]
a3=Xval[I+1]; b3=Yval[J+1]; c3=Zval[J+1,I+1]
a4=Xval[I];b4=Yval[J+1];c4=Zval[J+1,I]
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)
}
}
}
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)
}
#########################
# 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.23upto
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.23upto
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.23upto
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]]}
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)
}
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(tmp2){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=Collectnear(tmp1,Eps2)
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.02upto
}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){
Eps=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.21upto
}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,Eps,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)>Eps){
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))
}
Dropnumlistcrv<- function(QdL,Eps){
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))>Eps){
PtL=c(PtL,K)
P=Op(K,Pd)
}
}
K=Length(Pd)
if(Norm(P-Op(K,Pd))>Eps){ #18.02.12 eps
PtL=c(PtL,K)
}
if(length(PtL)==1){
PtL=c()
}
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)
Eps=0.01
if(Nargs>2){Eps=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)>Eps){
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)>Eps){
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),Eps*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,Eps,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])){ #####
Vval1=VRNG[1]+(J-1)*Dy
Vval2=VRNG[1]+J*Dy
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)
}
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,Eps,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)Eps2){
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)
Eps=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){Eps=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,Eps,Eps2,I)
Tmp1=Op(I,FkL)
Tmp=Nohiddenpara2(Par,Tmp1,1,Np,Eps,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)
Eps=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){Eps=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)
tmp3=list()
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,Eps)
Nlist=Nlist[[1]]
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
IMPLICITDATA<<- Out3
Tmp=proc.time()-starttime
print(paste('ImplicitData obtained : Time =',sprintf("%6.3f",Tmp[1]),sep=''))
starttime=proc.time()
Out4=Cuspsplitpara(Out3,Eps)
CUSPDATA<<- Out4
CUSPPT<<- CUSPSPLITPT
Tmp=proc.time()-starttime
print(paste('CuspData obtained : Time =',sprintf("%6.3f",Tmp[1]),sep=''))
Out5=Borderparadata(Out4,Np,Eps,Eps2)
return(Out5)
}
Meetpoints<- function(PtA,PtB,Uveq,Np,Eps){
Eps0=10^(-4)
Vec=PtB-PtA
if(Norm(Vec)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
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)
}
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){Eps=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,Eps,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,Eps)
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))>Eps) {
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]]Eps){
Par=c(Par,tmp)
tmp2=tmp
}
}
Tmp1=Nohiddenpara2(Par,Fk,1,Np,Eps,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)
Eps=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){Eps=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,Eps,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){Eps=tmp}
if(ctr==2){Eps2=tmp}
}
}
Out=Crv3onsfparadata(FkL,Fbdy3,Fd,Np,Eps,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)
Eps=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){Eps=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,Eps,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,Eps,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)
Eps=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){Eps=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,Eps)
}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)
Eps=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){Eps=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
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)
}
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)