Hi there,
from mcclim examples
(in-package :common-lisp-user) (defpackage :clim-demo.clim-fig (:use :clim-lisp :clim) (:import-from :alexandria :when-let :curry) (:export :clim-fig)) ; Function and application frame class (in-package :clim-demo.clim-fig)
(defclass canvas-pane (application-pane);;If you want to create a new class ;;that behaves like an application ;;frame, it should be a subclass of ;;application-frame. ())
(defclass move-event () ((record :initarg :record :reader record) (delta-x :initarg :delta-x :reader delta-x :initform 0) (delta-y :initarg :delta-y :reader delta-y :initform 0)) (:default-initargs :record (error "move-event needs a record"))) ;;Appeared no where else (defmethod print-object ((object move-event) stream) (print-unreadable-object (object stream :type T) (format stream "moving ~a by (~D,~D)>" (record object) (delta-x object) (delta-y object))))
(defun set-status-line (string) (setf (clime:label-pane-label (find-pane-named *application-frame* 'status)) string)) ;;status is a slot in application frame, clime:label-pane-label becomes ;;slot status and string is new value (defun draw-figure (pane mode x y x1 y1 &key cp-x1 cp-y1 cp-x2 cp-y2) (with-slots (line-style current-color fill-mode constrict-mode) *application-frame* (let* ((radius-x (- x1 x)) (radius-y (- y1 y))) (when constrict-mode (case mode ((:line :arrow) (if (> (abs radius-x) (abs radius-y)) (setf y1 y) (setf x1 x))) ((:rectangle :ellipse) (let ((radius-max (max (abs radius-x) (abs radius-y)))) (setf radius-x (* (if (minusp radius-x) -1 1) radius-max) radius-y (* (if (minusp radius-y) -1 1) radius-max) x1 (+ x radius-x) y1 (+ y radius-y)))))) (case mode (:point (draw-point* pane x y :ink current-color :line-style line-style)) (:line (draw-line* pane x y x1 y1 :ink current-color :line-style line-style)) (:arrow (draw-arrow* pane x y x1 y1 :ink current-color :line-style line-style :to-head t :head-width 20 :head-length 20)) (:rectangle (draw-rectangle* pane x y x1 y1 :filled fill-mode :ink current-color :line-style line-style)) (:ellipse (draw-ellipse* pane x y radius-x 0 0 radius-y :filled fill-mode :ink current-color :line-style line-style)) (:bezier (let* ((cp-x1 (or cp-x1 x)) (cp-y1 (or cp-y1 y1)) (cp-x2 (or cp-x2 x1)) (cp-y2 (or cp-y2 y))) (unless (or (= x cp-x1 x1 cp-x2) (= y cp-y1 y1 cp-y2)) ; Don't draw null beziers. (let ((design (if fill-mode (mcclim-bezier::make-bezier-area* (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1 x1 y1 x y x y)) (mcclim-bezier::make-bezier-curve* (list x y cp-x1 cp-y1 cp-x2 cp-y2 x1 y1))))) (draw-design pane design :ink current-color :line-style line-style)) (draw-line* pane x y cp-x1 cp-y1 :ink +red+) (draw-line* pane x1 y1 cp-x2 cp-y2 :ink +blue+))))))))
(define-presentation-type figure ())
(define-presentation-method highlight-presentation ((type figure) record stream state) (declare (ignore record stream state)) nil)
(defun handle-draw-object (pane x1 y1) (let* ((frame *application-frame*) (mode (slot-value frame 'drawing-mode)) cp-x1 cp-y1 cp-x2 cp-y2 output-record) (flet ((make-figure-output-record (x y) ;; Note that this can be NIL if (= x x1) and (= y y1). (setf output-record (with-output-to-output-record (pane) (with-output-as-presentation (pane nil 'figure) (draw-figure pane mode x1 y1 x y :cp-x1 cp-x1 :cp-y1 cp-y1 :cp-x2 cp-x2 :cp-y2 cp-y2)))))) (case mode (:point (make-figure-output-record x1 y1) (replay output-record pane)) (t (block processor (tracking-pointer (pane) (:pointer-motion (&key window x y) (declare (ignore window)) (set-status-line (format nil "~:(~A~) from (~D,~D) to (~D,~D)~@[ - Use ~ the middle and right mouse button to set ~ control points~]" mode (round x1) (round y1) (round x) (round y) (eq mode :bezier))) (when output-record (repaint-sheet pane (with-bounding-rectangle* (x1 y1 x2 y2) output-record (make-rectangle* (1- x1) (1- y1) (1+ x2) (1+ y2))))) (make-figure-output-record x y) (when output-record (replay output-record pane))) (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-left-button+) (return-from processor (values x y)))) (:pointer-button-press (&key event x y) (let ((button (pointer-event-button event))) (cond ((= button +pointer-right-button+) (setf cp-x1 x cp-y1 y)) ((= button +pointer-middle-button+) (setf cp-x2 x cp-y2 y))))))))) (set-status-line " ") (when output-record (push output-record (undo-list frame)) (stream-add-output-record pane output-record) (setf (redo-list *application-frame*) nil) (disable-commands frame 'com-redo) (enable-commands frame 'com-undo 'com-clear)))))
(defun handle-move-object (pane figure first-point-x first-point-y) (multiple-value-bind (figure-x figure-y) (output-record-position figure) (let ((offset-x (- figure-x first-point-x)) (offset-y (- figure-y first-point-y))) (tracking-pointer (pane) (:pointer-motion (&key window x y) (declare (ignore window)) (setf (output-record-position figure) (values (+ x offset-x) (+ y offset-y))) (window-refresh pane)) (:pointer-button-release (&key event x y) (when (= (pointer-event-button event) +pointer-right-button+) (let ((frame *application-frame*)) (push (make-instance 'move-event :record figure :delta-x (- x first-point-x) :delta-y (- y first-point-y)) (undo-list frame)) (setf (redo-list frame) (list)) (disable-commands frame 'com-redo) (window-refresh pane) (return-from handle-move-object))))))))
(defun clim-fig () (run-frame-top-level (make-application-frame 'clim-fig)))
(defun make-colored-button (color &key width height) (make-pane 'push-button :label " " :activate-callback (lambda (gadget) (setf (current-color (gadget-client gadget)) color)) :width width :height height :background color :foreground color :normal color :pushed-and-highlighted color :highlighted color))
(defun make-drawing-mode-button (label mode) (make-pane 'push-button :label label :activate-callback (lambda (gadget) (setf (drawing-mode (gadget-client gadget)) mode))))
(defun make-dashes-string (dashes) (if dashes (with-output-to-string (stream) (flet ((add-segment (length character) (write-string (make-string length :initial-element character) stream))) (loop for (dash space) on (append dashes dashes) by #'cddr do (add-segment dash #-) (add-segment space #\Space)))) "none"))
(defun make-merged-line-style (line-style &key unit thickness joint-shape cap-shape (dashes nil dashes-p)) (flet ((scale-dashes (dashes factor) (map (class-of dashes) (curry #'* factor) dashes))) (let* ((old-thickness (line-style-thickness line-style)) (thickness (or thickness old-thickness)) (old-dashes (line-style-dashes line-style)) (dashes (if dashes-p dashes (scale-dashes old-dashes (/ old-thickness))))) (make-line-style :unit (or unit (line-style-unit line-style)) :thickness thickness :joint-shape (or joint-shape (line-style-joint-shape line-style)) :cap-shape (or cap-shape (line-style-cap-shape line-style)) :dashes (scale-dashes dashes thickness)))))
(define-application-frame clim-fig () ((drawing-mode :initform :line :accessor drawing-mode) (output-record :accessor root-output-record) (undo-list :initform nil :accessor undo-list) (redo-list :initform nil :accessor redo-list) (current-color :initform +black+ :accessor current-color) (line-style :initform (make-line-style) :accessor line-style) (fill-mode :initform nil :accessor fill-mode) (constrict-mode :initform nil :accessor constrict-mode) (status :initform nil :accessor status)) (:menu-bar menubar-command-table) (:panes (canvas canvas-pane :name 'canvas :display-time nil) (line-width-slider :slider :label "Line Width" :value 1 :min-value 1 :max-value 100 :value-changed-callback (lambda (gadget value) (declare (ignore gadget)) (with-slots (line-style) *application-frame* (setf line-style (make-merged-line-style line-style :thickness (round value))))) :show-value-p t :decimal-places 0 :orientation :horizontal) (dashes :option-pane :value nil :items '(nil (2 2) (4 4) (2 4) (4 2)) :name-key 'make-dashes-string :value-changed-callback (lambda (gadget value) (with-slots (line-style) (gadget-client gadget) (setf line-style (make-merged-line-style line-style :dashes value)))) :text-style (make-text-style :fix nil nil)) (round-shape-toggle :toggle-button :label "Round Cap/Joint" :value nil :value-changed-callback (lambda (gadget value) (with-slots (line-style) (gadget-client gadget) (let ((cap-shape (if value :round :butt)) (joint-shape (if value :round :miter))) (setf line-style (make-merged-line-style line-style :cap-shape cap-shape
:joint-shape joint-shape)))))) (fill-mode-toggle :toggle-button :label "Fill" :value nil :value-changed-callback (lambda (gadget value) (setf (fill-mode (gadget-client gadget)) value))) (constrict-toggle :toggle-button :label "Constrict" :value nil :value-changed-callback (lambda (gadget value) (setf (constrict-mode (gadget-client gadget)) value)))
;; Drawing modes (point-button (make-drawing-mode-button "Point" :point)) (line-button (make-drawing-mode-button "Line" :line)) (arrow-button (make-drawing-mode-button "Arrow" :arrow)) (rectangle-button (make-drawing-mode-button "Rectangle" :rectangle)) (ellipse-button (make-drawing-mode-button "Ellipse" :ellipse)) (bezier-button (make-drawing-mode-button "Bezier" :bezier))
;; Colors (black-button (make-colored-button +black+)) (blue-button (make-colored-button +blue+)) (green-button (make-colored-button +green+)) (cyan-button (make-colored-button +cyan+)) (red-button (make-colored-button +red+)) (magenta-button (make-colored-button +magenta+)) (yellow-button (make-colored-button +yellow+)) (white-button (make-colored-button +white+)) (turquoise-button (make-colored-button +turquoise+)) (grey-button (make-colored-button +grey+)) (brown-button (make-colored-button +brown+)) (orange-button (make-colored-button +orange+))
(undo :push-button :label "Undo" :active nil :activate-callback (lambda (x) (declare (ignore x)) (com-undo))) (redo :push-button :label "Redo" :active nil :activate-callback (lambda (x) (declare (ignore x)) (com-redo))) (clear :push-button :label "Clear" :active nil :activate-callback (lambda (x) (declare (ignore x)) (com-clear))) (status :label-pane :label "CLIM Fig")) (:layouts (default (vertically () (:fill (horizontally () (vertically (:width 150) (tabling (:height 60) (list black-button blue-button green-button cyan-button) (list red-button magenta-button yellow-button white-button) (list turquoise-button grey-button brown-button orange-button)) line-width-slider (horizontally (:spacing 4) (labelling (:label "Dashes")) dashes) round-shape-toggle (horizontally () fill-mode-toggle constrict-toggle) point-button line-button arrow-button ellipse-button rectangle-button bezier-button :fill) (:fill (scrolling (:width 600 :height 400) canvas)))) (horizontally (:height 30) clear undo redo) status))) (:top-level (default-frame-top-level :prompt 'prompt)))
(defmethod frame-standard-output ((frame clim-fig)) (find-pane-named frame 'canvas))
(define-presentation-to-command-translator add-figure (blank-area com-add-figure clim-fig :gesture :select ; XXX :echo nil :tester ((object window) (declare (ignore object)) (typep window 'canvas-pane))) (object x y) (list x y))
(define-presentation-to-command-translator move-figure (figure com-move-figure clim-fig :gesture :menu ; XXX :echo nil) (object presentation x y) ;; xxx: inv-2016-08-22 ;; (declare (ignore object)) (list presentation x y))
(defmethod generate-panes :after (frame-manager (frame clim-fig)) (declare (ignore frame-manager)) (setf (root-output-record frame) ;; *standard-output* not bound to the canvas pane yet. (stream-current-output-record (frame-standard-output frame)) (status frame) (find-pane-named frame 'status)))
(defun prompt (stream frame) (declare (ignore stream frame)))
(defmethod note-command-enabled :after (frame-manager (frame clim-fig) command-name) (case command-name (com-undo (activate-gadget (find-pane-named frame 'undo))) (com-redo (activate-gadget (find-pane-named frame 'redo))) (com-clear (activate-gadget (find-pane-named frame 'clear)))))
(defmethod note-command-disabled :after (frame-manager (frame clim-fig) command-name) (case command-name (com-undo (deactivate-gadget (find-pane-named frame 'undo))) (com-redo (deactivate-gadget (find-pane-named frame 'redo))) (com-clear (deactivate-gadget (find-pane-named frame 'clear)))))
(defun enable-commands (frame &rest command-names) (dolist (command-name command-names) (setf (command-enabled command-name frame) t)))
(defun disable-commands (frame &rest command-names) (dolist (command-name command-names) (setf (command-enabled command-name frame) nil)))
(define-clim-fig-command com-exit () (frame-exit *application-frame*))
(define-clim-fig-command com-undo () "Undo the previous command, which might have been either 'draw a new object', 'move an object', or the CLEAR command.
In the first case, remove the record and add it to the redo list; in the second case, move the object back to its previous position; to undo a CLEAR, replay the output-history." (when-let ((latest-undo-entry (pop (undo-list *application-frame*)))) (cond ((typep latest-undo-entry 'move-event) (multiple-value-bind (x y) (output-record-position (record latest-undo-entry)) (setf (output-record-position (record latest-undo-entry)) (values (- x (delta-x latest-undo-entry)) (- y (delta-y latest-undo-entry)))) (window-refresh *standard-output*)) (push latest-undo-entry (redo-list *application-frame*)) (enable-commands *application-frame* 'com-redo)) ((listp latest-undo-entry) (loop for record in latest-undo-entry do (stream-add-output-record *standard-output* record) (replay record *standard-output* (bounding-rectangle record))) (enable-commands *application-frame* 'com-clear) (disable-commands *application-frame* 'com-redo)) (T (erase-output-record latest-undo-entry *standard-output*) (push latest-undo-entry (redo-list *application-frame*)) (enable-commands *application-frame* 'com-clear 'com-redo))) (unless (undo-list *application-frame*) (disable-commands *application-frame* 'com-undo 'com-clear))))
(define-clim-fig-command com-redo () (when-let ((current-redo-entry (pop (redo-list *application-frame*)))) (push current-redo-entry (undo-list *application-frame*)) (enable-commands *application-frame* 'com-undo 'com-clear) (cond ((typep current-redo-entry 'move-event) (multiple-value-bind (x y) (output-record-position (record current-redo-entry)) (setf (output-record-position (record current-redo-entry)) (values (+ x (delta-x current-redo-entry)) (+ y (delta-y current-redo-entry))))) (window-refresh *standard-output*)) (T (stream-add-output-record *standard-output* current-redo-entry) (replay current-redo-entry *standard-output* (bounding-rectangle current-redo-entry)))) (unless (redo-list *application-frame*) (disable-commands *application-frame* 'com-redo))))
(define-clim-fig-command com-clear () (push (coerce (output-record-children (root-output-record *application-frame*)) 'list) (undo-list *application-frame*)) (setf (redo-list *application-frame*) (list)) (disable-commands *application-frame* 'com-redo 'com-clear) (window-clear *standard-output*))
(define-clim-fig-command (com-add-figure :name nil) ((x real) (y real)) (handle-draw-object (find-pane-named *application-frame* 'canvas) x y))
(define-clim-fig-command (com-move-figure :name nil) ((figure figure) (x real) (y real)) (handle-move-object (find-pane-named *application-frame* 'canvas) figure x y))
(make-command-table 'file-command-table :errorp nil :menu '(("Exit" :command com-exit)))
(make-command-table 'edit-command-table :errorp nil :menu '(("Undo" :command com-undo) ("Redo" :command com-redo) ("Clear" :command com-clear)))
(make-command-table 'menubar-command-table :errorp nil :menu '(("File" :menu file-command-table) ("Edit" :menu edit-command-table)))
I hoped to figure out how the code works
CLIM-FIG> (defvar c) C CLIM-FIG> (setf c (make-instance 'clim-fig)) #<CLIM-FIG {10042E0403}>
I thought to use instance of clim-fig to get it slot-values, but get lost on the way. How you guys manage to understand big pieces of code. May you share your experience with me.
Very best, Igor