;;;-------------------<宿題投稿>------------------------------------
;;;
;;;   あるTEXTの文字列を任意の位置で切断し、配置するというプログラム
;;;
;;;  2001.03.30                                  Programed by mapcar
;;;  2001.04.03                                  少し進化
;;;-----------------------------------------------------------------
;;楽しみ方：
;;    宿題の方向性とは少し違っていますが、操作の手間を少なくする方向で
;;    工夫してみました。すなわち、
;;       (Step1) コマンド発行 (c:txtsep)
;;       (Step2) テキスト図形を切りたい場所で指示
;;    となっています。
;;    通常ならテキスト図形指示と切る文字数を入力しなくてはならず、3
;;    ステップ以上かかるところを2ステップで完了しています。
;;    分割後は元テキストのすぐ上に分割したテキストが生成されます。
;;    図形のグリップをつかんで所定の位置に配置します。
;;    ２バイト文字対応です。
;;------------------------------------------------------------------
;;    テキストの幅を取得しているので、分割前と同じ体裁を保つことが
;;    できるようになっています。"WAKU" の文字列のある行のコメントを
;;    外すと、テキストのまわりに枠を描画します(少し進化)。
;;    J オプションで作られたテキストへの対応は A/F/C/TC/MC/BC 以外は
;;    対応できますが、ソースが煩雑になるので割愛しました。
;;    対応しているのはJオプションなしのテキスト図形のみです。
;;    任意の座標系、ビュー、突き出し方向に対応しています(の筈)。
;;    縦書きは未対応です。
;;    縦書きとJオプションに対応して完成とする予定です。
;;;-----------------------------------------------------------------

