外部変形は データのやり取りをテキストファイルで行うので プログラム言語は 自由に選ぶことができます。図形は機能的かつシンプルなため、数多くのユーザーに受け入れられています。
clispでソリッド図形のＨ形鋼断面を描く
:clispでソリッド図形のＨ形鋼断面を描く
@echo off
set s=%*
if defined s (
echo ^%*> %~dpn0.txt
) else (
if exist %~dpn0.txt (
for /f "tokens=*" %%a in (%~dpn0.txt) do set s=%%a
)
)
if not defined s set s=400 200 8 13 16
for /f "delims=:" %%n in ('findstr /n "^#!" %0') do (
more +%%n %0 | clisp -q > nul
)
goto:eof
REM #jww
REM #1%d 位置を指示して下さい
REM #99#
REM #c H B T1 T2 R =
REM #e
#!この次の行からプログラムを書いてください
;ユーザ定義関数
;文字列 str の old に一致する部分を new で置き換える
(defun gsub (old new str)
(let (s e)
(if (search old str)
(progn
(setq s (search old str))
(setq e (+ s (length old)))
(setq str (concatenate 'string (subseq str 0 s) new (subseq str e)))
(gsub old new str)
)
str
)
))
;リストを平坦化する : 引用
(defun flatten (ls)
(cond ( (null ls) nil)
( (atom ls) (list ls))
(t (append (flatten (car ls)) (flatten (cdr ls))))))
( ;文字列 "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" を 整数に変換
defun to_i (x)
(if (numberp x)
(* (signum x) (floor (abs x)))
(progn
(if (equal x nil) (setq x "0"))
(if (listp x)
(mapcar #'to_i x)
(progn
(if (stringp x) nil (setq x (write-to-string x)))
(parse-integer x)
)
)
)
)
)
;点 pt を 相対距離 (x y) 移動する
(defun moveto (pt x &optional (y nil) (d nil))
(let (xy i j)
(setq xy (if y (list x y) x))
(unless (listp xy) (setq xy (list x 0)))
(setq pt (flatten (to_f pt)))
(setq xy (flatten (to_f xy)))
; (if (equal d nil) (setq d (to_f y)))
; (setq xy (rot xy d))
(if xy
(loop for i in pt
for j in xy
collect (+ i j)
)
x
)
))
(
defun ptrot (d x y)
(setq co (cos (* d (/ pi 180))))
(setq si (sin (* d (/ pi 180))))
(multiple-value-setq (x1 y1 x2 y2) (values-list (append x y)))
(list (- (* (+ x1 x2) co) (* (+ y1 y2) si))
(+ (* (+ x1 x2) si) (* (+ y1 y2) co)))
)
(
defun offset (w h pt)
(setq opt 5)
(list
(* (/ w 2) (- (mod (- 9 pt) 3) (mod (- 9 opt) 3)))
(* (/ h 2) (- (to_i (/ (- 9 pt) 3))
(to_i (/ (- 9 opt) 3))) )
)
)
(
defun jish_sl (hp a b tw tf &optional (r 0) (d *hk*) (pt 5))
(multiple-value-setq (a b tw tf r) (values-list (to_f (list a b tw tf r))))
(setq u 5)
(setq p0 (offset b a pt))
(setq p (list
(list (/ tw 2) (- (/ a 2) tf (* r 0)))
(list (+ (/ tw 2) r) (- (/ a 2) tf r))
(list (+ (/ tw 2) r) (- (/ a 2) tf))
(list (/ b 2) (- (/ a 2) tf))
(list (/ b 2) (/ a 2))
)
)
(setq out (format nil "~a~%" "pl"))
;(setq pp (list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
(setq pp (loop for i to 19 collect i)) ;リストの作成
(loop for j from 0 to 3
do
(setq a (* 90 (mod (- 1 j) 4)))
(loop for i from 0 to (- u 1)
do
(setq k (if (= (mod j 2) 0) i (- u i 1)))
(multiple-value-setq (x y) (values-list (nth k p)))
(setq px (if (/= (mod j 3) 0) (- x) x))
(setq py (if (> j 1) (- y) y))
(setq pc (moveto hp (ptrot d (list px py) p0)))
(if (and (= k 1) (> r 0))
(progn
(setq pc (append pc (list r 1 (* d (/ pi 180)) (* a (/ pi 180)) (/ pi 2) -1)))
(setq out (concatenate 'string out (format nil "sc~{ ~a~}~%" (to_s pc))))
)
)
(setf (nth (+ i (* j u)) pp) pc) ;リストの要素に値を代入 setf 式
)
)
(setq r1 (append (nth 0 pp) (nth 9 pp) (nth 10 pp) (nth 19 pp)))
(setq r2 (append (nth 3 pp) (nth 4 pp) (nth 5 pp) (nth 6 pp)))
(setq r3 (append (nth 13 pp) (nth 14 pp) (nth 15 pp) (nth 16 pp)))
(setq out (concatenate 'string out (format nil "sl~{ ~a~}~%" (to_s r1))))
(setq out (concatenate 'string out (format nil "sl~{ ~a~}~%" (to_s r2))))
(setq out (concatenate 'string out (format nil "sl~{ ~a~}~%" (to_s r3))))
(setq out (concatenate 'string out (format nil "~a~%" "#")))
out
)
;本文
(setq pi (* (atan 1d0 1d0) 4)) ;円周率 を 倍精度実数値 double-float で 再定義する
(setq hp '( (0 0)))
(setq hpn 1)
(with-open-file (f "jwc_temp.txt" :direction :input)
(loop for line = (read-line f nil) while line do
(setq a (regexp:regexp-split " \\+" line))
(if (regexp:match "^hk" line) (setq hk (cadr a)))
;指示点データ
(if (regexp:match "^hp[1-9][0-9]\\?\\(ln\\|ci\\|ch\\)\\?-\\?" line)
(progn
(setq hpn (gsub "hp" "" (car a)))
(setq hpn (gsub "ln" "" hpn))
(setq hpn (gsub "ci" "" hpn))
(setq hpn (gsub "ch" "" hpn))
(setq hpn (gsub "#" "" hpn))
(setq hpn (parse-integer (gsub "-" "" hpn)))
(if (>= (- hpn (length hp)) 0)
(loop for i to (- hpn (length hp)) do
(setq hp (append hp '( (0 0))))
)
)
(setf (elt hp hpn) (cdr a))
)
)
)
)
( ;準備計算
progn
(setq *hk* (to_f hk))
(setq n (- (length hp) 1))
(setq s (regexp:regexp-split " \\+" (ext:getenv "s")))
(setq h (to_f (nth 0 s)))
(setq b (to_f (nth 1 s)))
(setq t1 (to_f (nth 2 s)))
(setq t2 (to_f (nth 3 s)))
(setq r (to_f (nth 4 s)))
(multiple-value-setq (red green blue) (values 0 128 128))
)
( ;jwc_temp.txt へ 出力
with-open-file (f "jwc_temp.txt" :direction :output)
(format f "lc10 ~a~%" (+ red (* 256 green) (* 256 256 blue)))
(loop for i to n
do
(if (> i 0)
(write-line (jish_sl (elt hp i) h b t1 t2 r) f)
)
)
)
