CLIM mail archive
[Prev][Next][Index][Thread]
question on table-formatting + graphics
CLIM 1.1 ACL 4.1
I inherited an editor from a previous programmer. The code was developed on
a Symbolics with CLIM 1.1 and showed the same problem that I have on ACL.
We have a workaround but I would prefer to find the solution or rewrite if
necessary.
Our editor has two columns of information which the user can link together
by selecting an item in column one and one in column two. A line is drawn
between the two items to show the link explicitly. Unfortunately, the
_display_ of the lines interferes with the items in the column. When you
run your mouse down the column, the lower items in the column will no longer
be selectable once the links are displayed. We added a flag to control the
display of the links. When the links are present but no drawn to the pane,
all items in the columns can be selected. When the same links are drawn on
the pane (using draw-line*), the lower items in the list will once again
become inaccessable.
We are using table formatting to build the columns. I assume that we are
somehow interfering with the table by overlaying graphics. Can anyone give
me any further information here? I have included code for a simple test
case based on our editor below.
We are about to port our code to CLIM 2.0. Is this problem likely to
persist in CLIM 2.0? If this problem will go away in CLIM 2.0, I won't
worry about doing a rewrite now. Our changeover to CLIM 2.0 isn't simple;
we have to upgrade our operating system which also means that ACL 4.1 will
no longer work on the upgraded machines. We also have major demos for our
project this month just to keep life interesting.
Thanks in advance for you help.
Marilyn
------------------------------------------------------------------
Marilyn Bunzo NASA Ames Research Center
msb@eos.arc.nasa.gov Mailstop 269-6
Sterling Software Bldg. 269 Room 152
(415) 604-0426 Moffett Field, CA 94035
;;;-*- Syntax: Common-Lisp; Package: clim-user; Base: 10; Mode: LISP -*- ;;;
(in-package :clim-user)
(defvar *clim-root-1* (open-root-window :clx))
(defvar *top-level-test-ct* (define-command-table top-level-test-ct))
(define-gesture-name *left-button* :button :left)
;;Class for the parent slots (left hand column)
(defclass test-option ()
((value :initform nil :initarg :value :accessor test-option-value)
(right :initform nil :initarg :right :accessor slot-basics-right)
(left :initform nil :initarg :left :accessor slot-basics-left)
(middle :initform nil :initarg :middle :accessor slot-basics-middle)
(selected :initform nil :accessor test-option-selected))
(:documentation "Test item for display."))
;;Class for the child slots (right column)
(defclass child-test-option (test-option)
()
(:documentation "Child test item for display."))
;;Presentation types
(define-presentation-type test-option ())
(define-presentation-type child-test-option ()
:inherit-from 'test-option)
;;Link record
(defclass test-link ()
((child :initarg :child :accessor child)
(child-x :initform 0 :initarg :child-x :accessor child-x)
(child-y :initform 0 :initarg :child-y :accessor child-y)
(parent :initarg :parent :accessor parent)
(parent-x :initform 0 :initarg :parent-x :accessor parent-x)
(parent-y :initform 0 :initarg :parent-y :accessor parent-y)
)
(:documentation "class defining links between parent and child nodes"))
;;Simple example of table-formatted linking editor
(define-application-frame test-editor ()
((parent-slots :initarg :parent-slots :accessor parent-slots)
(child-slots :initarg :child-slots :accessor child-slots)
(selected-parent-slot :initform nil :accessor selected-parent-slot)
(selected-child-slot :initform nil :accessor selected-child-slot)
(selected-link :initform nil :accessor selected-link)
(all-links :initarg :all-links :initform nil
:accessor all-links)
(display-links :initarg :display-links :initform nil
:accessor display-links)
(display-table :initarg :display-table :initform nil
:accessor display-table))
(:command-table (top-level-test-ct))
(:panes
((title
:title
:display-string "Decomposition Method Editor"
:default-text-style '(:fix :bold :large)
:scroll-bars nil)
(menu-bar
:command-menu
:default-text-style '(:fix :bold :normal)
:scroll-bars nil)
(work-area
:application
:default-text-style '(:fix :roman :normal)
:display-function 'display-structure
:incremental-redisplay nil
:scroll-bars ':both)))
(:documentation
"Basic test editor class definition"))
(defmethod set-selection-parent ((editor test-editor)
(parent test-option))
"Set the parent selection and unselect the previous parent."
(with-slots (selected-parent-slot ) editor
(when (not (test-option-selected parent)) ;not currently selected
(if selected-parent-slot
(setf (test-option-selected selected-parent-slot) nil))
(setf (test-option-selected parent) t
selected-parent-slot parent))))
(defmethod set-selection-child ((editor test-editor)
(child child-test-option))
"Set the child selection and unselect the previous child."
(with-slots (selected-child-slot ) editor
(when (not (test-option-selected child)) ;not currently selected
(if selected-child-slot
(setf (test-option-selected selected-child-slot) nil))
(setf (test-option-selected child) t
selected-child-slot child))))
(defmethod display-linkage ((editor test-editor) pane)
;;Display the links, after the table is drawn
(loop for link in (all-links editor)
do (draw-line* pane
(parent-x link)
(parent-y link)
(child-x link)
(child-y link))))
(defmethod display-structure ((application test-editor)
pane)
"Display the table structures and links (based on flag value)."
(with-slots ( selected-parent-slot selected-child-slot
child-slots parent-slots all-links
display-table display-links) application
;;Format the two lists of options using table coumns
(format pane "~2& ")
(setf display-table
(formatting-table (pane :inter-column-spacing 75)
(formatting-column (pane)
(with-text-face (:bold pane)
(formatting-cell (pane :align-x :center :minimum-width 100)
(format pane "List 1")))
(dolist (slot parent-slots)
(formatting-cell (pane :align-x :right)
(draw-test-slot slot application pane))))
(formatting-column (pane)
(with-text-face (:bold pane)
(formatting-cell (pane :align-x :center :minimum-width 100
)
(format pane "List 2" )))
(dolist (slot child-slots)
(formatting-cell (pane :align-x :left)
(draw-test-slot slot application pane))))
))
;;When flag is set, display links between columns
(when display-links
(find-link-positions-when-needed application)
(display-linkage application pane))
))
(defmethod draw-test-slot ((slot test-option) (editor test-editor) pane)
"Draw the slot as a presentation."
(let ((print-string (format nil "~a" (test-option-value slot))))
(with-output-as-presentation (:stream pane
:object slot
:type (class-name (class-of slot))
:single-box t)
(cond ((test-option-selected slot)
(with-text-face ('(:bold) pane)
(format pane print-string)))
(t (with-text-face (:roman pane)
(format pane print-string)))))))
(defun find-slot-location (base-record column row)
"Find the slot location based on the table."
(let* ((column-record (aref (slot-value base-record 'clim::elements) column))
(row-record (aref (slot-value column-record 'clim::elements) row)))
(values (bounding-rectangle-right row-record)
(bounding-rectangle-left row-record)
(+(bounding-rectangle-bottom row-record)
(/ (bounding-rectangle-height row-record) 2))
)))
(defmethod find-link-positions-when-needed ((editor test-editor))
"Find new link positions only when values not yet set."
(with-slots (all-links) editor
(when (and all-links
(or (not (slot-boundp (car all-links) 'child-x))
(some #'zerop (mapcar #'parent-x all-links))
(some #'zerop (mapcar #'child-x all-links))))
(generate-link-positions editor))))
(defmethod generate-link-positions ((editor test-editor))
"Find the positions for the links from the table locations of the elements"
(with-slots (all-links parent-slots
child-slots display-table) editor
;;Variables declared in the outer let are not being used in this function
;;commented it out for now. If not of use then reducing the complexity
;;of this function should be considered. MSB 5/20/93
(loop for link in all-links do
(multiple-value-bind (init-right init-left init-middle)
(find-slot-location display-table 1
(1+ (position (child link) child-slots
:test #'equal )))
(declare (ignore init-right))
(setf (child-x link) (+ init-left 20)
(child-y link) init-middle ))
(when (parent link)
(multiple-value-bind (init-right init-left init-middle)
(find-slot-location display-table 0
(1+ (position (parent link) parent-slots
:test #'equal )))
(declare (ignore init-left))
(setf (parent-x link) (+ init-right 10)
(parent-y link) init-middle))))))
;;------------------------Commands----------------------------------------
(define-command (select-child-option
:command-table top-level-test-ct)
((child-test-option 'symbol) (presentation 'symbol))
"Select the child slot. Make sure its position is known for linkage."
(with-slots (selected-child-slot) *application-frame*
(set-selection-child *application-frame* child-test-option)
(if (null (slot-basics-right child-test-option))
(let ((table-cell (output-record-parent presentation)))
(setf (slot-basics-right selected-child-slot)
(bounding-rectangle-right table-cell)
(slot-basics-left selected-child-slot)
(bounding-rectangle-left table-cell)
(slot-basics-middle selected-child-slot)
(+(bounding-rectangle-bottom table-cell)
(/ (bounding-rectangle-height table-cell) 2)))))))
(define-presentation-to-command-translator select-child-option
(child-test-option select-child-option
top-level-test-ct
:gesture *left-button*)
(object presentation)
(list object presentation))
(define-command (select-parent-option
:command-table top-level-test-ct)
((test-option 'symbol) (presentation 'symbol))
"Select a parent option. Make sure its position is known for linkage."
(with-slots (selected-parent-slot) *application-frame*
(set-selection-parent *application-frame* test-option)
(if (null (slot-basics-right test-option))
(let ((table-cell (output-record-parent presentation)))
(setf (slot-basics-right selected-parent-slot)
(bounding-rectangle-right table-cell)
(slot-basics-left selected-parent-slot)
(bounding-rectangle-left table-cell)
(slot-basics-middle selected-parent-slot)
(+(bounding-rectangle-bottom table-cell)
(/ (bounding-rectangle-height table-cell) 2)))))))
(define-presentation-to-command-translator select-parent-option
(test-option select-parent-option
top-level-test-ct
:gesture *left-button*)
(object presentation)
(list object presentation))
(define-command (test-link-slot-to-argument
:name "Link Slots"
:menu "Link Slots"
:command-table top-level-test-ct) ()
"Link slots from left column to right column."
(with-slots (all-links selected-child-slot selected-parent-slot)
*application-frame*
(when (and selected-child-slot selected-parent-slot
(not (linked-slot-and-child selected-parent-slot
selected-child-slot all-links)))
(push
(make-instance 'test-link
:child selected-child-slot
:child-x (+ (slot-basics-left selected-child-slot) 20)
:child-y (slot-basics-middle selected-child-slot)
:parent selected-parent-slot
:parent-x (+ (slot-basics-right selected-parent-slot) 10)
:parent-y (slot-basics-middle selected-parent-slot)
)
all-links))))
(defun linked-slot-and-child (selected-parent-slot selected-child-slot
all-links)
"Returns link between parent and child when one exists."
(loop for link in all-links
when (and (equal (child link) selected-child-slot)
(equal (parent link) selected-parent-slot))
return link
finally (return nil)))
(define-command (test-delete-slot-link
:name "Delete Slot Link"
:menu "Delete Slot Link"
:command-table top-level-test-ct) ()
"Remove a link between left and right columns"
(with-slots (all-links selected-child-slot selected-parent-slot)
*application-frame*
(setf all-links
(remove
(linked-slot-and-child selected-parent-slot
selected-child-slot all-links)
all-links))))
(define-command (test-toggle-hide-slot-links
:name "Hide/Show Slot Links"
:menu "Hide/Show Slot Links"
:command-table top-level-test-ct) ()
"Toggle the flag to hide the slot links."
(setf (display-links *application-frame*)
(not (display-links *application-frame*))))
(define-command (test-file-exit
:name "Exit"
:menu "Exit"
:command-table top-level-test-ct) ()
"Reset the selected slots for possible reopening of editor."
(setf (selected-child-slot *application-frame*) nil
(selected-parent-slot *application-frame*) nil)
(loop for child in (child-slots *application-frame*) do
(setf (test-option-selected child) nil))
(loop for parent in (parent-slots *application-frame*) do
(setf (test-option-selected parent) nil))
(frame-exit *application-frame*))
;;-----------------Test Case-------------------------------------------
;;; This test case builds a simple editor with two columns. Items can be
;;; linked from one column to the other by selecting one item in each
;;; column and choosing link items.
;;; The problem is that items become unselectable when the links are
;;; displayed. The editor opens with the links hidden. All items can
;;; be selected. When Hide/Show Links is selected, the links appear and
;;; some items can no longer be selected.
(eval-when (load eval)
(when (y-or-n-p "Set up test case? ")
(setf test-child-set (loop for c in '(blue green red orange yellow
violet fuschia teal) collect
(make-instance 'child-test-option
:value c))
test-parent-set (loop for p in '(chair table carpet cabinet
stool hatrack) collect
(make-instance 'test-option
:value p))
test-links (list (make-instance 'test-link
:parent (third test-parent-set)
:child (first test-child-set))
(make-instance 'test-link
:parent (fourth test-parent-set)
:child (fifth test-child-set)))
my-test-editor (make-application-frame
'test-editor
:parent *clim-root-1*
:left 100
:top 100
:right 500
:bottom 450
:all-links test-links
:display-links t
:child-slots test-child-set
:parent-slots test-parent-set))
(run-frame-top-level my-test-editor)))
Follow-Ups:
Main Index |
Thread Index