(defun c:ufc00002 ( / eps epe ss1 nn1 ente1 enls1 pk1 pk2 wclen
                      ss2 nn2 pp1 pp2 nc ente enls fin cpn cpn1 cpn2
                      eat lay lnk col ) 
;線分カット
;最初に選択された線分で次以降に選択された線分をカットする
  (setq eps 0.001)
  (setq epe 0.0000001)
  (prompt "\nカットする線分を選択(１線分)：")
  (setq ss1 (ssget '((0 . "LINE")) )) ;線分を選択
  (setq nn1 0)
  (if (/= ss1 nil)
    (progn
      (setq nn1 (sslength ss1))
      (setq ente1 (ssname ss1 0))
      (setq enls1 (entget ente1)) 
      (setq pk1 (cdr (assoc 10 enls1)))
      (setq pk2 (cdr (assoc 11 enls1)))
    )
  )
  (if (/= nn1 1)
    (prompt "\n最初の選択は１線分を選択して下さい。")
    (progn
      (initget (+ 2 4))
      (setq wclen (getreal (strcat "\nカットする幅を入力：")))
      (if (/= wclen nil)
        (progn
          (prompt "\nカットされる線分を選択（複数線分可）：")
          (setq ss2 (ssget '((0 . "LINE")) )) ;線分を選択
          (setq nn2 0)
          (if (/= ss2 nil)
            (setq nn2 (sslength ss2))
          )
          (setq pp1 (list 0.0 0.0 0.0))
          (setq pp2 (list 0.0 0.0 0.0))
          (command "pan" "none" pp1 "none" pp2 ) 'undo１回分戻るためのダミーコマンド
          (setq nc 0)
          (repeat nn2
            (setq ente (ssname ss2 nc))
            (setq nc (+ nc 1))
            (if (and (/= ente nil) (/= ente ente1))
              (progn
                (setq enls (entget ente))
                (if (/= enls nil)
                  (progn
                    (setq pp1 (cdr (assoc 10 enls)))
                    (setq pp2 (cdr (assoc 11 enls)))
                    (setq fin (ufb00006 pk1 pk2 pp1 pp2 eps epe))
                    (if (= fin nil)
                      (prompt "\n交点が見つかりません。")
                      (progn
                        (setq cpn (ufc00002a pp1 pp2 fin wclen eps epe))
                        (setq cpn1 (car  cpn))
                        (setq cpn2 (cadr cpn))
                        (if (or (/= cpn1 nil) (/= cpn2 nil))
                          (progn
                            (setq eat (ufl00003 ente))
                            (if (/= eat nil)
                              (progn
                                (setq lay (nth 0 eat))
                                (setq lnk (nth 1 eat))
                                (setq col (nth 2 eat))
                                (if (= col nil)
                                  (setq col 256)
                                )
                                (if (= lnk nil)
                                  (setq lnk "BYLAYER")
                                )
                                (entdel ente)
                                (if (/= cpn1 nil)
                                  (ufl00004 (car cpn1) (cadr cpn1) lay lnk col)
                                )
                                (if (/= cpn2 nil)
                                  (ufl00004 (car cpn2) (cadr cpn2) lay lnk col)
                                )
                              )
                            )
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (princ)
)
(defun ufc00002a ( u_st  ;線分の始点
                   u_en  ;線分の終点
                   u_cp  ;カットする位置
                   u_cl  ;カットする幅
                   u_eps ;許容誤差
                   u_epe ;許容誤差（規格化用）
                 / ps1   ;線分１の始点
                   pe1   ;線分１の終点
                   ps2   ;線分２の始点
                   pe2   ;線分２の終点
                         ;   出力リスト構造
                         ;     (setq plen (list (list ps1 pe1) (list ps2 pe2)))
                         ;     線分が２線分とも求まらないとき:(nil nil)
                         ;     線分が１線分しか求まらないとき:((ps1 pe1) nil)
                         ;                             または:((ps2 pe2) nil)
                   plen pepl vec pep l2 xx yy l2e lenl len1 len2 )
;カットする位置を中心に指定された幅分線分をカットした後の２線分の座標を求める
  (setq plen (list nil nil))
  (setq pepl (ufc00002b u_st u_en u_cp u_eps u_epe))
  (if (and (/= pepl nil) (> u_cl u_eps))
    (progn
      (setq vec (ufb00001 u_st u_en u_eps))
      (if (/= vec nil)
        (progn
          (setq pep (cadr pepl))
          (setq l2 (/ u_cl 2.0))
          (setq ps1 u_st)
          (setq xx (- (car  pep) (* l2 (car  vec))))
          (setq yy (- (cadr pep) (* l2 (cadr vec))))
          (setq pe1 (list xx yy 0.0))
          (setq xx (+ (car  pep) (* l2 (car  vec))))
          (setq yy (+ (cadr pep) (* l2 (cadr vec))))
          (setq ps2 (list xx yy 0.0))
          (setq pe2 u_en)
          (setq plen (list (list ps1 pe1) (list ps2 pe2)))
          (setq l2e (+ l2 u_eps))
          (setq xx (- (car  u_en) (car  u_st)))
          (setq yy (- (cadr u_en) (cadr u_st)))
          (setq lenl (sqrt (+ (* xx xx) (* yy yy))))
          (setq xx (- (car  u_st) (car  pep)))
          (setq yy (- (cadr u_st) (cadr pep)))
          (setq len1 (sqrt (+ (* xx xx) (* yy yy))))
          (setq xx (- (car  u_en) (car  pep)))
          (setq yy (- (cadr u_en) (cadr pep)))
          (setq len2 (sqrt (+ (* xx xx) (* yy yy))))
          (if (and (<= len1 l2e) (> len2 l2e))
            (setq plen (list (list ps2 pe2) nil))
          )
          (if (and (> len1 l2e) (<= len2 l2e))
            (setq plen (list (list ps1 pe1) nil))
          )
          (if (and (<= len1 l2e) (<= len2 l2e))
            (setq plen (list nil nil))
          )
        )
      )
    )
  )
  plen
)
(defun ufc00002b ( u_st  ;線分の始点
                   u_en  ;線分の終点
                   u_pr  ;垂線を求めるための点
                   u_eps ;許容誤差
                   u_epe ;許容誤差（規格化用）
                 / lper  ;線分までの距離
                   perp  ;垂線の座標
                         ;   出力リスト構造
                         ;     (setq pero (list lper perp))
                         ;     pero が nil:線分の始点終点が同一点
                   pero xx yy len vec vx vy epe pc pp vxl vyl xx yy )
;垂線を下した部分の座標値と距離を求める
  (setq pero nil)
  (setq xx (- (car  u_en) (car  u_st)))
  (setq yy (- (cadr u_en) (cadr u_st)))
  (setq len (sqrt (+ (* xx xx) (* yy yy))))
  (if (> len u_eps)
    (progn
      (setq vec (ufb00001 u_st u_en u_eps))
      (if (/= vec nil)
        (progn
          (setq vx (car  vec))
          (setq vy (cadr vec))
          (setq epe (/ u_eps len))
          (setq pc (list 0.0 0.0 0.0))
          (setq pp (list vx vy 0.0))
          (setq aa -90.0)
          (setq rvc (ufb00007 pp pc aa))
          (setq vxl (car  rvc))
          (setq vyl (cadr rvc))
          (setq xx (+ (* len vxl) (car  u_pr)))
          (setq yy (+ (* len vyl) (cadr u_pr)))
          (setq pp (list xx yy 0.0))
          (setq perp (ufb00004 u_st u_en u_pr pp u_eps u_epe))
          (if (/= perp nil)
            (progn
              (setq xx (- (car  perp) (car  u_pr)))
              (setq yy (- (cadr perp) (cadr u_pr)))
              (setq lper (sqrt (+ (* xx xx) (* yy yy))))
              (setq pero (list lper perp))
            )
          )
        )
      )
    )
  )
  pero
)
(defun ufb00001 ( u_p1  ;線分の始点
                  u_p2  ;線分の終点
                  u_eps ;許容誤差
                / vv    ;単位ベクトル（２次元）　Ｚ成分は０．０
                        ; nil:単位ベクトルが算出できないとき
                        ;     始点と終点が同一点（Ｚ＝０平面）
                  xx yy ll vx vy zv )
;単位ベクトルを求める（２次元）
  (setq vv nil)
  (setq xx (- (car  u_p2) (car  u_p1)))
  (setq yy (- (cadr u_p2) (cadr u_p1)))
  (setq ll (sqrt (+ (* xx xx) (* yy yy))))
  (if (> ll u_eps)
    (progn
      (setq vx (/ (- (car  u_p2) (car  u_p1)) ll))
      (setq vy (/ (- (cadr u_p2) (cadr u_p1)) ll))
      (setq vz 0.0)
      (setq vv (list vx vy vz))
    )
  )
  vv
)
(defun ufb00003 ( u_p1  ;線分の始点
                  u_p2  ;線分の終点
                  u_eps ;許容誤差
                / abc   ;直線の方程式　(car abc)*x+(cadr abc)*y=c
                        ; nil:方程式が求まらない
                        ;     始点と終点が同一点
                  xx yy ll aa bb cc )
;直線の方程式を求める
  (setq abc nil)
  (setq xx (- (car  u_p2) (car  u_p1)))
  (setq yy (- (cadr u_p2) (cadr u_p1)))
  (setq ll (sqrt (+ (* xx xx) (* yy yy))))
  (if (> ll u_eps)
    (progn
      (setq aa (/ (- (cadr u_p1) (cadr u_p2)) ll))
      (setq bb (/ (- (car  u_p2) (car  u_p1)) ll))
      (setq cc (/ (- (* (- (car  u_p2) (car  u_p1)) (cadr u_p1))
                     (* (- (cadr u_p2) (cadr u_p1)) (car  u_p1))) ll))
      (setq abc (list aa bb cc))
    )
  ) 
  abc
)
(defun ufb00004 ( u_p1  ;線分１の始点
                  u_p2  ;線分１の終点
                  u_p3  ;線分２の始点
                  u_p4  ;線分２の終点
                  u_eps ;許容誤差
                  u_epe ;許容誤差（規格化用）
                / pc    ;交点
                        ; nil:交点が求まらない
                        ;     始点と終点が同一点
                  abc1 abc2 a1 b1 c1 a2 b2 dd c2 xc yc )
;無限線分と無限線分の交点を求める
  (setq pc nil)
  (setq abc1 (ufb00003 u_p1 u_p2 u_eps))
  (setq abc2 (ufb00003 u_p3 u_p4 u_eps))
  (if (and (/= abc1 nil) (/= abc2 nil))
    (progn
      (setq a1 (car   abc1))
      (setq b1 (cadr  abc1))
      (setq c1 (caddr abc1))
      (setq a2 (car   abc2))
      (setq b2 (cadr  abc2))
      (setq c2 (caddr abc2))
      (setq dd (- (* a1 b2) (* b1 a2)))
      (if (> (abs dd) u_epe)
        (progn
          (setq xc (/ (- (* b2 c1) (* b1 c2)) dd))
          (setq yc (/ (- (* a1 c2) (* a2 c1)) dd))
          (setq pc (list xc yc 0.0))
        )
      )
    )
  ) 
  pc
)
(defun ufb00005 ( u_p1  ;線分１の始点（無限線分）
                  u_p2  ;線分１の終点（無限線分）
                  u_p3  ;線分２の始点（有限線分）
                  u_p4  ;線分２の終点（有限線分）
                  u_eps ;許容誤差
                  u_epe ;許容誤差（規格化用）
                / pc    ;交点
                        ; nil:交点が求まらない
                        ;     始点と終点が同一点
                  pw xx yy ll m1 m2 )
;無限線分と有限線分の交点を求める
  (setq pc nil)
  (setq pw (ufb00004 u_p1 u_p2 u_p3 u_p4 u_eps u_epe))
  (if (/= pw nil)
    (progn
      (setq xx (- (car  u_p4) (car  u_p3)))
      (setq yy (- (cadr u_p4) (cadr u_p3)))
      (setq ll (sqrt (+ (* xx xx) (* yy yy))))
      (setq xx (- (car  u_p3) (car  pw)))
      (setq yy (- (cadr u_p3) (cadr pw)))
      (setq m1 (sqrt (+ (* xx xx) (* yy yy))))
      (setq xx (- (car  u_p4) (car  pw)))
      (setq yy (- (cadr u_p4) (cadr pw)))
      (setq m2 (sqrt (+ (* xx xx) (* yy yy))))
      (setq lw (- (+ m1 m2) u_eps))
      (if (> ll lw)
        (setq pc pw)
      )
    )
  ) 
  pc
)
(defun ufb00006 ( u_p1  ;線分１の始点
                  u_p2  ;線分１の終点
                  u_p3  ;線分２の始点
                  u_p4  ;線分２の終点
                  u_eps ;許容誤差
                  u_epe ;許容誤差（規格化用）
                / pc    ;交点
                        ; nil:交点が求まらない
                        ;     始点と終点が同一点
                  pw xx yy ll m1 m2 )
;有限線分と有限線分の交点を求める
  (setq pc nil)
  (setq pw (ufb00005 u_p1 u_p2 u_p3 u_p4 u_eps u_epe))
  (if (/= pw nil)
    (progn
      (setq xx (- (car  u_p2) (car  u_p1)))
      (setq yy (- (cadr u_p2) (cadr u_p1)))
      (setq ll (sqrt (+ (* xx xx) (* yy yy))))
      (setq xx (- (car  u_p1) (car  pw)))
      (setq yy (- (cadr u_p1) (cadr pw)))
      (setq m1 (sqrt (+ (* xx xx) (* yy yy))))
      (setq xx (- (car  u_p2) (car  pw)))
      (setq yy (- (cadr u_p2) (cadr pw)))
      (setq m2 (sqrt (+ (* xx xx) (* yy yy))))
      (setq lw (- (+ m1 m2) u_eps))
      (if (> ll lw)
        (setq pc pw)
      )
    )
  ) 
  pc
)
(defun ufb00007 ( u_p1  ;回転前の点
                  u_pc  ;回転中心
                  u_aa  ;回転角度（度）
                / p2    ;回転後の点
                  aa xl1 yl1 xl2 yl2 x2 y2 )
;回転した座標値を求める
  (setq aa (/ (* u_aa PI) 180.0))
  (setq xl1 (- (car  u_p1) (car  u_pc)))
  (setq yl1 (- (cadr u_p1) (cadr u_pc)))
  (setq xl2 (- (* (cos aa) xl1) (* (sin aa) yl1)))
  (setq yl2 (+ (* (sin aa) xl1) (* (cos aa) yl1)))
  (setq x2 (+ (car  u_pc) xl2))
  (setq y2 (+ (cadr u_pc) yl2))
  (setq p2 (list x2 y2 0.0))
  p2
)
(defun ufl00003 ( u_entn ;エンティティ名
                / out    ;(list lay lnkd col)
                  lay    ;画層名
                  lnkd   ;線種
                  col    ;色番号
                  enls )
;画層名、線種、色を得る
  (setq out nil)
  (setq lay nil)
  (setq lnkd nil)
  (setq col nil)
  (if (/= u_entn nil)
    (progn
      (setq enls (entget u_entn))
      (if (/= enls nil)
        (progn
          (setq lay (cdr (assoc 8 enls)))
          (setq lnkd (cdr (assoc 6 enls)))
          (setq col (cdr (assoc 62 enls)))
          (setq out (list lay lnkd col))
        )
      )
    )
  )
  out
)
(defun ufl00004 ( u_pp1 ;始点座標
                  u_pp2 ;終点座標
                  u_lay ;画層名
                  u_lnk ;線種名
                  u_col ;色番号
                / )
;線分を作図する
  (entmake  (list (cons 0 "LINE")
                  (cons 8 u_lay)
                  (cons 6 u_lnk)
                  (cons 62 u_col)
                  (cons 10 u_pp1)
                  (cons 11 u_pp2)
            )
  )
)