mcclim-devel

Download

mcclim-devel@common-lisp.net

September 2023

1 participants
1 discussions

Pan and Zoom
by Robert Krug 17 Sep '23

17 Sep '23

Greetings,Many thanks for all your work on McClim. I have been enjoying using it while trying to work my way through Tilings and Patterns by Grunbaum and Shepard.I think I have gotten a workable approach to panning and zooming. Any comments or suggestions would be greatly appreciated, but my main purpose in posting this rather long email is so that future users might save themselves some work. Thanks again.Robert;;; This is a first attempt at implementing panning and zooming in;;; McClim. It mostly works, but after a few (say 10) zooming;;; operations (in or out), the displayed region is not correct ---;;; subsequent panning operations can leave a part of the window;;; unpainted. This may be because of the accumulating inacuracy;;; inherent in repeated floating-point operations.(defpackage #:pan-and-zoom-1 (:use #:clim-lisp #:clim))(in-package #:pan-and-zoom-1);;; This class will be our model for the infinite Euclidean plane.;;; N.B. I do not understand the McClim pane hierarchy. The below may;;; not behave correctly if plane inherits from classes of panes other;;; than basic-pane. In particular, application-pane did odd things.(defclass plane (standard-extended-input-stream basic-pane) ());;; Draw a bunch of squares, so that we can examine the effect of;;; panning and zooming.(defmethod handle-repaint ((plane plane) region) (declare (ignore region)) (window-clear plane) (dotimes (i 40) (dotimes (j 40) (let ((c-x (- (* i 40) 800)) (c-y (- (* j 40) 800))) (draw-polygon* plane `(,c-x ,c-y ,(+ c-x 40) ,c-y ,(+ c-x 40) ,(+ c-y 40) ,c-x ,(+ c-y 40)) :filled 'NIL :line-thickness 2 :ink +black+) (draw-text* plane (format nil "~A, ~A" i j) (+ c-x 20) (+ c-y 20) :align-x :center :align-y :center)))))(defun pan (dx dy) (let* ((plane (find-pane-named *application-frame* 'plane)) (plane-transformation (sheet-transformation plane)) (translation-transformation (make-translation-transformation dx dy)) (new-plane-transformation (compose-transformations translation-transformation plane-transformation)) (sheet-region (sheet-region plane)) ;; We transform sheets, and untransform (apply the inverse ;; transformation) to regions. I keep getting this confused. (new-sheet-region (untransform-region translation-transformation sheet-region))) (setf (sheet-transformation plane) new-plane-transformation (sheet-region plane) new-sheet-region)))(defun zoom (factor) (let* ((plane (find-pane-named *application-frame* 'plane)) (plane-transformation (sheet-transformation plane)) (scaling-transformation (make-scaling-transformation* factor factor)) (new-plane-transformation (compose-transformations scaling-transformation plane-transformation)) (sheet-region (sheet-region plane)) (new-sheet-region (untransform-region scaling-transformation sheet-region))) (setf (sheet-transformation plane) new-plane-transformation (sheet-region plane) new-sheet-region)))(define-application-frame tiling () () (:panes (plane plane :width 400 :height 400)) (:menu-bar t) (:layouts (default plane)));;; Without these next two methods (or an interactor pane), the;;; panning/zooming commands will not be executed!;;; From Franz's User Guide: You will often implement a method for;;; this generic function for an application frame, since CLIM cannot;;; always reliably determine which pane to use for *standard-input*.(defmethod frame-standard-input ((tiling tiling)) (find-pane-named tiling 'plane))(defmethod frame-standard-output ((tiling tiling)) (find-pane-named tiling 'plane))(define-tiling-command (com-quit :menu t) () (frame-exit *application-frame*))(define-tiling-command (com-pan-up :keystroke :up) () (pan 0 10))(define-tiling-command (com-pan-down :keystroke :down) () (pan 0 -10))(define-tiling-command (com-pan-right :keystroke :right) () (pan -10 0))(define-tiling-command (com-pan-left :keystroke :left) () (pan 10 0))(define-tiling-command (com-zoom-in :keystroke (:up :shift)) () (zoom 1.1))(define-tiling-command (com-zoom-out :keystroke (:down :shift)) () (zoom 0.9))(defun tiling () (flet ((run () (let ((frame (make-application-frame 'tiling))) (setq *test-frame* frame) (run-frame-top-level frame)))) (clim-sys:make-process #'run)));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; This is a second attempt at implementing panning and zooming in;;; McClim. It works, but is a little messy.(defpackage #:pan-and-zoom-2 (:use #:clim-lisp #:clim))(in-package #:pan-and-zoom-2);;; This class will be our model for the infinite Euclidean plane.;;; We avoid the problems with pan-and-zoom-1's accumulating;;; floating-point inaccuracies by keeping track of the plane's;;; scaling and translations, and making the appropriate;;; transformations when needed. We also keep track of the "raw";;; sheet-region so that we can transform (really untransform) it;;; appropriately.;;; N.B. I do not understand the McClim pane hierarchy. The below may;;; not behave correctly if plane inherits from classes of panes other;;; than basic-pane. In particular, application-pane did odd things.(defclass plane (standard-extended-input-stream basic-pane) ((scale :initform 1 :accessor scale) (dx :initform 0 :accessor dx) (dy :initform 0 :accessor dy) (raw-sheet-region :initform 'NIL :accessor raw-sheet-region)));;; We catch sheet resize events here so that we can update the;;; raw-sheet-region. We transform it here so that when we untransform;;; it later, we get the original region back. This is needed because;;; generally we will transform sheets and untransform regions.(defmethod resize-sheet :after ((plane plane) width height) (let ((transformation (sheet-transformation plane))) (setf (raw-sheet-region plane) (transform-region transformation (sheet-region plane)))));;; Draw a bunch of squares, so that we can examine the effect of;;; panning and zooming.(defmethod handle-repaint ((plane plane) region) (declare (ignore region)) (unless (raw-sheet-region plane) ;; Set the raw-sheet-region. This is not available at the time of ;; the plane's initialization. (setf (raw-sheet-region plane) (sheet-region plane))) (window-clear plane) (dotimes (i 40) (dotimes (j 40) (let ((c-x (- (* i 40) 800)) (c-y (- (* j 40) 800))) (draw-polygon* plane `(,c-x ,c-y ,(+ c-x 40) ,c-y ,(+ c-x 40) ,(+ c-y 40) ,c-x ,(+ c-y 40)) :filled 'NIL :line-thickness 2 :ink +black+) (draw-text* plane (format nil "~A, ~A" i j) (+ c-x 20) (+ c-y 20) :align-x :center :align-y :center)))))(defun update-plane (plane) (let* ((scaling (make-scaling-transformation* (scale plane) (scale plane))) (translation (make-translation-transformation (dx plane) (dy plane))) (transformation (compose-transformations scaling translation))) (setf (sheet-transformation plane) transformation (sheet-region plane) (untransform-region transformation (raw-sheet-region plane)))))(defun pan (dx dy) (let ((plane (find-pane-named *application-frame* 'plane))) (setf (dx plane) (+ (dx plane) dx) (dy plane) (+ (dy plane) dy)) (update-plane plane)))(defun zoom (factor) (let ((plane (find-pane-named *application-frame* 'plane))) (setf (scale plane) (* factor (scale plane))) (update-plane plane)))(define-application-frame tiling () () (:panes (plane plane :width 400 :height 400)) (:menu-bar t) (:layouts (default plane)));;; Without these next two methods (or an interactor pane), the;;; panning/zooming commands will not be executed!;;; From Franz's User Guide: You will often implement a method for;;; this generic function for an application frame, since CLIM cannot;;; always reliably determine which pane to use for *standard-input*.(defmethod frame-standard-input ((tiling tiling)) (find-pane-named tiling 'plane))(defmethod frame-standard-output ((tiling tiling)) (find-pane-named tiling 'plane))(define-tiling-command (com-quit :menu t) () (frame-exit *application-frame*))(define-tiling-command (com-up :keystroke :up) () (pan 0 10))(define-tiling-command (com-down :keystroke :down) () (pan 0 -10))(define-tiling-command (com-right :keystroke :right) () (pan -10 0))(define-tiling-command (com-left :keystroke :left) () (pan 10 0))(define-tiling-command (com-zoom-in :keystroke (:up :shift)) () (zoom 1.1))(define-tiling-command (com-zoom-out :keystroke (:down :shift)) () (zoom 0.9))(defun tiling () (flet ((run () (let ((frame (make-application-frame 'tiling))) (setq *test-frame* frame) (run-frame-top-level frame)))) (clim-sys:make-process #'run)))

2 1