外部変形は データのやり取りをテキストファイルで行うので プログラム言語は 自由に選ぶことができます。図形は機能的かつシンプルなため、数多くのユーザーに受け入れられています。
clispで２線の交角を計算する
:clispで２線の交角を計算する
@echo off
for /f "delims=:" %%n in ('findstr /n "^#!" %0') do (
more +%%n %0 | clisp -q > nul
)
goto:eof
REM #jww
REM #1%dln 線を指示してください
REM #2%dln 線を指示してください
REM #bz
REM #e
#!この次の行からプログラムを書いてください
;ユーザ定義関数
( ;文字列 "x" を 数値 xd0 (倍精度 double-float) に変換
defun to_f (x)
(if (equal x nil) (setq x "0"))
(if (listp x)
(mapcar #'to_f x)
(progn
(if (typep x 'double-float)
x
(progn
(if (stringp x) nil (setq x (write-to-string x)))
(if (search "e" x)
(progn
(setq s (search "e" x))
(read-from-string
(concatenate 'string (subseq x 0 s) "d" (subseq x (+ 1 s) (length x)))
)
) ;progn (search "e" x)
(if (search "d" x)
x
(read-from-string
(concatenate 'string x "d0")
)
)
)
) ;progn (typep x 'double-float)
)
) ;progn (listp x)
)
)
( ;数値 xd0 (倍精度 double-float) を 文字列 "x" に変換
defun to_s (x)
(if (equal x nil) (setq x 0))
(if (listp x)
(mapcar #'to_s x)
(progn
(if (stringp x) nil (setq x (write-to-string x)))
(if (search "d0" x)
(subseq x 0 (search "d" x))
(if (search "d" x)
(progn
(setq s (search "d" x))
(concatenate 'string (subseq x 0 s) "e" (subseq x (+ 1 s) (length x)))
)
x
)
)
) ;progn (listp x)
)
)
( ;線長を返す
; x : (x1 y1 x2 y2)
defun lnlength (x)
(setq x1 (to_f (nth 0 x)))
(setq y1 (to_f (nth 1 x)))
(setq x2 (to_f (nth 2 x)))
(setq y2 (to_f (nth 3 x)))
(sqrt (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1))))
)
( ;線角を返す
; x : (x1 y1 x2 y2)
defun lnslope (x)
(setq x1 (to_f (nth 0 x)))
(setq y1 (to_f (nth 1 x)))
(setq x2 (to_f (nth 2 x)))
(setq y2 (to_f (nth 3 x)))
(atan (- y2 y1) (- x2 x1))
)
( ;線と点の最短距離を返す
; ln : (x1 y1 x2 y2)
; hp : (x y)
defun ln_hpdist (ln hp)
(setq x (append hp (subseq ln 0 2)))
(* (lnlength x) (sin (- (lnslope ln) (lnslope x))))
)
( ;線の吸着点を返す
; ln : (x1 y1 x2 y2)
; hp : (x y)
defun ln_hpsnap (ln hp)
(setq s (ln_hpdist ln hp))
(setq d (lnslope ln))
(list
(to_s (+ (to_f (nth 0 hp)) (* s (sin d))))
(to_s (- (to_f (nth 1 hp)) (* s (cos d))))
)
)
( ;線と線の交点を返す
; ln1 : (x1 y1 x2 y2)
; ln2 : (x3 y3 x4 y4)
defun inters (ln1 ln2)
(setq x1 (to_f (nth 0 ln1)))
(setq y1 (to_f (nth 1 ln1)))
(setq x2 (to_f (nth 2 ln1)))
(setq y2 (to_f (nth 3 ln1)))
(setq dx1 (- x2 x1))
(setq dy1 (- y2 y1))
(setq m1 (if (= dx1 0d0) 1d20 (/ dy1 dx1)))
(setq x3 (to_f (nth 0 ln2)))
(setq y3 (to_f (nth 1 ln2)))
(setq x4 (to_f (nth 2 ln2)))
(setq y4 (to_f (nth 3 ln2)))
(setq dx2 (- x4 x3))
(setq dy2 (- y4 y3))
(setq m2 (if (= dx2 0d0) 1d20 (/ dy2 dx2)))
(setq aa (- m1 m2))
(if (= aa 0d0)
(list "he処理できません")
(progn
(setq u1 (- y1 (* m1 x1)))
(setq u2 (- y3 (* m2 x3)))
;(list (to_s (/ (- u2 u1) aa)) (to_s (/ (- (* m1 u2) (* m2 u1)) aa)))
(to_s (list (/ (- u2 u1) aa) (/ (- (* m1 u2) (* m2 u1)) aa)))
)
)
)
;本文
(setq pi (* (atan 1d0 1d0) 4)) ;3.141592653589793d0
( ;jwc_temp.txt から 入力
with-open-file (f "jwc_temp.txt" :direction :input)
(loop for line = (read-line f nil) while line do
(setq a (regexp:regexp-split "\\s\\+" line))
(if (regexp:match "^hp1" line) (setq hp1 (cdr a)))
(if (regexp:match "^hp2" line) (setq hp2 (cdr a)))
(if (regexp:match "^hhp1ln" line) (setq n 1))
(if (regexp:match "^hhp2ln" line) (setq n 2))
(if (regexp:match "^\\s\\+" line)
(progn
(if (= n 1) (setq ln1 (cdr a)))
(if (= n 2) (setq ln2 (cdr a)))
)
)
)
)
( ;準備計算
progn
(setq pc (inters ln1 ln2))
(if (= (length pc) 2)
(progn
(setq p1 (ln_hpsnap ln1 hp1))
(setq p2 (ln_hpsnap ln2 hp2))
(setq d1 (lnslope (append pc p1)))
(setq d2 (lnslope (append pc p2)))
(setq xang (* (- d2 d1) (/ 180 pi)))
)
(setq xang -900)
)
(if (= (signum (- xang 180)) 1) (setq xang (- xang 360)))
(if (= (signum (+ xang 180)) -1) (setq xang (+ xang 360)))
)
( ;jwc_temp.txt へ 出力
with-open-file (g "jwc_temp.txt" :direction :output)
(if (> xang -720)
(format g "h#２線の交角 = ∠~,6fﾟ : d1=~,6fﾟ : d2=~,6fﾟ~%" xang (* d1 (/ 180 pi)) (* d2 (/ 180 pi)) )
)
)
