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 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))

(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))

(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))

(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
      (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)

;;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)

;;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"
         :label "Table" 
         :contents ( ( "clear-roots" :label "Clear Table Root"
                       :push (sd-browser-exec-cmd "lisp" :clear-table-roots)))
         :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

    (sd-browser-define-table "lisp" :table-name "table-1" :with-name-column nil
      `((: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"))

    (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"))

    (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)