updating-output issues

[Paul Werkowski]

I've been revisiting a clim project from 15 years ago which was to 
provide clim graphics to Dan Corkhill's very nice GBBopen blackboard 
system. I have an initial version now working nicely on Lispworks 
clim-2.0 on Windows. It is close to running with McCLIM as well.

I have two issues, updating-output appears to work in that the 
:cache-test is respected but where Lispworks clim calls 
clear-output-record when a displayed object moves or is deleted McCLIM 
does not do so. I have attached a simple demo that shows that problem. 
Just click right or left anywhere in the pane to move the green disk 
left or right to see the problem.

The other issue is that redisplay-frame-pane (not used in the demo) 
always causes an infinite recursion that finally results in a blown 
stack. Part of the problem is with window-clear which in addition to 
using medium-clear-area, etc to clear the screen also sets window size 
to zero and then calls compose-space. I have an :around method that 
avoids that problem but the redisplay recursion persists. My workaround 
for that is to just call the display function directly but that does not 
allow updating-output to work correctly.

Paul
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/mcclim-devel/attachments/20220128/a0f19a1a/attachment.html>
-------------- next part --------------
(defpackage utest (:use :clim :clim-lisp))
(in-package :utest)

(defclass unit ()())
(define-presentation-type unit ())

(defclass test-unit (unit)
  ((x-value :initarg :x :accessor x-of)
   (y-value :initarg :y :accessor y-of)
   (color   :initarg :color
            :accessor color-of)
   (size :initform 10))
  (:default-initargs
   :x 10 :y 10 :color +green+))

(defmethod print-object ((obj test-unit) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "<~d ~d>"
            (x-of obj)(y-of obj))))

(defclass example-pane (application-pane)
  ((units :initform nil
          :initarg :units
          :accessor units-of)
   (dx :initform 10)
   (dy :initform 10))
  (:default-initargs
   :width  300
   :height 300
   :incremental-redisplay t
   :display-function 'example-pane-displayer))

(defmethod draw-unit ((pane example-pane)(unit test-unit))
  (with-slots ((x x-value) (y y-value) size color) unit
    (format *trace-output* "~&draw-unit ~a~%" unit)
    (updating-output (pane :unique-id unit
                           :cache-value (list* x y size color)
                           :cache-test #'equalp)
      (with-output-as-presentation (pane unit 'unit)
        (format *trace-output* "~&--draw-circle~%")
        (draw-circle* pane x y size :ink (color-of unit))))))

#+notyet
(define-presentation-method highlight-presentation
  ((type unit) record stream state)
  (with-bounding-rectangle* (x0 y0 xz yz) record
    (declare (ignorable xz yz))
    (let ((ink (if (eql state :highlight) +flipping-ink+ +background-ink+)))
      (draw-rectangle* stream (1- x0)(1- y0) xz yz
                       :ink ink :filled nil))))

(defmethod example-pane-displayer (frame (pane example-pane))
  (declare (ignore frame)) ; need tracking-pointer here - see plotter
  (with-bounding-rectangle* (x1 y1 x2 y2) pane
    (updating-output (pane :cache-value (list* x1 y1 x2 y2)
                           :cache-test #'equalp)
      (draw-rectangle* pane x1 y1 x2 y2 :ink +blue+ :filled nil))
    (with-first-quadrant-coordinates (pane x1 y2)
      (dolist (unit (units-of pane))
        (draw-unit pane unit))
      )))

(define-application-frame utest ()
  ((x-dim :initform 'x :initarg :x-dim)
   (y-dim :initform 'y :initarg :y-dim))
  (:menu-bar t)
  #-mcclim(:command-table t)
  #+mcclim(:command-table (utest))
  (:panes
   (p1
    (make-pane 'example-pane
               :units (list (make-instance
                             'test-unit :x 150 :y 150
                             :color +green+)
                            (make-instance
                             'test-unit :x 250 :y 50
                             :color +blue+))
               :width 300 :height 300
               :max-width +fill+
               :max-height +fill+
               )))
  (:layouts 
   (default  p1)))

(define-utest-command (com-move-unit)((which '(member :x :y))
                                      (unit 'test-unit)
                                      (pane 'example-pane)
                                      (direction '(member :up :down
                                                          :left :rignt)))
  (declare (ignorable pane))
  (with-slots (x-value y-value) unit
    (let ((incr 5.0))
      (case which
        (:x (incf x-value (case direction (:left (- incr))(:right incr))))
        (:y (incf y-value (case direction (:up incr)(:down (- incr))))))
      )))

(define-presentation-to-command-translator xlate-move-unit-l
    (blank-area com-move-unit utest
                  :pointer-documentation "Move Left"
                  :gesture :select)
    ;; object is blank-area
    (object window x y)
  (declare (ignore object x y)) (terpri *trace-output*)
  (let* ((units (units-of window))
         (unit (first units)))
    `(:x ,unit ,window :left)))

(define-presentation-to-command-translator xlate-move-unit-r
    (blank-area com-move-unit utest
                  :pointer-documentation "Move Right"
                  :gesture :menu)
    ;; object is blank-area
    (object window x y)
  (declare (ignore object x y))
  (let* ((units (units-of window))
         (unit (first units)))
    `(:x ,unit ,window :right)))

(defun testme ()
  (run-frame-top-level
   (make-application-frame 'utest
     :left 950 :top 40)))