;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 22. DCL: The Graphic User Interface.
(defun display-dialog (dialogname dclfile /)
(if (not *Position*)
(setq *Position* '(-1 -1)))
(if (= -1 (setq dcl_id (load_dialog dclfile)))
(alert (strcat "DCL file not found:\n" dclfile))
(if (not (new_dialog dialogname dcl_id "" *Position*))
(alert
(strcat "Dialog definition not found:\n"
dialogname))
t)))
;;;Listing 22.2. Function that starts a dialog.
(defun display-image (key image)
(start_image key)
(fill_image 0 0 (dimx_tile "img") (dimy_tile "img") -2)
(slide_image 0 0 (dimx_tile key) (dimy_tile key) image)
(end_image))
;;;Listing 22.3. Function that loads a SLD image in a dialog.
(defun param-format (key value /)
(set_tile key (rtos (abs (atof value)) 2 2)))
;;;Listing 22.4. Function that checks and formats edit box values.
(defun param-edit (key value reason / form)
(param-format key value)
(if (or (= reason 1) (= reason 2))
(cond
((= (get_tile "nor") "1") ;Normal case
(test-normal key))
((= (get_tile "nor") "0") ;Other cases
(setq form (form-sel))
(test-other form)))))
;;;Listing 22.5. Parameter edit boxes callback function.
(defun test-other (form / rad-f dim-x dim-y rad-c)
(cond
((= form "sph")
(setq rad-f (atof (get_tile "ra")))
(if (<= rad-f 0)
(setq ok nil)
(progn (setq ok t)
(set_tile "dx" (rtos rad-f 2 2))
(set_tile "dy" (rtos (* rad-f 2) 2 2)))))
((= form "bar")
(setq dim-x (atof (get_tile "dx"))
dim-y (atof (get_tile "dy")))
(if (or (<= dim-x 0) (<= dim-y 0))
(setq ok nil)
(setq ok t)))
((= form "tub")
(setq dim-x (atof (get_tile "dx"))
dim-y (atof (get_tile "dy"))
rad-c (atof (get_tile "rc")))
(if (or (<= dim-x 0) (<= dim-y 0) (<= rad-c 0))
(setq ok nil)
(setq ok t))))
(if ok
(progn (mode_tile "accept" 0) (set_tile "error" ""))
(progn (mode_tile "accept" 1)
(set_tile "error"
"Parameters must be greater than 0"))))
;;;Listing 22.6. Function test-other.
(defun test-1 (rad-f /)
(if (<= rad-f 0)
(progn (setq msg "FilletRadius must be greater than 0")
(setq ok1 nil))
(setq ok1 t)))
(defun test-2 (rad-f dim-y /)
(if (> (* rad-f 2) dim-y)
(progn
(setq msg (strcat "DimY must be greater than "
(rtos (* rad-f 2) 2 2)))
(setq ok2 nil))
(setq ok2 t)))
(defun test-3 (rad-f dim-x)
(if (> rad-f dim-x)
(progn
(setq msg (strcat "DimX must be greater than "
(rtos rad-f 2 2)))
(setq ok3 nil))
(setq ok3 t)))
;;;Listing 22.7. Verification functions test-1, test-2 and test-3.
(defun test-normal (key / dim-x dim-y rad-f msg ok1 ok2 ok3)
(setq dim-x (atof (get_tile "dx"))
dim-y (atof (get_tile "dy"))
rad-f (atof (get_tile "ra")))
(test-1 rad-f)
(test-2 rad-f dim-y)
(test-3 rad-f dim-x)
(cond
((= key "ra") (test-1 rad-f))
((= key "dx") (test-3 rad-f dim-x))
((= key "dy") (test-2 rad-f dim-y)))
(if (and ok1 ok2 ok3)
(progn (mode_tile "accept" 0) (set_tile "error" ""))
(progn (mode_tile "accept" 1) (set_tile "error" msg))))
;;;Listing 22.8. Function test-normal.
(defun form-ops (key value / dim-x dim-y rad-f rad-c)
(cond
((and (= key "nor") (= value "1")) ; NORMAL FORM
(setq dim-x (atof (get_tile "dx"))
dim-y (atof (get_tile "dy"))
rad-f (atof (get_tile "ra")))
(mode_tile "dx" 0)
(mode_tile "dy" 0)
(mode_tile "ra" 0)
(mode_tile "rc" 0)
(if (= rad-f 0)
(set_tile "ra" (rtos (/ dim-x 2) 2 2)))
(if (< dim-y (* rad-f 2))
(set_tile "dy" (rtos (* rad-f 2) 2 2)))
(display-image "img" "./img/nor")
(test-normal "dx"))
((and (= key "sph") (= value "1")) ; SPHERE
(setq dim-x (atof (get_tile "dx"))
rad-f (atof (get_tile "ra")))
(if (= rad-f 0)
(progn (set_tile "ra" (get_tile "dx"))
(setq rad-f dim-x))
(set_tile "dx" (get_tile "ra")))
(set_tile "dy" (rtos (* rad-f 2) 2 2))
(set_tile "rc" "0.00")
(mode_tile "dx" 1)
(mode_tile "dy" 1)
(mode_tile "ra" 0)
(mode_tile "rc" 1)
(display-image "img" "./img/sph")
(test-other key))
((and (= key "bar") (= value "1")) ; BAR
(set_tile "ra" "0.00")
(set_tile "rc" "0.00")
(mode_tile "dx" 0)
(mode_tile "dy" 0)
(mode_tile "ra" 1)
(mode_tile "rc" 1)
(display-image "img" "./img/bar")
(test-other key))
((and (= key "tub") (= value "1")) ; TUBE
(setq rad-c (atof (get_tile "rc")))
(set_tile "ra" "0.00")
(if (= rad-c 0)
(set_tile "rc" (get_tile "dx")))
(mode_tile "dx" 0)
(mode_tile "dy" 0)
(mode_tile "ra" 1)
(mode_tile "rc" 0)
(display-image "img" "./img/tub")
(test-other key))))
;;;Listing 22.9. Callback function to the Predefined Forms radio buttons.
(defun form-sel (/)
(cond
((= (get_tile "nor") "1") "nor")
((= (get_tile "sph") "1") "sph")
((= (get_tile "bar") "1") "bar")
((= (get_tile "tub") "1") "tub")))
;;;Listing 22.10. Detecting the selected predefined form radio_button.
(defun sel-rotation (key value reason / form)
(cond
((= key "ang")
(if (or (= reason 3) (= reason 2) (= reason 1))
(set_tile "inf" value)))
((= key "inf")
(if (or (= reason 2) (= reason 1))
(if (numberp (read value))
(set_tile "ang" value)
(set_tile "inf" (get_tile "ang"))))))
(setq form (form-sel))
(if (= form "nor")
(test-normal "ra")
(test-other form)))
;;;Listing 22.11. Slider callback function.
(defun assign-actions (/)
(action_tile "nor" "(form-ops $key $value)")
(action_tile "sph" "(form-ops $key $value)")
(action_tile "bar" "(form-ops $key $value)")
(action_tile "tub" "(form-ops $key $value)")
(action_tile "dx" "(param-edit $key $value $reason)")
(action_tile "dy" "(param-edit $key $value $reason)")
(action_tile "ra" "(param-edit $key $value $reason)")
(action_tile "rc" "(param-edit $key $value $reason)")
(action_tile
"ang"
"(sel-rotation $key $value $reason)")
(action_tile
"inf"
"(sel-rotation $key $value $reason)")
(action_tile
"accept"
"(setq dim-x (atof (get_tile \"dx\"))
dim-y (atof (get_tile \"dy\"))
rad-f (atof (get_tile \"ra\"))
rad-c (atof (get_tile \"rc\"))
ang-r (atof (get_tile \"ang\"))
form (form-sel)
obj-type (model-type)
*Position* (done_dialog 1)))")
(action_tile
"cancel"
"(setq *Position* (done_dialog 0))"))
;;;Listing 22.12. Assigning callback actions to tiles.
(defun model-type (/)
(if (= (get_tile "sol") "1")
"_SO"
"_SU"))
;;;Listing 22.13. Function that determines the model type.
(defun param-dialog (/ action)
(setvar "DIMZIN" 1)
(if (display-dialog "parametric" "./dcl/parametric.dcl")
(progn (display-image "img" "./img/nor")
(assign-actions)
(setq action (start_dialog))
(if (= action 1)
(param-dwg obj-type dim-x dim-y rad-f rad-c ang-r))
(unload_dialog dcl_id))))
;;;Listing 22.14. Function that activates the dialog box.
(defun bulge (ang /)
(/ (sin (/ ang 4)) (cos (/ ang 4))))
;;;Listing 22.15. Function for calculating the bulge magnitude.
(defun rev-profile (max-x med-x max-y min-y rad-c / pts)
(setq pts (list (list rad-c min-y)
(list med-x min-y)
(list max-x (+ min-y rad-f))
(list max-x (- max-y rad-f))
(list med-x max-y)
(list rad-c max-y)))
(if
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts))
'(70 . 1)
(cons 10 (nth 0 pts))
(cons 10 (nth 1 pts))
(cons 42 (bulge (/ pi 2)))
(cons 10 (nth 2 pts))
(cons 10 (nth 3 pts))
(cons 42 (bulge (/ pi 2)))
(cons 10 (nth 4 pts))
(cons 10 (nth 5 pts))
'(210 0.0 0.0 1.0)))
(setq profile (entlast))))
;;;Listing 22.16. Function that draws the profile as a LWPOLYLINE.
(defun param-dwg (mode dim-x dim-y rad-f rad-c ang-r / max-y min-y max-x med-x pts
profile)
(setq max-y (/ dim-y 2)
min-y (- max-y)
max-x (+ rad-c dim-x)
med-x (- max-x rad-f))
(rev-profile max-x med-x max-y min-y rad-c) ; Profiles
(if profile
(progn
(if (= mode "_SU") ; Model
(progn (setvar "SURFACEMODELINGMODE" 0)
(setvar "SURFACEASSOCIATIVITY" 1)
(vl-cmdf "_AutoConstrain" profile "")))
(vl-cmdf "_REVOLVE" "_MOde" mode profile "" "_Y" ang-r)
(ax-SWt))))
;;;Listing 22.17. Function that creates the 3D model.
(defun C:DCL-PARAM (/ *error*)
(defun *error* ()
(cmd-out)
(command-s "_UNDO" "_End"))
(cmd-in)
(command-s "_UNDO" "_Begin")
(if (= (getvar "WORLDUCS") 0)
(vl-cmdf "_UCS" "_W"))
(param-dialog)
(command-s "_UNDO" "_End")
(cmd-out))
;;;Listing 22.18. Main function C:DCL-PARAM.
No comments:
Post a Comment