;;;-----------------------------
;;; 2000.07.06 sat
;;; 布置指北针
;;;-----------------------------
(defun pm_zbz (/ w_rt_ang w_insp w_tkname w_old_orthomode)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  ;;;(#ppas "pps_tkk")
  (DL_ArxLoad "GalleryManage")
  (setq w_rt_ang (HY_GetNorthDirection)
        w_rt_ang (- w_rt_ang 90.0)
  )
  (if (setq w_tkname (DL_ShowGallery "指北针"))
    (progn
      (setq w_insp (getpoint "\n回车退出 / 点取插入点:"))
      (setq w_old_orthomode (getvar "orthomode"))
      (setvar "orthomode" 0)
      (if w_insp
        (command "_.insert" w_tkname w_insp "" "" w_rt_ang)
      )
      (setvar "orthomode" w_old_orthomode)
    )
  )
  (#ppuas "pps_tkk")
  (pub_re_var)
  (princ)
)
;;;-----------------------------
;;; 1996.10.19 sat
;;; 布置风玫瑰 @bzfmg.lsp
;;;-----------------------------
(defun wwbzfmg
       (/ wjm roseb cityb dcl_id what x y city citym @_col1 @_col2)

  ;;;(HY_SV)
  (hy_set0)
  (setq wjm (DL_GetUserSettingsDir)
        wjm (strcat wjm "\\rose.dat")
  )
  (if (findfile wjm)
    (setq roseb (getdat wjm))
    (progn
      (setq wjm (HY_GetInstallDir)
            wjm (strcat wjm hyszdl_gv_user_dir "\\")
            wjm (strcat wjm "rose.dat")
      )
      (setq roseb (getdat wjm))
    )
  )

  (setq cityb (mapcar 'car roseb))
  (setq citym (car cityb))
  (setq city "0")

  (setq dcl_id (szdl_load_dlg "@bzfmg.dcl"))
  (if (not (new_dialog "bzfmg" dcl_id))
    (exit)
  )

  (start_list "city")
  (mapcar 'add_list cityb)
  (end_list)
  (set_tile "city" city)
  (mode_tile "saveme" 1)
                                        ;----- 显示幻灯 -------------
  (s_img citym roseb)

  (action_tile "city" "(city_0)")

  (action_tile "sm" "(sm)")
  (action_tile "modi" "(modi)")
  (action_tile "saveme" "(saveme)")
  (action_tile "accept" "(done_dialog 1)")
  (action_tile "cancel" "(done_dialog 0)")

  (setq what (start_dialog))
  (unload_dialog dcl_id)

  (if (= what 1)
    (rose-1 citym roseb)
  )

;;;; (HY_RV)
  (HY_Set1)
  (princ)
)
;;-------------------------
;; set image
;;-------------------------
(defun s_img (citym  roseb  /      roseb  x      y      delt   sca
              ii     angt   pt     p00x   p00y   p01x   p01y   p02x
              p02y   p03x   p03y   p04x   p04y   p05x   p05y   p06x
              p06y
             )

  (setq roseb (cdr (assoc citym roseb)))
  (setq sca 5)                          ;*** 放大 ***

  (setq x (dimx_tile "rose"))
  (setq y (dimy_tile "rose"))
  (start_image "rose")
  (fill_image 0 0 x y 0)

  (setq p00x (fix (* 0.5 x))
        p00y (fix (* 0.5 y))
        p01x (- x 10)
        p01y p00y
        p02x p00x
        p02y 10
        p03x 10
        p03y p00y
        p04x p00x
        p04y (- y 10)
        p05x (+ p02x 5)
        p05y (+ p02y 20)
        p06x (- p02x 5)
        p06y (+ p02y 20)

  )
  (vector_image p01x p01y p03x p03y 7)
  (vector_image p02x p02y p04x p04y 7)
  (vector_image p02x p02y p05x p05y 1)
  (vector_image p02x p02y p06x p06y 1)
  (vector_image p05x p05y p06x p06y 1)

  (setq delt (* (/ 22.5 180.0) pi))
                                        ;----- 方向线 ---------------------
  (setq ii 0)
  (setq angt (* 2.0 pi))
  (repeat 32
    (setq pt (polar (list p00x p00y) angt (* sca (nth ii roseb))))
    (vector_image p00x p00y (fix (car pt)) (fix (cadr pt)) 7)
    (setq angt (- angt delt))
    (setq ii (1+ ii))
  )
                                        ;----- 全年 -------
  (setq ii 0)
  (setq angt (* 2 pi))
  (repeat 15
    (setq pt1 (polar (list p00x p00y) angt (* sca (nth ii roseb))))
    (setq pt2 (polar (list p00x p00y)
                     (- angt delt)
                     (* sca (nth (1+ ii) roseb))
              )
    )
    (vector_image
      (fix (car pt1))
      (fix (cadr pt1))
      (fix (car pt2))
      (fix (cadr pt2))
      1
    )
    (setq angt (- angt delt))
    (setq ii (1+ ii))
  )
  (setq pt1 (polar (list p00x p00y) 0.0 (* sca (nth 0 roseb))))
  (vector_image
    (fix (car pt1))
    (fix (cadr pt1))
    (fix (car pt2))
    (fix (cadr pt2))
    1
  )

                                        ;----- 最热月 -------
  (setq ii 16)
  (setq angt (* 2 pi))
  (repeat 15
    (setq pt1 (polar (list p00x p00y) angt (* sca (nth ii roseb))))
    (setq pt2 (polar (list p00x p00y)
                     (- angt delt)
                     (* sca (nth (1+ ii) roseb))
              )
    )
    (vector_image
      (fix (car pt1))
      (fix (cadr pt1))
      (fix (car pt2))
      (fix (cadr pt2))
      3
    )
    (setq angt (- angt delt))
    (setq ii (1+ ii))
  )
  (setq pt1 (polar (list p00x p00y) 0.0 (* sca (nth 16 roseb))))
  (vector_image
    (fix (car pt1))
    (fix (cadr pt1))
    (fix (car pt2))
    (fix (cadr pt2))
    3
  )


  (end_image)

)
;;------------------------------
;; 1996.10.23 wed
;; 选城市
;;------------------------------
(defun city_0 ()

  (setq city (get_tile $key))
  (setq citym (nth (atoi city) cityb))
  (s_img citym roseb)

)
;;--------------------------
;; 数据修改
;;--------------------------
(defun modi (/ what1 ii bb)

  (if (not (new_dialog "modi" dcl_id))
    (exit)
  )

  (set_tile "mm0" citym)
  (setq bb (assoc citym roseb))

  (setq ii 1)
  (repeat 32
    (set_tile (strcat "mm" (itoa ii)) (rtos (nth ii bb)))
    (setq ii (1+ ii))
  )

  (action_tile
    "mm0"
    "(setq bb (lismod bb 0 (get_tile $key)))"
  )
  (setq ii 1)
  (repeat 32
    (action_tile
      (strcat "mm" (itoa ii))
      "(setq bb (lismod bb (atoi (substr $key 3)) (atof (get_tile $key))))"
    )
    (setq ii (1+ ii))
  )
  (action_tile "accept" "(done_dialog 1)")
  (action_tile "cancel" "(done_dialog 0)")

  (setq what1 (start_dialog))

  (if (= what1 1)
    (progn
      (setq roseb (subst bb (assoc citym roseb) roseb))
      (setq citym (car bb))

      (setq cityb (mapcar 'car roseb))

      (start_list "city")
      (mapcar 'add_list cityb)
      (end_list)

      (set_tile "city" city)
                                        ;----- 显示幻灯 -------------
      (s_img citym roseb)
      (mode_tile "saveme" 0)
    )
  )

)
;;------------------------------
;; 1996.10.23 wed
;; save rose.dat
;;------------------------------
(defun saveme (/ ff bb w_wjm)
  (setq w_wjm (DL_GetUserSettingsDir)
        w_wjm (strcat w_wjm "\\rose.dat")
  )
  (setq ff (open w_wjm "w"))
  (foreach bb roseb
    (prin1 bb ff)
    (princ "\n" ff)
  )
  (close ff)
  (mode_tile "saveme" 1)
)

;;------------------------------
;; 绘 ROSE
;;------------------------------
(defun rose-1 (citym  roseb  /      roseb  p00    ang    ang0   dd
               delt   ww     ii     angt   p001   p002   p003   p004
               p005   p006   p007   sca    loopv  if_sol u_num  en0
               ss0
              )
  (DL_MakeLayer "pp-pm-fmg")
  (setq roseb (cdr (assoc citym roseb)))
  (setq sca (DL_GetDrawingFactor))

  (initget 1)
  (setq p00 (getpoint "\n中心位置:"))
  (initget 1)
;;;  (setq ang (getangle p00 "\n北方向:")) 7/6/00 wht
  (setq ang  (HY_GetNorthDirection)
        ang  (dtor ang)
        ang0 (- ang (* 0.5 pi))
  )
;;;  (setq ang0 (- ang (* 0.5 pi))) 7/6/00 wht
;;;ang0 : east
  (setq dd (/ 30.0 sca))
;;;dd   : cross_L
  (setq delt (* (/ 22.5 180.0) pi))
;;;delt : angle_offset
  (setq ww 0.1)
;;;ww   : line_W

  (setq p001 (polar p00 ang0 dd)
;;;p001  : east point
        p002 (polar p00 ang dd)
;;;p002  : north point
        p003 (polar p00 (+ ang0 pi) dd)
;;;p003  : west point
        p004 (polar p00 (+ ang pi) dd)
;;;p004  : south point
                                        ; p005 (polar p002 (+ ang pi) 3.0)        ;;;p005~p007  : arrow
                                        ; p006 (polar p005 ang0 0.5)
                                        ; p007 (polar p005 (+ ang0 pi) 0.5)
  )

  (setq en0 (ent_last))
  (setvar "celtype" "continuous")
  (command "line" p001 p003 "")
  (command "line" p002 p004 "")
                                        ;(command "line" p002 p006 p007 "C")
  (command "text"
           "j"
           "bc"
           (polar p002 ang (/ 3.0 sca))
           (/ 3.0 sca)
           (* (/ ang0 pi) 180.0)
           "N"
  )
                                        ;----- 方向线 -----
  (setq ii     0
        angt   ang0
        er_lst (ssadd)
  )
  (repeat 32
;;;32 to 16
    (command "line"
             p00
             (polar p00 angt (/ (nth ii roseb) sca))
             ""
    )
    (setq er_lst (ssadd (entlast) er_lst))
    (setq angt (+ angt delt))
    (setq ii (1+ ii))
  )
  ;----- 全年 -------
  (setq ii 0)
  (setq angt ang0)
;;;angt=ang0  : east
  (setvar "plinewid" ww)
  (setvar "cecolor" "red")
  (command "pline")
  (repeat 16
    (command (polar p00 angt (/ (nth ii roseb) sca)))
    (setq angt (+ angt delt))
    (setq ii (1+ ii))
  )
  (command "c")
  (setq re_ss (ssadd (entlast)))
                                        ;----- 最热月 -------
  (setq angt ang0)
                                        ;(setvar "celtype" "dashed")
  (setvar "cecolor" "green")
  (command "pline")
  (repeat 16
    (command (polar p00 angt (/ (nth ii roseb) sca)))
                                        ;(setq er_lst (ssadd (entlast) er_lst))
    (setq angt (+ angt delt))
    (setq ii (1+ ii))
  )
  (command "c")
  (HY_KZSJXZ (entlast) nil 6 "dashed")
  (setq er_lst (ssadd (entlast) er_lst))
  (setvar "cecolor" "white")
  (setq ss0 (get_last en0))
                                        ;(prompt"\n缺省填充颜色为蓝黄相间,是否填充?")
  (setq loopv t
        u_num 0
  )
  (while loopv
    (initget "A F U")
    (setq if_sol
           (getkword "\n全部填充A / 间隔填充F / 回退U / <回车退出>:")
    )
    (cond
      ((null if_sol) (setq loopv nil))
      ((= if_sol "U")
       (while (> u_num 0) (HY_UndoB) (setq u_num (- u_num 1)))
       (HY_SSRedraw re_ss 4)
       (prompt "\n填充已被取消!")
      )
      ((= if_sol "A")
       (while (> u_num 1) (HY_UndoB) (setq u_num (1- u_num)))
       (HY_UndoM)
       (command ".erase" er_lst "")
       (setq u_num (1+ u_num))
       (setq @_col1 5
             @_col2 2
       )
       (HY_UndoM)
                                        ;(setq en4 (ent_last))
       (do_tcys)
                                        ;(setq ss4 (get_last en4))
       (HY_SSRedraw re_ss 4)

       (setq u_num (1+ u_num))
       (initget "C R")
       (setq if_c (getkword "\n改颜色C / 返回R / <回车退出>:"))
       (cond
         ((null if_c) (setq loopv nil))
         ((= if_c "R"))
         ((= if_c "C")
          (get_col)
          (while (> u_num 1) (HY_UndoB) (setq u_num (1- u_num)))
          (HY_UndoM)
                                        ;(setq en3 (ent_last))
          (do_tcys)
          (HY_SSRedraw re_ss 4)
                                        ;(setq ss3 (get_last en3))
                                        ;(HY_SSRedraw ss3 4)
          (setq u_num (1+ u_num))
         )
       )
      )
      ((= if_sol "F")
       (while (> u_num 1) (HY_UndoB) (setq u_num (1- u_num)))
       (HY_UndoM)
       (command "erase" er_lst "")
       (setq u_num (1+ u_num))
       (setq @_col1 5
             @_col2 nil
       )
       (HY_UndoM)
                                        ;(setq en1 (ent_last))
       (do_tcys)
       (HY_SSRedraw re_ss 4)
                                        ;(setq ss1 (get_last en1))
                                        ;(HY_SSRedraw ss1 4)
       (setq u_num (1+ u_num))
       (initget "C R")
       (setq if_c (getkword "\n改颜色C / 返回R / <回车退出>:"))
       (cond
         ((null if_c) (setq loopv nil))
         ((= if_c "R"))
         ((= if_c "C")
          (setq @_col1 (acad_colordlg 5 nil))
          (while (> u_num 1) (HY_UndoB) (setq u_num (1- u_num)))
          (HY_UndoM)
                                        ;(setq en2 (ent_last))
          (do_tcys)
          (HY_SSRedraw re_ss 4)
                                        ;(setq ss2 (get_last en2))
                                        ;(HY_SSRedraw ss2 4)
          (setq u_num (1+ u_num))
         )
       )
      )
;;;end cond_F
    )
;;;end all_cond
  )
)
(defun get_col ()
  (if (not @_col1)
    (setq @_col1 5)
  )
  (if (not @_col2)
    (setq @_col2 2)
  )
  (princ "\n请选择第一种填充颜色<")
  (princ @_col1)
  (princ ">:")
  (setq @_col1 (acad_colordlg 5 nil))
  (if @_col1
    (progn
      (princ "\n第一种颜色代码为\"")
      (princ @_col1)
      (princ "\"")
      (princ "\n请选择第二种填充颜色<")
      (princ @_col2)
      (princ ">:")
      (setq @_col2 (acad_colordlg 2 nil))
    )
  )
  (if (or (not @_col1) (not @_col2))
    (setq @_col1 nil
          @_col2 nil
    )
  )
)
(defun do_tcys ()
  (setq angt ang0
        ii   0
  )
  (if (and @_col1 @_col2)
    (progn
      (repeat 15
        (command ".solid"
                 p00
                 (polar p00 angt (/ (nth ii roseb) sca))
                 (polar p00 (+ angt delt) (/ (nth (1+ ii) roseb) sca))
                 ""
                 ""
        )
        (if (= (rem (+ 2 ii) 2) 0)
          (command ".change" "l" "" "p" "c" @_col1 "")
          (command ".change" "l" "" "p" "c" @_col2 "")
        )
        (setq angt (+ angt delt))
        (setq ii (1+ ii))
      )
      (command ".solid"
               p00
               (polar p00 angt (/ (nth ii roseb) sca))
               (polar p00 ang0 (/ (nth 0 roseb) sca))
               ""
               ""
      )
      (command ".change" "l" "" "p" "c" @_col2 "")
    )
  )
  (if (and @_col1 (not @_col2))
    (progn
      (repeat 8
        (command ".solid"
                 p00
                 (polar p00 angt (/ (nth ii roseb) sca))
                 (polar p00 (+ angt delt) (/ (nth (1+ ii) roseb) sca))
                 ""
                 ""
        )
        (command ".change" "l" "" "p" "c" @_col1 "")
        (setq angt (+ angt delt delt))
        (setq ii (+ 2 ii))
      )
    )
  )
)
;;;-------------------------------
(princ)
