#|
Gbrowser example
Note: This is an example file showing concepts of the Integration Kit.
The code itself is not supported and will never be supported.
|#
(in-package :browser-example)
(use-package :oli)
;;define the clientData structure
(defstruct interrogator
(primary-pixmap "GB Test Pinned")
(secondary-pixmap nil)
(display-in-graphics t)
(display-in-table t)
(is-sensitive t)
(is-selectable t)
(is-expandable t)
(display-name nil)
(drag-source t)
(drag-target t)
(can-be-dropped t) ;;not very meaningful, provided for completeness
(enum-type "PART")
)
(defun test-tree()
;;test function to build a tree
(let (root a2 a4 a1 p1 p3 p4 p5 a3)
(setq root (sd-create-browsernode :tree "lisp-tree" :parent nil
:objClientData (make-interrogator :drag-source nil)))
(setq a2 (sd-create-browsernode :tree "lisp-tree" :parent root
:objPname "A2" :objClientData
(make-interrogator :display-name "No Drag Source"
:drag-source nil :enum-type "ASSEMBLY")))
(setq a4 (sd-create-browsernode :tree "lisp-tree" :parent root
:objPath "/A4" :objPname "a4" :objClientData
(make-interrogator :is-sensitive nil
:is-expandable nil)))
(setq a1 (sd-create-browsernode :tree "lisp-tree" :parent root
:objPath "/A1" :objPname "a1" :objClientData
(make-interrogator)))
;;make five children
(dotimes (x 5)
(sd-create-browsernode :tree "lisp-tree" :parent a1
:objPname (format nil "test~A" x) :objClientData
(make-interrogator :enum-type "PART")))
(setq p1 (sd-create-browsernode :tree "lisp-tree" :parent root
:objPath "/P1" :objPname "p1" :objClientData
(make-interrogator :display-in-graphics nil
:is-expandable nil
:primary-pixmap "GB Test Unpinned"
:enum-type "FEATURE")))
(setq a3 (sd-create-browsernode :tree "lisp-tree" :parent a2
;;:objPath "/A2/A3"
:objPname "a3" :objClientData
(make-interrogator :enum-type "ASSEMBLY")))
(setq p4 (sd-create-browsernode :tree "lisp-tree" :parent a1
:objPath "/A1/P4" :objPname "p4" :objClientData
(make-interrogator :is-selectable nil
:display-name "Non Selectable"
:is-expandable nil
:enum-type "REL-SET")))
(setq p3 (sd-create-browsernode :tree "lisp-tree" :parent a1
:objPath "/A1/P3" :objPname "p3" :objClientData
(make-interrogator :display-in-graphics nil
:is-expandable nil
:primary-pixmap "GB Test Unpinned")))
(setq p5 (sd-create-browsernode :tree "lisp-tree" :parent a3
:objPath "/A2/A3/P5" :objPname "p5" :objClientData
(make-interrogator :display-in-graphics t
:is-expandable nil
:drag-target nil
:primary-pixmap "GB Test Unpinned"
:display-name "No Target")))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;interrogator functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-pixmap(obj name)
(interrogator-primary-pixmap (browsernode-objclientdata obj))
)
(defun get-sec-pixmap(obj name)
(when (interrogator-is-expandable (browsernode-objclientdata obj))
(if (sd-query-browser name :is-object-expanded obj)
"GB Test On"
"GB Test Off"
)
)
)
(defun get-display-in-graphics(obj name)
(interrogator-display-in-graphics (browsernode-objclientdata obj))
)
(defun get-display-in-table(obj name)
(if (interrogator-display-in-table (browsernode-objclientdata obj))
t
nil)
)
(defun get-is-sensitive(obj name)
(interrogator-is-sensitive (browsernode-objclientdata obj))
)
(defun get-is-selectable(obj name)
(interrogator-is-selectable (browsernode-objclientdata obj))
)
(defun get-is-expandable(obj name)
(interrogator-is-expandable (browsernode-objclientdata obj))
)
(defun get-display-name(obj name)
(interrogator-display-name (browsernode-objclientdata obj))
)
(defun get-object-name(obj name)
(browsernode-objpname obj)
)
(defun get-drag-source(obj name)
(interrogator-drag-source (browsernode-objclientdata obj))
)
(defun get-drag-target(obj name)
;;(interrogator-drag-target (browsernode-objclientdata obj))
t
)
(defun get-can-be-dropped(source target name)
(interrogator-drag-target (browsernode-objclientdata target))
)
(defun get-drag-cursor(object name)
t ; t for single, nil for multi
)
(defun border-color(obj name)
(if (interrogator-is-expandable (browsernode-objclientdata obj))
"green"
nil
)
)
(setq enum-list '("PART" "ASSEMBLY" "FEATURE" "REL-SET" "JUNK"))
(defun get-enum(obj name &aux type)
(setq type (interrogator-enum-type (browsernode-objclientdata obj)))
(position type enum-list :test #'equal)
)
(defun edit-enum(obj name new-val &aux tmp)
(setq tmp (nth new-val enum-list))
(if tmp
(progn
(setf (interrogator-enum-type (browsernode-objclientdata obj)) tmp)
;;normally this refresh should not be required, but this is a special
;;case test
(sd-browser-exec-cmd name :refresh-tree nil t)
)
nil
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;click action functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun do-drag (source target name &aux s-name t-name)
(setq s-name (browsernode-objpath source))
(setq t-name (browsernode-objpath target))
(print (format nil "Drag ~A to ~A" s-name t-name))
(if (sd-query-browser name :is-descendent target source )
(print (format nil "~A is child of ~A" s-name t-name))
(print (format nil "~A is not child of ~A" s-name t-name))
)
)
(defun sec-icon-click(obj name)
(if (sd-query-browser name :is-object-expanded obj)
(sd-browser-exec-cmd name :set-object-expansion obj nil)
(sd-browser-exec-cmd name :set-object-expansion obj t)
)
)
(defun dbl-click(obj name)
(sd-browser-exec-cmd name :clear-table-roots)
(sd-browser-exec-cmd name :change-table-root obj t)
)
(defun shift-click2(object name)
(print (format nil "shift-click on ~A" (browsernode-objpath object)))
)
(defun menu-action(object name)
(if object
(print (format nil "popup menu pick on ~A" (browsernode-objpath object)))
(print "popup menu picked on no object")
)
)
(defun display-name(object name)
(browsernode-objpname object)
)
(defun is-visible(obj name)
t
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;create the browser tree and graphical browser with limited UI
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun test-lisp-browser()
;;destroy old ones first
(sd-destroy-graphical-browser "lisp")
(sd-destroy-browser-tree "lisp-tree")
;;define the tree
(sd-create-browser-tree "lisp-tree"
:update-events *SD-CHANGE-OBJECT-TREE-EVENT* :update-func 'test-tree)
;;construct a browser
(sd-create-graphical-browser "lisp" :tree "lisp-tree"
:topLabel "Test Browser"
:topmenu
'(
("table"
:label "Table"
:contents ( ( "clear-roots" :label "Clear Table Root"
:push (sd-browser-exec-cmd "lisp" :clear-table-roots)))
)
("test"
:label "test"
:contents ( ("button1" :label "button1" :push (print "button1"))
("button2" :label "button2" :push (print "button2"))
)
:mutualexclusion ("button1" "button2")
))
)
;; add all possible interrogators
(sd-browser-add-interrogator "lisp" :interrogator-type :primary-pixmap
:interrogator-func 'get-pixmap)
(sd-browser-add-interrogator "lisp" :interrogator-type :secondary-pixmap
:interrogator-func 'get-sec-pixmap)
(sd-browser-add-interrogator "lisp" :interrogator-type
:display-in-graphics :interrogator-func 'get-display-in-graphics)
(sd-browser-add-interrogator "lisp" :interrogator-type :display-in-table
:interrogator-func 'get-display-in-table)
(sd-browser-add-interrogator "lisp" :interrogator-type :is-sensitive
:interrogator-func 'get-is-sensitive)
(sd-browser-add-interrogator "lisp" :interrogator-type :is-selectable
:interrogator-func 'get-is-selectable)
(sd-browser-add-interrogator "lisp" :interrogator-type :is-expandable
:interrogator-func 'get-is-expandable)
(sd-browser-add-interrogator "lisp"
:interrogator-type :table-display-name
:interrogator-func 'get-display-name)
(sd-browser-add-interrogator "lisp"
:interrogator-type :tree-display-name
:interrogator-func 'get-display-name)
(sd-browser-add-interrogator "lisp" :interrogator-type :drag-source
:interrogator-func 'get-drag-source)
(sd-browser-add-interrogator "lisp" :interrogator-type :drag-target
:interrogator-func 'get-drag-target)
(sd-browser-add-interrogator "lisp" :interrogator-type :can-be-dropped
:interrogator-func 'get-can-be-dropped)
(sd-browser-add-interrogator "lisp" :interrogator-type :drag-cursor-single
:interrogator-func 'get-drag-cursor)
(sd-browser-add-interrogator "lisp" :interrogator-type :border-color
:interrogator-func 'border-color)
;;add some click handlers
(sd-browser-click-action "lisp"
:action-type :drag
:mask nil
:button :button1
:action-func 'do-drag)
(sd-browser-click-action "lisp"
:action-type :single-click
:mask '(:shift)
:button :button2
:action-func 'shift-click2)
(sd-browser-click-action "lisp"
:action-type :sec-icon-click
:action-func 'sec-icon-click)
(sd-browser-click-action "lisp"
:action-type :multi-click
:action-func 'dbl-click)
;;add a menu entry
(sd-browser-add-popup-entry "lisp" :menu-action 'menu-action
:is-entry-visible 'is-visible
:label "my entry")
;;execute some browser commands
(sd-browser-exec-cmd "lisp" :display-secondary-icon t)
;;define a table
(unless
(sd-browser-define-table "lisp" :table-name "table-1" :with-name-column nil
:column-definition
`((:label "Pixmap" :max-width 15 :type
:string-column :display-func get-pixmap
:clipping t)
(:label "second Pixmap" :type :boolean-column
:display-func get-sec-pixmap :print-values ("On" "Off")
:clipping t :justification :right)
(:label "Object Name" :display-func get-object-name
:justification :left)
(:label "GraphicsDisplay" :initial-width 5 :type :boolean-column
:display-func get-display-in-graphics)
(:label "Table Display" :type :boolean-column
:display-func get-display-in-table)
(:label "Enum Test" :type :enum-column :display-func get-enum
:edit-func edit-enum :print-values ,enum-list )
)
)
(sd-display-error "table-1 failed"))
(unless
(sd-browser-define-table "lisp" :table-name "table-2"
:with-name-column t :column-definition
'((:label "Pixmap" :initial-width 5 :type
:string-column )))
(sd-display-error "table-2 failed"))
(unless
(sd-browser-define-table "lisp" :table-name "table-3"
:with-name-column nil :column-definition
'((:label "Pixmap" :initial-width 5 :type
:string-column :display-func display-name)))
(sd-display-error "table-3 failed"))
(sd-browser-set-active-table "lisp" :table-name "table-1")
(sd-browser-exec-cmd "lisp" :set-dual-mode)
;; register images
(sd-browser-register-image "lisp"
:image "GB Test Pinned"
:filename "bitmaps/lock.xbm"
:type :primary-pixmap
:foreground "white"
:background *sd-command-color*)
(sd-browser-register-image "lisp"
:image "GB Test Unpinned"
:filename "bitmaps/key.xbm"
:type :primary-pixmap
:foreground "white"
:background *sd-command-color*)
(sd-browser-register-image "lisp"
:image "GB Test Off"
:filename "pixmaps/off_drawlist.pm"
:type :secondary-pixmap
:foreground "white"
:background *sd-command-color*)
(sd-browser-register-image "lisp"
:image "GB Test On"
:filename "pixmaps/on_drawlist.pm"
:type :secondary-pixmap
:foreground "white"
:background *sd-command-color*)
;;display the browser
(sd-show-graphical-browser "lisp")
;;set table root
(oli:sd-browser-exec-cmd "lisp" :change-table-root
(oli:sd-get-BrowserNode-struct "lisp-tree" :root)
t)
)
(test-lisp-browser)
;;;