(defun c:txtsep ; 指示されたテキスト図形を指定位置で分割、再配置する 2001.03.30
  (
  /
    ent en ety typ j72 j73 txtl0 ppll ppl1 areal1 areal2 
    pe0 qe0 idx len pe1 h0 hh th ux uy txt0 txtl txt1 
  )
    (setq ent (entsel "テキストを指示(分割位置直後の文字を指示):"))
    (if (setq en (car ent)) (progn
        (setq ety (entget en))
        (setq typ (= (cdr (assoc 0 ety)) "TEXT")) ; テキストに限る
        (setq j72 (= (cdr (assoc 72 ety)) 0)) ; Jなしテキストに限る
        (setq j73 (= (cdr (assoc 73 ety)) 0)) ; Jなしテキストに限る
        (if (and typ j72 j73) (progn
            (setq txtl0 (c_str2codel (cdr (assoc 1 ety)))) ; 文字リストを取得
            (setq ppll (get_txt_endp txtl0 ety 0.25)) ; テキスト領域構成頂点を求める
            (setq ppl1 (car ppll) ppl2 (cadr ppll))
;            (print (list 'ppl2= ppl2))
            (setq areal1 (mapcar '(lambda ( p0 p1 p3 p2 / res ) ; 矩形に変形
                 (list p0 p1 p2 p3)
            ) (car ppl1) (cdr (car ppl1)) (cadr ppl1) (cdr (cadr ppl1))))

            (setq areal2 (mapcar '(lambda ( p0 p1 p3 p2 / pp qq) ; 矩形に変形
                (setq pp (list p0 p1 p2 p3))
                (setq qq (mapcar '(lambda ( pj ) (trans pj en 1)) pp))
;;WAKU          (command "3dpoly") (mapcar 'command qq) (command  "c") ; コメントを外すと矩形を描画します。
                pp
            ) (car ppl2) (cdr (car ppl2)) (cadr ppl2) (cdr (cadr ppl2))))

            (setq pe0 (cdr (assoc 10 ety))) ; テキスト原点(ECS)
            (setq qe0 (get_ent_plane_pt pe0 en (cadr ent))) ;entsel 点をテキストに付着(ECS)させる
;           (command "circle" (trans qe0 en 1) 25) ; 付着確認

            (setq idx (get_area_idx qe0 areal1)) ; 指定した文字の領域を特定する
            (setq len (/ idx 2))                   ; 文字数に換算
            (setq pe1 (car (nth idx areal1))) ; 分割後の右側テキスト原点
            (setq h0 (cdr (assoc 40 ety)))
            (setq hh (* 1.2 h0)) ; テキスト高さ(２割増し)
            (setq hh (list hh hh hh)) ; 分割後テキストへの位置差分
            (setq th (cdr (assoc 50 ety)))              ; 回転角度
            (setq ux (list (cos th) (sin th) 0.0))      ; テキスト右方向取得
            (setq uy (list (- (cadr ux)) (car ux) 0.0)) ;テキスト高さ方向取得
            (setq txt0 "")
            (setq txtl txtl0)
;            (print (list 'txtl0= txtl))
            (repeat len ; 前半文字列を組み立てる
                (setq txt0 (strcat txt0 (car txtl)))
                (setq txtl (cdr txtl))
;                (print (list 'txtl= txtl))
            )
            (setq txt1 (apply 'strcat txtl)) ; 残りの文字列を組み立てる
;           (setq pe0 (mapcar '+ pe0 (mapcar '* ux hh)))
            (setq pe0 (mapcar '+ pe0 (mapcar '* uy hh)))
            (setq pe1 (mapcar '+ pe1 (mapcar '* uy hh)))
;           (setq pe1 (get_Rtext_pt txtl0 len pe0 th (* h0 xs))) ; 右側テキストの基点を得る 2001.04.02
;            (getpoint pe0)
;            (getpoint pe1)
            (drw_text_at_pt ety txt0 pe0)
            (drw_text_at_pt ety txt1 pe1)
        ))
    ))
    (princ)
)

(defun get_area_idx ; 点の所属する矩形エリア番号を返す ;2001.04.03
  (
    pt  ; 点
    ppl ; 頂点リストのリスト
  /
    res
  )
    (setq res (mapcar '(lambda ( pp ) (is_in_area pt pp)) ppl))
    (- (length res) (length (member T res)))
)

(defun is_in_area ; 凸多角形内に点が含まれるかを判定する
  (
    pt  ; 点
    pp  ; 凸多角形構成点
  /
    res
  )
    (setq res (mapcar '(lambda ( p0 p1 / vv )
        (setq vv (c_outer (mapcar '- p1 p0) (mapcar '- pt p0)))
        (> (last vv) 0.0)
    ) pp (append (cdr pp) (list (car pp)))))
    (apply 'and res)
)

(defun drw_text_at_pt ;基点指定でテキストを生成する
  (
    ety
    txt
    p0
  /
    en q0 q1 vv res
  )
    (setq res (entmake (subst (cons 1 txt) (assoc 1 ety) ety)))
    (setq ety (entget (setq en (entlast))))
    (setq q0 (cdr (assoc 10 ety)) q1 (cdr (assoc 11 ety)))
    (setq vv (mapcar '- p0 q0)) ; 仮置きからのずれ
    (setq q0 (mapcar '+ q0 vv) q1 (mapcar '+ q1 vv))
    (setq ety (subst (cons 10 q0) (assoc 10 ety) ety))
    (setq ety (subst (cons 11 q1) (assoc 11 ety) ety))
    (entmod ety)
    (entupd en)
)

(defun get_txt_endp ; テキスト領域頂点を求める 2001.04.03
  (
    txtl ; 文字のリスト
    ety
    mar ; ゼロ幅文字の調整係数
  /
    h0 xs style pchl xxl xxl2 th ux uy p0 pp0 dy pp1 p0 pp2 h1 pp3 
  )
    (setq h0 (cdr (assoc 40 ety)))
    (setq xs (cdr (assoc 41 ety)))
    (setq style (cdr (assoc 7 ety))) (setq style (if style style "Standard"))
    (setq pchl (get_txt_pitch txtl style)) ; 文字列展開幅リストを取得
    (setq pchl (mapcar '(lambda ( pch ) (* pch h0 xs)) pchl)) ; 実幅に調整
    (setq xxl '(0.0)) (mapcar '(lambda ( pch ) ; ピッチを座標値に変換
        (setq xxl (append xxl (list (+ (last xxl) pch))))
    ) pchl)
    (setq xxl2 (pich_adjust xxl mar)) ; 文字囲み範囲用座標を作成

    (setq th (cdr (assoc 50 ety)))
    (setq ux (list (cos th) (sin th) 0.0))      ; テキスト右方向取得
    (setq uy (list (- (cadr ux)) (car ux) 0.0)) ;テキスト高さ方向取得
    (setq p0 (cdr (assoc 10 ety)))
    (setq pp0 (mapcar '(lambda ( xx / dx ) ; ベースライン頂点
        (mapcar '+ p0 (mapcar '* ux (list xx xx xx)))
    ) xxl))
    (setq dy (mapcar '* uy (list h0 h0 h0)))
    (setq pp1 (mapcar '(lambda ( pj ) (mapcar '+ pj dy)) pp0)) ; トップ頂点

    (setq p0 (mapcar '+ p0 (mapcar '* dy '(-0.1 -0.1 -0.1))))
    (setq pp2 (mapcar '(lambda ( xx / dx ) ; 囲み頂点下
        (mapcar '+ p0 (mapcar '* ux (list xx xx xx)))
    ) xxl2))
    (setq h1 (* h0 1.2))
    (setq dy (mapcar '* uy (list h1 h1 h1)))
    (setq pp3 (mapcar '(lambda ( pj ) (mapcar '+ pj dy)) pp2)) ; トップ頂点
    (list (list pp0 pp1) (list pp2 pp3))
)

(defun pich_adjust ; ピッチ調整 2001.04.03
  ( ; ゼロピッチの文字は両端の空白から領域をもらう
    xxl ; Ｘ座標リスト
    mar ; 空隙調整率
  /
    aa spl chl dx 
  )
    (setq aa (reverse (cdr (reverse (cdr xxl)))))
    (while aa
        (setq spl (cons  (list (car aa) (cadr aa)) spl))
        (setq aa (cddr aa))
    )
    (setq aa xxl)
    (while aa 
        (setq chl (cons (list (car aa) (cadr aa)) chl))
        (setq aa (cddr aa))
    )
    (setq aa (mapcar '(lambda ( ab ) (- (cadr ab) (car ab))) spl))
    (setq dx (* mar (apply 'min  aa))) ; 最小空隙を基準とする
    (setq chl (mapcar '(lambda ( ab ) ; 文字端を広げる
        (list (- (car ab) dx) (+ (cadr ab) dx))
    ) (reverse chl)))
    (apply 'append chl)
)

(defun get_Rtext_pt ; 右側テキストの基点を得る 2001.04.02
  ( ; 文字が引っかかるまで成長させる方式
    txtl
    len
    p0
    th
    scale
  /
    style pchl xx
  )
    (setq style (cdr (assoc 7 ety)))
    (setq style (if style style "Standard"))
    (setq pchl (get_txt_pitch txtl style)) ; 文字列展開幅リストを取得
    (setq xx 0.0) 
    (repeat (* 2 len) (setq xx (+ xx (car pchl)) pchl (cdr pchl)))
    (setq xx (* scale xx))
    (mapcar '+ p0 (list (* xx (cos th)) (* xx (sin th)) 0.0))
)

(defun get_ent_plane_pt ; entsel 点をエンティティに付着させる
  (
    p0  ; エンティティ原点
    en  ; エンティティ
    qv0 ; そのビューでの entsel 点(UCS)
  /
    qv1 qe0 qe1 qe2 qe3 
  )
    (setq qv1 (mapcar '+ qv0 (getvar "VIEWDIR")))
    (setq qe0 (trans qv0 1 en))
    (setq qe1 (trans qv1 1 en))
    (setq qe2 (list (car qe0) (cadr qe0) (caddr p0)))
    (setq qe3 (list (car qe1) (cadr qe1) (caddr p0)))
    (inters qe0 qe1 qe2 qe3 nil)
)

(defun get_pickbox_pp ; ピックボックス端点リストを取得する
  (
    pc ; 中心位置
  /
    aa bb
  )
    (setq aa (c_p2u (getvar "PICKBOX")))
    (setq bb (- aa))
    (setq pc (mapcar '+ (trans pc 1 2) '(0 0)))
    (list (mapcar '+ pc (list bb bb)) (mapcar '+ pc (list aa bb))
          (mapcar '+ pc (list aa aa)) (mapcar '+ pc (list bb aa)))
)

(defun c_str2codel ; 文字列→文字単位リスト
  (
    str ; <str1> 任意の文字列
  /
    ii   ; <int>  インデックス
    code ; <str>  文字コード
    res  ; <list> 結果
  )
    (setq ii 0)
    (while (/= (strlen (setq code (substr str (setq ii (1+ ii)) 1))) 0)
        (if (or (and (>= (ascii code) (+ 256 -128)) (<= (ascii code) (+ 256 -97)))
                (and (>= (ascii code) (+ 256  -32)) (<= (ascii code) (+ 256  -1))))
            (progn ; SJIS漢字コードの場合、次の1ﾊﾞｲﾄは強制抽出する
                (setq res (cons (substr str ii 2) res))
                (setq ii (1+ ii))
            )
            (setq res (cons code res))
        )
    )
    (reverse res)
)

(defun get_txt_cross_len_old ; 前半文字数を求める 2001.03.30
  (
    ety0
    txtl ; 文字リスト
    pp   ; 選択ポリゴン
  /
    en qq txtl txt ety
  )
    (entmake ety0) ; 交差チェック用図形を生成する
    (setq en (entlast))
;   (setq qq (mapcar '(lambda ( pj ) (trans pj 2 1)) pp))
;   (mapcar 'getpoint qq)
    (while (member en (get_sscp_enl pp))
        (setq txtl (reverse (cdr (reverse txtl))))
        (setq txt (apply 'strcat txtl))
        (setq ety (entget en))
        (setq ety (subst (cons 1 txt) (assoc 1 ety) ety))
;       (print (list 'txt_get_txt_cross_len_= txt))
        (entmod ety)
        (entupd en)
    )
    (entdel en)
    (length txtl)
)

(defun get_sscp_enl ; クロスポリゴンで図形を取得する
  (
    pp
  /
    qq ss ii res 
  )
    (setq qq (mapcar '(lambda ( pj ) (trans pj 2 1)) pp))
    (if (setq ss (ssget "CP" qq)) ; なぜか UCS値を与えると正常動作...
        (repeat (setq ii (sslength ss))
            (setq res (cons (ssname ss (setq ii (1- ii))) res))
        )
    )
    res
)

(defun get_txt_pitch ; テキストの文字展開幅を取得する 2001.03.31
  (
    txtl  ; 文字単位文字リスト
    style ; 文字スタイル名
  /
    ety en wwl0 wwl1 res 
  )
    (setq ety '((0 . "TEXT")         ; (固定) テキスト
                (100 . "AcDbEntity") ; (固定) サブクラス マーカー(AcDbText)
                (67 . 0)             ; (固定) =0:ModelSpace, =1:PaperSpace
                (410 . "Model")      ; (固定)
                (8 . "0")            ; (固定) Layer
                (100 . "AcDbText")   ; (固定) サブクラス マーカー(AcDbText)
                (10  0.0 0.0 0.0)    ; (追従) 第1位置合わせ点(OCS)
                (40 . 1.0)           ; (固定) 文字の高さ
                (1 . "")             ; (代入) 文字列本体
                (50 . 0.0)           ; (固定) 回転角
                (41 . 1.0)           ; (追従) 相対尺度
                (51 . 0.0)           ; (固定) 傾斜角度
                (7 . "Standard")     ; (継承) 文字スタイル名
                (71 . 0)             ; (固定) 鏡像文字フラグ
                (72 . 2)             ; (固定) 水平方向の位置合わせタイプ =2:右寄せ
                (11 0.0 0.0 0.0)     ; (固定) 第2位置合わせ点(OCS)
                (210 0.0 0.0 1.0)    ; (固定) 突出方向
                (100 . "AcDbText")   ; (固定) サブクラス マーカー(AcDbText)
                (73 . 0)             ; (固定) 垂直方向の位置合わせタイプ 
    ))
    (setq ety (subst (cons 7 style) (assoc 7 ety) ety)) ; 文字スタイルを継承する
    (if (entmake ety) (progn
        (setq ety (entget (setq en (entlast))))
        (setq wwl0 (mapcar '(lambda ( ch ) ; 各文字の展開幅を取得する
            (setq ety (subst (cons 1 ch) (assoc 1 ety) ety))
            (entmod ety)
            (setq ety (entget (setq en (entlast))))
            (- (car (cdr (assoc 10 ety))))
        ) txtl))
        (setq wwl1 (mapcar '(lambda ( c0 w0 c1 w1 ) ;文字間隔を取得する
            (setq ety (subst (cons 1 (strcat c0 c1)) (assoc 1 ety) ety))
            (entmod ety)
            (setq ety (entget (setq en (entlast))))
            (- (- (car (cdr (assoc 10 ety)))) w0 w1)
        ) txtl wwl0 (cdr txtl) (cdr wwl0)))
        (setq res (list (car wwl0)) wwl0 (cdr wwl0))
        (mapcar '(lambda ( w1 w0 )
            (setq res (append res (list w1)))
            (setq res (append res (list w0)))
        ) wwl1 wwl0)
        (entdel (cdr (assoc -1 ety)))
    ))
    res
)

;;-----(自前ライブラリより)-----------------------------------------
(defun c_p2u ; ピクセルを長さに変換する
  (
    pixel ; <int> ピクセル数
  )
    (* pixel (/ (* 1.0 (getvar "VIEWSIZE")) (* 1.0 (cadr (getvar "SCREENSIZE")))))
)
(defun c_inner ( v0 v1 ) (apply '+ (mapcar '* v0 v1))) ; ベクトル内積 2000.04.15

(defun c_vlength ( vv ) (distance '(0 0 0) vv)) ; ベクトル長さを求める 2000.12.04

(defun c_vscale ( sc vv ) (mapcar '* (list sc sc sc) vv)) ; ベクトルのスカラー倍

(defun c_uv ( vv ) ; 単位ベクトルを求める 2000.04.15
    (c_vscale (/ 1.0 (c_vlength vv)) vv)
)

(defun c_outer  ; ベクトル外積 2000.04.15
  ( v0 v1 / x0 y0 z0 x1 y1 z1)
    (mapcar 'set '(x0 y0 z0) v0)
    (mapcar 'set '(x1 y1 z1) v1)
    (list (- (* y0 z1) (* z0 y1))
          (- (* z0 x1) (* x0 z1))
          (- (* x0 y1) (* y0 x1))
    )
)

(defun c_ez2ijk ; ECS座標系 ijk を得る 2000.12.04
  ( vz ) ; AutoLISP内ではこのほうがシンプル(久々の進化)
    (list (trans '(1 0 0) vz 0) (trans '(0 1 0) vz 0) (trans '(0 0 1) vz 0))
)

(princ "\nコマンド名は txtsep です。")
(princ)