jw_cad 外部変形 - (499) clispで矩形を描く -

外部変形は データのやり取りをテキストファイルで行うので プログラム言語は 自由に選ぶことができます。図形は機能的かつシンプルなため、数多くのユーザーに受け入れられています。

 

clispで矩形を描く

:clispで矩形を描く
@echo off
if not exist %~dpn0.lisp (
  for /f "delims=:" %%n in ('findstr /n "^#!" %0') do (
    more +%%n %0 > %~dpn0.lisp
  )
)
clisp %~dpn0.lisp
goto:eof

REM #jww
REM #1-%d 矩形の始点を指示してください
REM #2%d  対頂点を指示してください
REM #e

#!この次の行からプログラムを書いてください
(defun to_f (x) ;文字列 "x" を 数値 xd0 (倍精度 double-float) に変換
  (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)
  )
)
(defun to_s (x) ;数値 xd0 (倍精度 double-float) を 文字列 "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)
  )
)
(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 "^hk" line) (setq hk (cadr a)))
    (if (regexp:match "^hp1" line) (setq p1 (cdr a)))
    (if (regexp:match "^hp2" line) (setq p2 (cdr a)))
  )
  (close f)
)
(progn
  (setq hk (to_f hk))
  (setq x1 (to_f (car p1)))
  (setq y1 (to_f (cadr p1)))
  (setq x2 (to_f (car p2)))
  (setq y2 (to_f (cadr p2)))
  (setq co (cos (* hk (/ pi 180))))
  (setq si (sin (* hk (/ pi 180))))
  (setq ww (+ (* (- x2 x1) co) (* (- y2 y1) si)))
  (setq hh (- (* (- y2 y1) co) (* (- x2 x1) si)))
  (setq x3 (- x1 (* hh si)))
  (setq y3 (+ y1 (* hh co)))
  (setq x4 (+ x1 (* ww co)))
  (setq y4 (+ y1 (* ww si)))
  (setq box (to_s (list x1 y1 x3 y3 x2 y2 x4 y4 x1 y1)))
)
(with-open-file (f "jwc_temp.txt" :direction :output)
  (write-line (format nil "~{ ~a ~,a~%~}" box) f)
  (close f)
)