CLIM mail archive
[Prev][Next][Index][Thread]
Manual REDISPLAY of output records
1In Symbolics MacIvory model 3 Command Processor in Genera 8.3, Logical Pathnames Translation Files NEWEST, CLIM 52.13, Genera CLIM 52.5,
PostScript CLIM 52.2, CLIM Demo 52.1, CLIM Documentation 52.1, Mailer 434.0, Metering 439.0, Metering Substrate 439.0, Conversion Tools 430.0,
Hacks 435.0, NFS Server 435.0, Ivory Revision 4A, FEP 328, FEP0:>I328-loaders.flod(24), FEP0:>I328-info.flod(24), FEP0:>I328-debug.flod(24),
FEP0:>I328-lisp.flod(25), FEP0:>I328-kernel.fep(44), Boot ROM version 320, Device PROM version 325, Genera application 5.6,
MacIvory SCSI Manager Server 4.3.1, Toolbox Servers 4.2, MacIvory & RPC library 6.3.2, MacIvory life support 4.3.6, Symbolics keyboard 2.1,
Macintosh System Software 7.0.1, 1152x802 Screen with Genera fonts, Machine serial number 30102, Macintosh Quadra 950, Symbolics Keyboard,
world booted from FEP0:>Inc-CLIM-ECO-from-Genera-8-3-sys.ilod.1 on Symbolics MacIvory model 3 #30102 (BITTERROOT):
0I'm sorry about all the mail on this topic, but I can't figure
out what's going on with manual redisplay of output records.
I can't get them to redisplay in the right location -- even
after having tried several different combinations of translating
output-record and output-record-parent locations. Here is a
complete example, to run it type (test) and click on things.
Any help would be greatly appreciated.
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10; -*-
(defpackage :table-test
(:use CLIM-LISP CLIM))
(in-package :table-test)
(defparameter *tracks* nil)
(defun test (&key (port (clim:find-port)))
(setf *nav-width* 300)
(let*
((framem (find-frame-manager :port port))
(frame (make-application-frame 'table-frame
:pretty-name "ASAPS Frame"
:frame-manager framem
:height 600
:width *nav-width*
)))
(setf *frame* frame
*tracks* (loop for i below 1
collecting (make-instance 'track) into tracks
finally (return tracks)))
(run-frame-top-level frame)))
(defclass data-navigator-view (textual-view) ())
(defparameter +data-navigator-view+ (make-instance 'data-navigator-view))
(define-application-frame table-frame ()
()
(:command-table (table-frame :inherit-from (accept-values-pane)))
(:panes
(title-nav :title
:display-string "Data Navigator")
(nav :application
:incremental-redisplay t ;Supplies outermost updating-output for nav pane
:display-after-commands nil
:display-function 'draw-data-navigator-display
:name :navigation
:scroll-bars :both
:end-of-page-action :scroll
:initial-cursor-visibility :inactive
)
(pointer :pointer-documentation)
(menu :command-menu))
(:menu-bar nil) ; Suppress menu bar at the top
(:layouts
(default
(vertically ()
(.05 title-nav) ;(:compute title-nav)
(:fill nav)
(.05 menu) ;(:compute menu)
(.04 pointer) ;(:compute pointer)
))))
(define-table-frame-command (com-exit-table-frame
:menu "Exit"
:name "Exit table formatter")
()
(frame-exit *application-frame*))
(defclass track ()
((exposed :accessor exposed :initform nil)
(data :initform (make-grid))))
(defclass spot ()
((beam :initarg :beam :accessor beam)
(sector :initarg :sector :accessor sector)
(shown :initarg :shown
:initform nil
:accessor shown)
(color
:initarg :color
:accessor color)
(output-record
:initform nil
:accessor output-record)
)
)
(define-presentation-type spot ()
:options (size))
(defun make-grid ()
(let* ((display-width *nav-width*)
(beams 2)
(sectors 2)
(array (make-array `(,beams ,sectors))))
(loop for beam from 0 below beams
do
(loop for sector below sectors
do
(setf (aref array beam sector)
(make-instance 'spot :beam beam :sector sector
:color +green+))))
array))
(defmethod draw-data-navigator-display ((frame table-frame) stream)
(stream-set-cursor-position stream 0 0)
(dolist (track *tracks*)
(UPDATING-OUTPUT (stream :unique-id track :cache-value (exposed track))
(present track 'track :stream stream :view +data-navigator-view+ :sensitive t)
(multiple-value-bind (xoff yoff)
(stream-cursor-position stream)
(with-translation (stream (+ xoff 10) yoff)
(with-slots (exposed) track
(when exposed (draw-table-and-axes track stream))))))))
(defmethod draw-table-and-axes ((track Track) stream)
(with-slots (data) track
(updating-output (stream)
(loop with size = 50
for beam from 0 below (array-dimension data 0)
do
(loop for sector from 0 below (array-dimension data 1)
for spot = (aref data beam sector)
do
(setf (beam spot) beam
(sector spot) sector
(output-record spot)
(UPDATING-OUTPUT (stream)
(UPDATING-OUTPUT (stream :unique-id spot :cache-value (color spot))
(present spot `((spot) :size ,size)
:stream stream :view +data-navigator-view+)))))))))
(define-presentation-method present
(object (type track) stream
(view data-navigator-view) &key)
(format stream "~A~&" (type-of object)))
(define-table-frame-command (expose-track :name "Show")
((object 'track))
(setf (exposed object) (not (exposed object))))
(define-presentation-to-command-translator expose-track
(track expose-track table-frame
:gesture :select
;;:tester ((object) (not (exposed object)))
;;:documentation ((stream object)
;; (format-documentation stream (if (typep object 'track) "Open" "Show") object))
:pointer-documentation ((stream object)
(format-loc stream (if (exposed object) "Open" "Close") object))
)
(object)
`(,object))
(defmethod format-loc (stream string (object spot))
(with-slots (beam sector) object
(with-slots (clim-utils::left clim-utils::top) (output-record object)
(let ((x clim-utils::left)
(y clim-utils::top))
(with-slots (clim-utils::left clim-utils::top) (output-record-parent (output-record object))
(let ((x-p clim-utils::left)
(y-p clim-utils::top))
(multiple-value-bind (x-r y-r)
(output-record-position (output-record object))
(format stream "~:(~A (beam ~d sector ~d x ~d y ~d parent x ~d y ~d Record x ~d y ~d) ~A~)"
string (1+ beam) (1+ sector) x y x-p y-p x-r y-r
(type-of object)))))))))
(define-presentation-method present
(spot (type spot) stream
(view data-navigator-view) &key)
;; Note, size is a spot presentation type option, and is bound within the present
(with-slots (beam sector color) spot
(let ((x (* beam size))
(y (* sector size)))
(with-translation (stream x y)
(draw-rectangle* stream 0 0 size size :filled t :ink color))
)))
(define-table-frame-command (highlite-spot :name "Show")
((spot 'spot) (stream 'application-pane))
(setf (color spot) (if (eq (color spot) +green+) +red+ +green+)
(shown spot) (not (shown spot)))
(multiple-value-bind (xoff yoff)
(convert-from-relative-to-absolute-coordinates stream (output-record-parent (output-record spot)))
(multiple-value-bind (x y)
(output-record-position (output-record spot))
(translate-coordinates xoff yoff x y)
(with-translation (stream x y)
(redisplay (output-record spot) stream)
)))))
(define-presentation-to-command-translator highlite-spot
(spot highlite-spot table-frame
:gesture :select
:pointer-documentation ((stream object)
(format-loc stream (if (eql (color object) +red+) "Close" "Open") object)))
(object window)
`(,object ,window))
;(defun foo (stream record)
; (when record
; (describe record)
; (multiple-value-bind (x y)
; (output-record-position record)
; (multiple-value-bind (x1 y1)
; (convert-from-relative-to-absolute-coordinates stream record)
; (multiple-value-bind (x2 y2)
; (convert-from-relative-to-absolute-coordinates nil record)
; (with-slots (clim-utils:left clim-utils:top) record
; (format t "~&---------------~&POSITION ~D ~D REL-TO-ABS(STREAM) ~D ~D REL-TO-ABS(NIL) ~D ~D LEFT-TOP ~D ~D~&---------------"
; x y x1 y1 x2 y2 clim-utils:left clim-utils:top)))))
; (foo stream (output-record-parent record))))
;(defun map-over-output-record-tree
; (function stream record &optional (region clim:+everywhere+))
; (declare (dynamic-extent function))
; (labels (( map-internal (rec x-offset y-offset)
; (multiple-value-bind (xoff yoff)
; (output-record-position rec)
; (translate-coordinates x-offset y-offset xoff yoff)
; (unless (eql rec record) ;not the first time
; (funcall function stream rec))
; (map-over-output-records-overlapping-region #'map-internal rec region
; (- x-offset) (- y-offset) xoff yoff))))
; (declare (dynamic-extent #'map-internal))
; (multiple-value-bind (x-offset y-offset)
; (convert-from-relative-to-absolute-coordinates
; nil (output-record-parent record))
; (map-internal record x-offset y-offset))))
Main Index |
Thread Index