外部変形は データのやり取りをテキストファイルで行うので プログラム言語は 自由に選ぶことができます。図形は機能的かつシンプルなため、数多くのユーザーに受け入れられています。
vbscriptで楕円弧の長さ(表示画面のｽｹｰﾙ)を計測表示する
:vbscriptで楕円弧の長さ(表示画面のｽｹｰﾙ)を計測表示する
@echo off
if not exist %~dp0eval.vbs echo ExecuteGlobal WScript.StdIn.ReadAll > %~dp0eval.vbs
for /f "delims=:" %%n in ('findstr /n "^#!" %0') do (
copy jwc_temp.txt myfiles > nul
(
: echo Option Explicit
echo On Error Resume Next
: echo On Error GoTo 0
more +%%n %0
) | cscript //nologo %~dp0eval.vbs > jwc_temp.txt
)
goto:eof
REM #jww
REM #1ci 長さを計測する円・円弧を指示してください
REM #bz
REM #e
#!この次の行からプログラムを書いてください
'1)正規表現
Dim re
Set re = New RegExp
re.IgnoreCase = True '大文字と小文字を区別しない
re.Global = True '文字列全体を検索する
function reSplit(str)
re.Pattern = "[ ]+"
reSplit = Split(Trim(re.Replace(str," ")))
end function
function reTest(pat, str)
re.Pattern = pat
reTest = re.Test(str)
end function
'2)円周率
Const PI = 3.141592653589793
'4)ユーザ定義関数
function dec(x)
if x = "a" then x = 10
if x = "b" then x = 11
if x = "c" then x = 12
if x = "d" then x = 13
if x = "e" then x = 14
if x = "f" then x = 15
dec = x
end function
function rad(x)
rad = x / 180 * PI
end function
function cilength(c)
Dim r, p1, p2, w, i, p
if typename(c) = "String" then c = Split(Trim(c))
i = 0
if typename(c(0)) = "String" then
if c(0) = "ci" then i = 1
end if
r = c(2+i)*1.0
if UBound(c) > 2+i then
p1 = c(3+i)*1.0
p2 = c(4+i)*1.0
w = c(5+i)*1.0
else
p1 = 0
p2 = 360
w = 1
end if
if w = 1 then
p = p2 - p1
while p <= 0: p = p + 360: wend
while p > 360: p = p - 360: wend
cilength = r * rad(p)
else
cilength = arc_l(r, p1, p2, w)
end if
end function
function apa(o, p)
apa = (90.0 * (2 * int( (o + 1) / 2) - 1) - p) * (-1) ^ (o - 1)
end function
function arc_l(r, p1, p2, w)
Dim ek, lp, n1, n2, n3, k
if w > 1 then
w = 1 / w
r = r / w
p1 = p1 - 90
p2 = p2 - 90
end if
if w = 1 then
dim p
p = p2 - p1
while p <= 0: p = p + 360: wend
while p > 360: p = p - 360: wend
arc_l = p * PI / 180 * r
exit function
end if
k = sqr(1 - w * w)
ek = elliptic_e(PI / 2, k)
if p1 = p2 then p2 = p2 + 360
lp = int(abs(p2 - p1) / 360.0) * 4.0 * ek
while p1 < 0: p1 = p1 + 360: wend
while p1 >= 360: p1 = p1 - 360: wend
while p2 < 0: p2 = p2 + 360: wend
while p2 >= 360: p2 = p2 - 360: wend
if p1 = p2 then
lp = 4.0 * ek
else
n1 = 1 + int(p1 / 90.0)
if n1 > 4 then n1 = 4
lp = ek * ( (n1 + 1.0) mod 2) + elliptic_e(apa(n1, p1) * PI / 180, k) * (-1.0) ^ (n1 - 1)
n2 = 1 + int(p2 / 90.0)
if n2 > 4 then n2 = 4
if n1 = n2 then n1 = n1 + 4
n3 = 5 + 2 * int( (n2 - 1.0) / 2.0)
lp = lp + ek * ( (n3 - n1) mod 4) + elliptic_e(apa(n2, p2) * PI / 180, k) * (-1.0) ^ n2
if lp < 0.0 then lp = lp + 4.0 * ek
end if
arc_l = r * lp
end function
function elliptic_e(p, k) '第２種楕円積分
if k = 0 then
elliptic_e = p
exit function
end if
dim l, i
for i = 1 to int(Ngauss / 2)
l = l + Hgauss(i) * Sqr(1 - (k * Sin(Egauss(i) * p)) ^ 2)
next
if Ngauss mod 2 = 1 then '奇数個の場合
l = l + Hgauss(Mgauss) * Sqr(1 - (k * Sin(Egauss(Mgauss) * p)) ^ 2) / 2.0
end if
elliptic_e = l * p
end function
sub gauss()
' パソコンで解く骨組み力学／藤谷著／丸善 P.220 より引用しています。
' 引用先のプログラムは Fortran です。VBScript に置き換えています。
Dim I, J, E1, T, X0, PKM1, PK, T1, PKP1
Dim DEN, D1, DPN, D2PN, D3PN, D4PN
Dim U, V, HH, PP, DP, XI, FX, WI
E1 = Ngauss * (Ngauss + 1)
For I = 1 TO Mgauss 'DO 1
T = (4.0 * I - 1.0) * PI / (4.0 * Ngauss + 2.0)
X0 = (1.0 - (1.0 - 1.0 / Ngauss) / (8.0 * Ngauss * Ngauss)) * Cos(T)
PKM1= 1.0
PK = X0
For J = 2 TO Ngauss 'DO 3
T1 = X0 * PK
PKP1= T1 - PKM1 - (T1 - PKM1) / J + T1
PKM1= PK
PK = PKP1
NEXT ' 3
DEN = 1.0 - X0 * X0
D1 = Ngauss * (PKM1 - X0 * PK)
DPN = D1 / DEN
D2PN= (2.0 * X0 * DPN - E1 * PK) / DEN
D3PN= (4.0 * X0 * D2PN + (2.0 - E1) * DPN) / DEN
D4PN= (6.0 * X0 * D3PN + (6.0 - E1) * D2PN) / DEN
U = PK / DPN
V = D2PN / DPN
HH = -U * (1.0 + 0.5 * U * (V + U * (V * V - D3PN / (3.0 * DPN))))
PP = PK + HH * (DPN + 0.5 * HH * (D2PN + HH / 3.0 * (D3PN + 0.25 * HH * D4PN)))
DP = DPN + HH * (D2PN + 0.5 * HH * (D3PN + HH * D4PN / 3.0))
HH = HH - PP / DP
XI =-(X0 + HH)
FX = D1 - HH * E1 * (PK + 0.5 * HH * (DPN + HH / 3.0 * (D2PN + 0.25 * HH * (D3PN + 0.2 * HH * D4PN))))
WI = 2.0 * (1.0 - XI * XI) / (FX * FX)
Egauss(I) = XI
Hgauss(I) = WI
NEXT ' 1
end sub
Dim Ngauss, Mgauss
Ngauss = 150 '積分点数は 60 ～ 300 程度
Mgauss = Int(Ngauss / 2) + Ngauss Mod 2
ReDim Egauss(Mgauss), Hgauss(Mgauss)
Call gauss()
Dim line, F
Dim i, hs(15), plg, lg
Dim ci1, p
lg = ""
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile("myfiles")
Do While Not .AtEndOfStream
line = .ReadLine: F = reSplit(line)
if reTest("^hs",line) then 'hs スケール
for i = 1 to 16
hs(i-1) = F(i)
next
end if
if reTest("^lg[A-F0-9]",line) then 'lg レイヤグループ
plg = LCase(Mid(line,3,1)): if lg = "" then lg = plg
end if
if reTest("^ci",line) then ci1 = F 'ci 指示円
Loop
End With
End With
p = hs(dec(lg)) '/ hs(dec(plg))
WScript.Echo "h#円弧長 L = " & FormatNumber(cilength(ci1) * p, 3, 0,0,0)
