? beagle/lisp-bezier-path.lisp ? beagle/tests Index: beagle/README.txt =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/README.txt,v retrieving revision 1.7 diff -u -r1.7 README.txt --- beagle/README.txt 6 Mar 2005 18:57:20 -0000 1.7 +++ beagle/README.txt 26 Apr 2005 22:33:40 -0000 @@ -144,22 +144,6 @@ (7) isn't necessary, since the CLX port appears in the server-path search order before the Beagle port does. - -listener: ---------- -If you want to run the Listener in this back end as it currently stands, you -need to make the following modifications to -'Apps/Listener/dev-commands.lisp' (or put up with broken directory display):- - -1. Modify 'pretty-pretty-pathname', removing: - - (let ((icon (icon-of pathname))) - (when icon (draw-icon stream icon :extra-spacing 3))) - -2. Modify 'com-show-directory', removing: - - (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% KNOWN LIMITATIONS / TODO LIST @@ -173,6 +157,17 @@ far this will get us though... UPDATE - 21.AUG.2004 - performing fewer NSWindow flushes makes no difference to speed. + UPDATE - 25.APR.2005 - When the mirror transformation is set (sheet is + scrolling) we dispatch a repaint on the 'untransformed + mirror region' (using the mirror transformation as the 'untransformation') + instead of on the whole sheet. Things seem to behave better (i.e. quicker) now. + This HASN'T made '(time (clim-listener::com-show-class-subclasses t))' execute + any faster though (or cons less). We're doing way too much work drawing stuff + I think, and because we get CLIM to redraw the regions (linear search through + output history?) it's not too fast. Suspect in CLX when the sheet is scrolled, + no redraw happens from CLIM generally. Also, Cocoa appears to get really slow + at rendering text when the output history gets too large (maybe this is CLIM + again, it's hard to know). Need to profile. 2. When running the Listener (and probably other applications), the resize handle is not visible; it's there, but you can't see it. Grab and drag @@ -181,9 +176,6 @@ 3. There are not yet any aqua look and feel panes. Sorry, I'm trying to get everything else working first! -4.5. Designs (other than colours) aren't implemented - THIS means there are - no icons in the Listener. - 5. Mouse down / up on buttons appears not to work very well unless the frame containing the buttons is the only active frame. Actually, this ^^^ seems to work fine, but the highlighting for button @@ -216,8 +208,6 @@ pool) but when running in a separate thread lots of warning messages are generated. -11. Line dash patterns haven't been implemented. - 12. There's probably some debug output remaining in some corner cases. 15. Popup menus don't work quite the same way as they do in the CLX back @@ -238,9 +228,9 @@ 18. The back end doesn't clear up after itself very well. You might find it necessary to force-quit OpenMCL after you've finished. -19. Menus don't work in CLIM-FIG (or any else!). No idea why not... - This is because the way pointer tracking is done in clim-internals has - been changed, so another work-around needs to be implemented. +19. Menus don't work in CLIM-FIG (or anywhere else!). No idea why not... + This is because (I think) the menu popups don't operate in a flipped + coord system (unlike NSViews). 20. Bounding rectangles are slightly off (this can be seen in CLIM-FIG again). It's only a matter of a pixel, maybe 2 in the worst case I've seen. @@ -270,6 +260,11 @@ RESOLVED 08.AUG.04 [NB. this functionality is not too efficient I think and needs revisiting (like everything else does)] +-4.5.- Designs (other than colours) aren't implemented - THIS means there are + no icons in the Listener. + UPDATE 25.APR.2005 - This is done now, more or less. + + -10.- Text sizes aren't calculated correctly; when multiple lines are output together, the bottom of one line can be overwritten by the top of the next line. @@ -282,6 +277,9 @@ Perhaps Cocoa thinks the dirty region includes that text or something. It's annoying whatever. Still, I'm going to mark this as fixed for now and maybe will come back to it later. + +-11.- Line dash patterns haven't been implemented. + -13.- Some Apropos cases fail; for example 'Apropos graft' fails (although '(apropos 'graft)' does not). The same problem prevents the address Index: beagle/beagle-backend.asd =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/beagle-backend.asd,v retrieving revision 1.1 diff -u -r1.1 beagle-backend.asd --- beagle/beagle-backend.asd 8 Aug 2004 16:20:44 -0000 1.1 +++ beagle/beagle-backend.asd 26 Apr 2005 22:33:40 -0000 @@ -24,7 +24,7 @@ #:port-disable-sheet #:port-motion-hints #:port-force-output - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; #:port-set-mirror-region @@ -89,6 +89,7 @@ :version "0.1" :serial t :components ((:file "package") + (:file "lisp-bezier-path") (:file "lisp-window") (:file "lisp-window-delegate") (:file "lisp-view") @@ -103,7 +104,7 @@ (:file "events") (:file "graft") (:file "fonts") - (:file "image") +;;; (:file "image") ;;; (:file "clim-extensions") (:file "keysymdef") )) Index: beagle/events.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/events.lisp,v retrieving revision 1.5 diff -u -r1.5 events.lisp --- beagle/events.lisp 4 Mar 2005 07:35:39 -0000 1.5 +++ beagle/events.lisp 26 Apr 2005 22:33:42 -0000 @@ -92,13 +92,8 @@ (warn "events:port-motion-hints:Motion hints not supported in Beagle backend") nil) -;;;(defmethod (setf port-motion-hints) (hint) -;;; (declare (ignore hint)) -;;; (warn "events:setf port-motion-hints:Motion hints not supported in Cocoa backend") -;;; nil) -;;; (defmethod (setf port-motion-hints) (val (port beagle-port) (sheet mirrored-sheet-mixin)) -;;; (declare (ignore val port sheet)) + (declare (ignore val port sheet)) (warn "events:setf port-motion-hints:Motion hints (2) not supported in Cocoa backend") nil) @@ -720,7 +715,9 @@ ;;; Cocoa note: the Frame (NSWindow) must be made key for us to receive events; but they ;;; must then be sent to the Sheet that has focus. -(defmethod %set-port-keyboard-focus (focus (port beagle-port) &key timestamp) +;;; NB. when the method was renamed it appears that the argument order was also changed. +(defmethod %set-port-keyboard-focus ((port beagle-port) focus &key timestamp) + (declare (ignore timestamp)) (let ((mirror (sheet-mirror focus))) (debug-log 2 "events.lisp:set-port-keyboard-focus - got mirror ~S~%" mirror) (when mirror Index: beagle/fonts.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/fonts.lisp,v retrieving revision 1.3 diff -u -r1.3 fonts.lisp --- beagle/fonts.lisp 21 Aug 2004 22:44:54 -0000 1.3 +++ beagle/fonts.lisp 26 Apr 2005 22:33:42 -0000 @@ -30,8 +30,12 @@ ;; I don't think there should be a fixed family though, it seems not ;; to be in the spec (section 11.1). +;;; These should all be able to be defined by the user, possibly +;;; in some start-up file (implement 'profile' ;-) + (defconstant *beagle-text-families* '(:fix "Courier" - :fixed "Courier" +;;; :fixed not in spec; old work-around for Listener bug. +;;; :fixed "Courier" :serif "Times New Roman" :sans-serif "Verdana")) @@ -120,15 +124,11 @@ ;; This is frigged for now; return the ascent of the default Cocoa font... see comments ;; for text-style-descent below re: line-gap too. ::FIXME:: (declare (ignore medium)) - (debug-log 2 "fonts.lisp -> text-style-ascent~%") (send (%text-style->beagle-font (or text-style *default-text-style*)) 'ascender)) -; (let* ((default-system-font (send (@class ns-font) :system-font-of-size -1.0)) -; (dsf-size (send default-system-font 'ascender))) -; dsf-size)) (defmethod text-style-descent (text-style (medium beagle-medium)) (declare (ignore medium)) - (debug-log 2 "fonts.lisp -> text-style-descent~%") + ;; For cocoa, this is -ve. Do we need to +ve it? Also Cocoa adds a "line-gap" to text, ;; which we may need to take account of. At some point investigate where this gap is ;; drawn. ::FIXME:: @@ -140,9 +140,6 @@ (abs (send (%text-style->beagle-font (or text-style *default-text-style*)) 'descender))) (defmethod text-style-height (text-style (medium beagle-medium)) - (debug-log 2 "fonts.lisp -> text-style-height~%") - (debug-log 3 "text-style-height returning: ~A as height~%" - (send (%text-style->beagle-font (or text-style *default-text-style*)) 'default-line-height-for-font)) (send (%text-style->beagle-font (or text-style *default-text-style*)) 'default-line-height-for-font)) ;; Let's be very very naughtly and assume fonts are square for now. Anything to get some @@ -220,61 +217,6 @@ 2) (abs (send beagle-font 'descender)))))))) -;;;(defmethod text-size ((medium beagle-medium) string &key text-style (start 0) end) -;;; (when (characterp string) -;;; (setf string (make-string 1 :initial-element string))) -;;; (unless end (setf end (length string))) -;;; (unless text-style (setf text-style (medium-text-style medium))) -;;; (let ((beaglefont (%text-style->beagle-font (or text-style *default-text-style*)))) -;;; (cond ((= start end) -;;; (values 0 0 0 0 0)) -;;; (t -;;; (let ((position-newline (position #\newline string :start start))) -;;; (cond ((not (null position-newline)) -;;; (multiple-value-bind (width ascent descent left right -;;; font-ascent font-descent direction -;;; first-not-done) -;;; (beagle-text-extents medium beaglefont string -;;; :start start :end position-newline) -;;; (declare (ignorable left right -;;; font-ascent font-descent -;;; direction first-not-done)) -;;; (multiple-value-bind (w h x y baseline) -;;; (text-size medium string :text-style text-style -;;; :start (1+ position-newline) :end end) -;;; (values (max w width) (+ ascent descent h) -;;; x (+ ascent descent y) (+ ascent descent baseline))))) -;;; (t -;;; (multiple-value-bind (width ascent descent left right -;;; font-ascent font-descent direction -;;; first-not-done) -;;; (beagle-text-extents medium beaglefont string -;;; :start start :end end) -;;; (declare (ignorable left right -;;; font-ascent font-descent -;;; direction first-not-done)) -;;; ;; Horrible hackery on the baseline; but it appears to work. Weird -;;; (values width (+ ascent descent) width 0 (+ ascent 2))) )))))) ) -;;;;;; (values width (+ ascent descent) width 0 ascent)) )))))) ) -;;; -;;;(defun beagle-text-extents (medium font string &key start end) -;;; -;;; ;; ASSUME: the string passed into the method does NOT contain newlines... -;;; ;; ?? -;;; ;; -> (values width ascent descent left right font-ascent font-descent direction (first-not-done =nil)) -;;; (let ((objc-string (%make-nsstring (subseq string start end)))) -;;; (slet ((bsize (send objc-string :size-with-attributes (reuse-attribute-dictionary medium font)))) -;;; (values (pref bsize :ize.width) ; width -;;; (send font 'ascender) ; ascent -;;; (abs (send font 'descender)) ; descent - in Cocoa, -ve. Max +ve for McCLIM -;;; 0 ; left -;;; (pref bsize :ize.width) ; right bearing of rightmost character -;;; (send font 'ascender) ; font-ascent -;;; (abs (send font 'descender)) ; font-descent -;;; nil ; direction -;;; nil)))) ; first not done - - ;; Note: we DO NOT want to draw the fonts in the medium-foreground colour - we want to draw them in a specific ;; colour (unless McCLIM sets the medium foreground colour in order to achieve drawing elements in specific @@ -290,7 +232,6 @@ ;; other threads don;t come along and bash the dictionary in the middle ;; of some operation (defun reuse-attribute-dictionary (medium font &key (colour nil)) - (debug-log 2 "fonts.lisp -> reuse-attribute-dictionary~%") (or reusable-dict (setf reusable-dict (send (@class ns-mutable-dictionary) :dictionary-with-capacity 3)) (send reusable-dict 'autorelease)) Index: beagle/lisp-view-additional.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/lisp-view-additional.lisp,v retrieving revision 1.1 diff -u -r1.1 lisp-view-additional.lisp --- beagle/lisp-view-additional.lisp 11 Jul 2004 19:48:16 -0000 1.1 +++ beagle/lisp-view-additional.lisp 26 Apr 2005 22:33:42 -0000 @@ -34,14 +34,30 @@ ;;; unit as they are defined. This is a (hopefully temporary) work-around ;;; until that's resolved. +(define-objc-method ((:void :stroke-path path :in-colour colour) lisp-view) + (when (send self 'lock-focus-if-can-draw) + (send path :set-colour colour) + (send path :set-fill #$NO) + (send path 'draw) + (send path 'release) + (send self 'unlock-focus))) + +(define-objc-method ((:void :fill-path path :in-colour colour) lisp-view) + (when (send self 'lock-focus-if-can-draw) + (send path :set-colour colour) + (send path :set-fill #$YES) + (send path 'draw) + (send path 'release) + (send self 'unlock-focus))) + (define-objc-method ((:void :set-bounds (:ect bounds)) lisp-view) (send-super :set-bounds bounds) - (send self 'fill-bounds) +;;; (send self 'fill-bounds) (send self 'establish-tracking-rect)) (define-objc-method ((:void :set-bounds-origin (:oint point)) lisp-view) (send-super :set-bounds-origin point) - (send self 'fill-bounds) +;;; (send self 'fill-bounds) (send self 'establish-tracking-rect)) (define-objc-method ((:void :set-bounds-rotation (:float angle)) lisp-view) @@ -50,7 +66,7 @@ (define-objc-method ((:void :set-bounds-size (:ize size)) lisp-view) (send-super :set-bounds-size size) - (send self 'fill-bounds) +;;; (send self 'fill-bounds) (send self 'establish-tracking-rect)) (define-objc-method ((:void :translate-origin-to-point (:oint point)) lisp-view) @@ -67,7 +83,7 @@ (define-objc-method ((:void :set-frame (:ect frame)) lisp-view) (send-super :set-frame frame) - (send self 'fill-bounds) +;;; (send self 'fill-bounds) (send self 'establish-tracking-rect)) (define-objc-method ((:void :set-frame-origin (:oint point)) lisp-view) @@ -80,7 +96,7 @@ (define-objc-method ((:void :set-frame-size (:ize size)) lisp-view) (send-super :set-frame-size size) - (send self 'fill-bounds) +;;; (send self 'fill-bounds) (send self 'establish-tracking-rect)) ;;; --->8--- end cut for kludgey work-around of OpenMCL bug --->8--- Index: beagle/lisp-view.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/lisp-view.lisp,v retrieving revision 1.4 diff -u -r1.4 lisp-view.lisp --- beagle/lisp-view.lisp 21 Aug 2004 20:51:28 -0000 1.4 +++ beagle/lisp-view.lisp 26 Apr 2005 22:33:43 -0000 @@ -68,14 +68,14 @@ (define-objc-method ((: is-flipped) lisp-view) #$YES) -;;;(define-objc-method ((:void :draw-rect (:ect rect)) -;;; lisp-view) -;;;;;; (send-super :draw-rect rect) ; <- is this right? -;;; (slet ((bounds (send self 'bounds))) -;;; (if (eql (%null-ptr) (view-background-colour self)) -;;; (send (the ns-color (send (@class ns-color) 'white-color)) 'set) -;;; (send (the ns-color (view-background-colour self)) 'set)) -;;; (#_NSRectFill bounds))) +(define-objc-method ((:void :draw-rect (:ect rect)) lisp-view) + ;; Set the background colour + (if (eql (%null-ptr) (view-background-colour self)) + (send (the ns-color (send (@class ns-color) 'white-color)) 'set) + (send (the ns-color (view-background-colour self)) 'set)) + + ;; Fill the 'dirty' rect with background colour. + (#_NSRectFill rect)) (define-objc-method ((:void :draw-string string :at-point (:oint point) @@ -95,23 +95,6 @@ ;;; (send (send self 'window) 'flush-window)) ) -(define-objc-method ((:void :stroke-path path :in-colour colour) lisp-view) - (when (send self 'lock-focus-if-can-draw) - (send (the ns-color colour) 'set) ; colour for current graphics context - (send path 'stroke) -;;; (send (send self 'window) 'flush-window) - (send self 'unlock-focus)) -;;; (send (send self 'window) 'flush-window)) - ) - -(define-objc-method ((:void :fill-path path :in-colour colour) lisp-view) - (when (send self 'lock-focus-if-can-draw) - (send (the ns-color colour) 'set) ; colour for current graphics context - (send path 'fill) -;;; (send (send self 'window) 'flush-window) - (send self 'unlock-focus)) -;;; (send (send self 'window) 'flush-window)) - ) (define-objc-method ((:id :copy-bitmap-from-region (:ect rect)) lisp-view) (debug-log 1 "lisp-view -> copy-bitmap-from-region (~A ~A ~A ~A)~%" @@ -141,14 +124,18 @@ ; [image release]; (when (send self 'lock-focus-if-can-draw) - (progn - (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) + (send image :dissolve-to-point point :fraction 1.0)) ;;; (send (send self 'window) 'flush-window) - (send self 'unlock-focus))) + (send self 'unlock-focus)) ;;; (send (send self 'window) 'flush-window)) ) +(define-objc-method ((:void :draw-image image :at-point (:oint point)) lisp-view) + (when (send self 'lock-focus-if-can-draw) + (send image :dissolve-to-point point :fraction 1.0) + (send self 'unlock-focus))) + ;;; ---------------------------------------------------------------------------- ;;; Tracking rectangle support. Each view establishes a tracking rectangle @@ -182,19 +169,19 @@ ;;; Support method; when the bounds or frame are reset, fill them with whatever ;;; background colour they have set. -(define-objc-method ((:void fill-bounds) lisp-view) -;;; (nslog (format nil "setting view bounds, about to attempt to lock focus for filling~%")) - (when (send self 'lock-focus-if-can-draw) -;;; (nslog (format nil "got lock~%")) - (if (eql (%null-ptr) (view-background-colour self)) - (send (the ns-color (send (@class ns-color) 'white-color)) 'set) - (send (the ns-color (view-background-colour self)) 'set)) - (slet ((bounds (send self 'bounds))) - (#_NSRectFill bounds)) -;;; (send (send self 'window) 'flush-window) - (send self 'unlock-focus)) -;;; (send (send self 'window) 'flush-window)) - ) +;;;(define-objc-method ((:void fill-bounds) lisp-view) +;;;;;; (nslog (format nil "setting view bounds, about to attempt to lock focus for filling~%")) +;;; (when (send self 'lock-focus-if-can-draw) +;;;;;; (nslog (format nil "got lock~%")) +;;; (if (eql (%null-ptr) (view-background-colour self)) +;;; (send (the ns-color (send (@class ns-color) 'white-color)) 'set) +;;; (send (the ns-color (view-background-colour self)) 'set)) +;;; (slet ((bounds (send self 'bounds))) +;;; (#_NSRectFill bounds)) +;;;;;; (send (send self 'window) 'flush-window) +;;; (send self 'unlock-focus)) +;;;;;; (send (send self 'window) 'flush-window)) +;;; ) ;;; Override the various :set-bounds-size etc. methods so we can reset the tracking ;;; rectangle when they change. Index: beagle/load-beagle.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/load-beagle.lisp,v retrieving revision 1.1 diff -u -r1.1 load-beagle.lisp --- beagle/load-beagle.lisp 21 Aug 2004 15:02:36 -0000 1.1 +++ beagle/load-beagle.lisp 26 Apr 2005 22:33:43 -0000 @@ -1,7 +1,7 @@ (format t "Ensure you have issued the commands: (require \"cocoa\") and (require \"asdf\")...~%") (format t "~%Loading Beagle~%") ;;;(load "/Users/duncan/sandbox/evins/McCLIM/Backends/Cocoa/src/cocoa-backend.asd") -(load "/Users/duncan/sandbox/mikemac/McCLIM/Backends/beagle/beagle-backend.asd") +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/Backends/beagle/beagle-backend.asd") (asdf:operate 'asdf:load-op 'beagle) ;;; Use this to specify the frame manager you want to use by default (note: if you ;;; want 'beagle::beagle-aqua-frame-manager, you don't need to set this since that Index: beagle/load-clim.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/load-clim.lisp,v retrieving revision 1.2 diff -u -r1.2 load-clim.lisp --- beagle/load-clim.lisp 21 Aug 2004 15:02:36 -0000 1.2 +++ beagle/load-clim.lisp 26 Apr 2005 22:33:43 -0000 @@ -1,10 +1,12 @@ (format t "Ensure you have issued the command: (require \"asdf\")...~%") (format t "~%Loading McCLIM~%") ;;;(load "/Users/duncan/sandbox/evins/McCLIM/system") -(load "/Users/duncan/sandbox/mikemac/McCLIM/system") +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/system") (asdf:operate 'asdf:load-op 'clim) (asdf:operate 'asdf:load-op 'clim-examples) ;;;(load "/Users/duncan/sandbox/evins/McCLIM/Apps/Listener/clim-listener.asd") -(load "/Users/duncan/sandbox/mikemac/McCLIM/Apps/Listener/clim-listener.asd") +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/Apps/Listener/clim-listener.asd") (asdf:operate 'asdf:load-op 'clim-listener) +(load "/Users/duncan/sandbox/common-lisp.net/mcclim/Apps/Inspector/clouseau.asd") +(asdf:operate 'asdf:load-op 'clouseau) (format t "~%Done.~%") Index: beagle/medium.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/medium.lisp,v retrieving revision 1.4 diff -u -r1.4 medium.lisp --- beagle/medium.lisp 21 Aug 2004 20:51:28 -0000 1.4 +++ beagle/medium.lisp 26 Apr 2005 22:33:44 -0000 @@ -94,7 +94,19 @@ (defmethod medium-drawable ((medium beagle-medium)) (debug-log 2 "medium.lisp -> medium-drawable~%") - (and (medium-graft medium) (port-lookup-mirror (port medium) medium))) + + ;; if medium isn't grafted it can't have a 'drawable'. If it *is* grafted, + ;; return the mirror for this medium. + + ;; ::FIXME:: This is broken; looks like this is being invoked with + ;; a 'nil' medium, a medium that is not grafted (!), or a bogus medium. + (format *debug-io* + "Entered medium::medium-drawable with medium arg ~A (should not be nil or bogus!)~%" + medium) + + ;; Add 'nil' in here so the port-lookup-mirror is never invoked; this needs fixing + ;; properly. + (and nil (graft medium) (port-lookup-mirror (port medium) medium))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -103,8 +115,9 @@ ;;; Creates a new medium for the port port. The new medium will have its default ;;; characteristics determined by sheet. +;;; I guess this isn't quite right; should we be grafting the sheet at this +;;; point in the process? Seems rather too early to me... (defmethod make-medium ((port beagle-port) sheet) - (debug-log 2 "medium.lisp -> make-medium~%") (make-instance 'beagle-medium :port port :graft (find-graft :port port) @@ -117,62 +130,187 @@ ;;; Bindings provided: port, mirror, ink, bezier-path, colour -(defgeneric %map-to-named-colour (medium ink)) +(defun make-foreign-colour-from-design (medium design) + "Given a medium and a design, return a native NSColor object. This +object is created for uniform colours, transparent colours, patterns +and stencils." + ;; Deal with uniform designs first (e.g. colours + opacities) + + (let* ((clim-colour (if (or (typep design 'climi::indirect-ink) + (typep design 'climi::standard-flipping-ink) + (typep design 'climi::standard-color)) + (%clim-colour-from-design medium design) + nil)) + (opacity (if (null clim-colour) + nil + (%clim-opacity-from-design medium design)))) + + ;; if a colour was found, return it for use. Need to deal with opacity + ;; in the design here too... + + (unless (null clim-colour) + (return-from make-foreign-colour-from-design (%beagle-pixel (port medium) + clim-colour + :alpha opacity)))) + + ;; Not a uniform design; must be a pattern, stencil or image. Need to deal + ;; with these by converting to an NSImage and creating an NSColor from + ;; this. + + ;; Three (?) cases here... we either have a 'climi::transformed-design', + ;; a 'climi::rectangular-tile' or a 'climi::indexed-pattern'. + + ;; A rectangular tile is a repeating pattern that conceptually fills the + ;; entire plain (region = +everywhere+). + ;; A transformed design is one with a transformation; this affects the + ;; pattern, not any of the designs drawn in the pattern. CLX only supports + ;; translation transformations, so we'll be doing as well as CLX if we do + ;; the same. + + ;; An indexed pattern seems to just define the pattern; presumably it would + ;; be a non-repeating pattern drawn at (0, 0) if it were used directly as + ;; a design in its own right for drawing purposes. + + (let ((pattern (typecase design + (climi::indexed-pattern design) + (climi::rectangular-tile (slot-value design 'climi::design)) + (climi::transformed-design (climi::transformed-design-design design))))) + (let ((bmp-image (%cocoa-image-from-pattern medium pattern))) + + ;; For climi::rectangular-tile we want to create an NSColor that uses this tile as + ;; the ink. + + ;; For the other two, we need to return the NSImage that we want to draw and deal + ;; with the exact location of that image in the drawing functions themselves (not + ;; nice :-< ). Will try to use NSGraphicsContext setPatternPhase to do transform. + + ;; Horrible kludge; wouldn't you think you could directly generate an NSImage from + ;; an NSImageRep subclass? + + ;; These images should be cached someplace too I suspect for performance. + + (let ((pasteboard (send bmp-image 'tiff-representation))) + (let ((image (make-instance 'ns:ns-image :init-with-data pasteboard))) + ;; When we're NOT dealing with a (typep design rectangular-tile) at this + ;; point, just return the image. This will be put on screen directly + ;; by the drawing methods. This may not be quite the right thing, but it + ;; will (hopefully) look better AND be in the right place. ::FIXME:: + (unless (typep design 'climi::rectangular-tile) + (return-from make-foreign-colour-from-design image)) + + ;; Otherwise continue, and set the pattern as the colour (will tile). + (let ((colour (send (@class ns-color) :color-with-pattern-image image))) + colour)))))) + +;;; v need one of these for transformed design too for the listener to work... the +;;; basics are working though, we can generate bmps and get them displayed! Yay! +(defmethod %cocoa-image-from-pattern ((medium beagle-medium) (design climi::indexed-pattern)) + "Given a CLIM pattern #2() + list of designs, return a native NSImage that +represents the pattern. This can be used as an ink (NSColor) in Cocoa. + +Returns a MACPTR containing the NSImage which can be used either in +NSColor (colorFromImage) for tiled designs, or directly with drawInRect +for non-tiled designs." + + ;; Our assumption here is that each design in the pattern is a uniform + ;; design (i.e. a colour (with or without an opacity) for patterns, or + ;; an opacity (with no colour) for stencils). I suspect in the generalised + ;; drawing model of CLIM this is a bad assumption, but for real-world + ;; applications it feels like it should be ok. + + ;; Construct data by iterating over the pixels in the pattern, and + ;; creating a new matrix where each value is a 16- or 32-bit colour + ;; value. We then construct an NSImage and pass this data into the + ;; image object (setting width, height and depth for the bitmap) + ;; which is returned for use. + + ;; ::FIXME:: the current implementation is wasteful, assuming full 32-bit + ;; values for each pixel. It's likely this could be reduced + ;; (especially for simple patterns and stencils) but for now at least it + ;; should work; more on efficiency later. + + (let* ((array (slot-value design 'climi::array)) + (inks (slot-value design 'climi::designs)) + (height (pattern-height design)) + (width (pattern-width design)) + (image (make-instance 'ns:ns-bitmap-image-rep + :init-with-bitmap-data-planes (%null-ptr) ; Cocoa will allocate + :pixels-wide width ; int-width + :pixels-high height ; int-height + :bits-per-sample 8 ; int-bps + :samples-per-pixel 4 ; RGB + opacity | int-spp + :has-alpha #$YES ; bool-alpha + :is-planar #$NO ; bool-planar + :color-space-name #@"NSCalibratedRGBColorSpace" + :bytes-per-row 0 ; int-bpr - Cocoa works out from + ; width, bps, spp with no padding. + :bits-per-pixel 0)) ; int-bits - Cocoa interprets to + ; be expected value, without any + ; meaningless bits + (planes (send image 'bitmap-data))) + + ;; populate 'planes' with bytes for the image. Note that RGB components must be + ;; pre-multiplied with the 'coverage' (alpha) component. We get this for free + ;; if we use ns-color to calculate the R, G and B components (I hope :-) + + ;; This code basically ripped off from that in CLX;medium.lisp (design-gcontext) + + (dotimes (y height) + (dotimes (x width) + (let* ((ink (elt inks (aref array y x))) + ;; Generate a colour for this design (will include an opacity - or it would + ;; if we had a way to get an opacity from a design that wasn't itself an + ;; opacity, but rather made use of an opacity. %m-t-n-c defaults opacity to + ;; 1.0). + (colour (if (eq ink +transparent-ink+) + (send (@class ns-color) 'clear-color) ; need to do better... + (%beagle-pixel (port medium) (%clim-colour-from-design medium ink)))) + ;; Then extract the R,G,B + coverage from this colour... + (red (if (eq ink +transparent-ink+) + (coerce 0 '(unsigned-byte 8)) + (coerce (round (* (send (the ns-color colour) 'red-component) 255)) '(unsigned-byte 8)))) + (green (if (eq ink +transparent-ink+) + (coerce 0 '(unsigned-byte 8)) + (coerce (round (* (send (the ns-color colour) 'green-component) 255)) '(unsigned-byte 8)))) + (blue (if (eq ink +transparent-ink+) + (coerce 0 '(unsigned-byte 8)) + (coerce (round (* (send (the ns-color colour) 'blue-component) 255)) '(unsigned-byte 8)))) + (opacity (coerce (round (* (send (the ns-color colour) 'alpha-component) 255)) '(unsigned-byte 8)))) + + ;; and set it in the (char *) named planes. rgb,o {0..255} + + (setf (ccl::%get-unsigned-byte planes (+ (* y width 4) (* x 4) 0)) red) + (setf (ccl::%get-unsigned-byte planes (+ (* y width 4) (* x 4) 1)) green) + (setf (ccl::%get-unsigned-byte planes (+ (* y width 4) (* x 4) 2)) blue) + (setf (ccl::%get-unsigned-byte planes (+ (* y width 4) (* x 4) 3)) opacity)))) + + image)) + +(defmethod %clim-opacity-from-design ((medium beagle-medium) design) + (declare (ignore medium design)) + ;; Just a stub for now. ::FIXME:: Need to ask on the list about this... + 1.0) + +(defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::indirect-ink)) + (if (eql design +foreground-ink+) + (medium-foreground medium) + (medium-background medium))) -(defmethod %map-to-named-colour ((medium beagle-medium) (ink (eql +foreground-ink+))) - (debug-log 2 "medium.lisp -> %map-to-named-colour (+foreground-ink+)~%") - (medium-foreground medium)) - -(defmethod %map-to-named-colour ((medium beagle-medium) (ink (eql +background-ink+))) - (debug-log 2 "medium.lisp -> %map-to-named-colour (+background-ink+)~%") - (medium-background medium)) -(defmethod %map-to-named-colour ((medium beagle-medium) (ink (eql +flipping-ink+))) - (debug-log 2 "medium.lisp -> %map-to-named-colour (+flipping-ink+)~%") +(defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::standard-flipping-ink)) +red+) -(defmethod %map-to-named-colour ((medium beagle-medium) (ink t)) - (debug-log 2 "medium.lisp -> %map-to-named-colour (ink t)~%") - ink) - -;;; See OpenMCL mailing [19th Feb 2004 - Gary Byers - Re: mcl-doubles problem] and follow-up -;;; [20th Feb 2004 - Bill Schottstaedt - Re: mcl-doubles problem]. -;;; -;;; Not actually used at the moment, but should be useful going forward... -(defmacro with-foreign-double-float-array ((ptr-var lisp-array) &body body) - (let* ((length (gensym)) (size (gensym))) - `(let* ((,length (length ,lisp-array)) - (,size (* ,length 8))) - (%stack-block ((,ptr-var ,size)) - (dotimes (i ,length) - (setf (%get-double-float ,ptr-var (* i 8)) (aref ,lisp-array i))) - ,@body)))) - -;;; Do we *really* need to do this prior to every drawing request? We must be able to capture -;;; these as a default and then we could just monitor changes to the drawing options, and handle -;;; them as they happen. Maybe this isn't so easy, but it certainly feels like it should be -;;; faster. - -(defmacro %with-beagle-graphics ((medium) &body body) - `(let* ((port (port ,medium)) - (mirror (port-lookup-mirror port (medium-sheet ,medium)))) - (when mirror - (let* ((ink (medium-ink ,medium)) - (line-style (medium-line-style ,medium)) - ;; CONVERT: if (eql ink +background-ink+) -> (medium-background medium) - ;; if (eql ink +foreground-ink+) -> (medium-foreground medium) - ;; if (eql ink +flipping-ink+) -> ( ??? ) - (colour (if (eql ink +flipping-ink+) - (%beagle-pixel port (%map-to-named-colour ,medium ink) :alpha 0.4) - (%beagle-pixel port (%map-to-named-colour ,medium ink)))) - (font (%text-style->beagle-font (or (medium-text-style ,medium) *default-text-style*))) - (width (coerce (line-style-thickness line-style) 'short-float)) - (cap (%translate-cap-shape (line-style-cap-shape line-style))) - (join (%translate-joint-shape (line-style-joint-shape line-style)))) - (unwind-protect - ;; #+nil - ;; (ccl::send bezier-path :set-line-dash (%translate-line-dash-pattern (line-dash-style line-style)) :count (%translate-line-dash-count (line-dash-style line-style)) :phase (%translate-line-dash-phase (line-dash-style line-style))) - ,@body))))) +(defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::standard-color)) + (declare (ignore medium)) + design) + +;; don't think this is ever invoked... +(defmethod %clim-colour-from-design ((medium beagle-medium) design) +; (declare (ignore design)) +; nil) + (error "Shouldn't be here!") + design) + (defmacro with-beagle-graphics ((medium) &body body) `(let* ((port (port ,medium)) @@ -180,73 +318,92 @@ (when mirror (let* ((ink (medium-ink ,medium)) (line-style (medium-line-style ,medium)) - ;; CONVERT: if (eql ink +background-ink+) -> (medium-background medium) - ;; if (eql ink +foreground-ink+) -> (medium-foreground medium) - ;; if (eql ink +flipping-ink+) -> ( ??? ) - (colour (if (eql ink +flipping-ink+) - (%beagle-pixel port (%map-to-named-colour ,medium ink) :alpha 0.4) - (%beagle-pixel port (%map-to-named-colour ,medium ink)))) - (font (%text-style->beagle-font (or (medium-text-style ,medium) *default-text-style*))) + + ;; Think we need to handle this differently; we either want an + ;; NSColor that is a solid (possibly transparent) colour (merge + ;; ink + opacity) OR a general design (pattern, stencil or 'image' + ;; (just a complex pattern)) in which case we use 'colorWithPatternImage:' + ;; in NSColor to give us a 'colour'which can be set. The only real + ;; complication with this is how (for images) we work out the phase + ;; offset to set in the NSGraphicsContext. + + (colour (make-foreign-colour-from-design ,medium ink)) (width (coerce (line-style-thickness line-style) 'short-float)) (cap (%translate-cap-shape (line-style-cap-shape line-style))) (join (%translate-joint-shape (line-style-joint-shape line-style))) - (path (send (@class ns-bezier-path) 'bezier-path))) - ;; #+nil - ;; (ccl::send bezier-path :set-line-dash (%translate-line-dash-pattern (line-dash-style line-style)) :count (%translate-line-dash-count (line-dash-style line-style)) :phase (%translate-line-dash-phase (line-dash-style line-style))) + ;; DASHES is a Lisp SEQUENCE + (dashes (line-style-dashes line-style)) + (path (make-instance 'lisp-bezier-path))) (send path :set-line-cap-style cap) (send path :set-line-join-style join) (send path :set-line-width width) - ,@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Note: we extract the dash pattern from the line-style via "line-dash-style", but the spec says we should -;; use the "line-style-dashes" generic function to get this information. Possible specification violation? - -(defun %translate-line-dash-pattern (line-dash-in) - "CLIM defines line dash patterns as a vector (usually) of alternating -solid and empty segments. This is the same way that Cocoa defines line -dash patterns, so we just need to convert between a Lisp vector and an -Objective C array-of-floats." - (debug-log 2 "medium.lisp -> %translate-line-dash-pattern~%") - line-dash-in) - -(defun %translate-line-dash-phase (line-dash-in) - "Indicates (in view coordinate units) how far into the pattern to start. -We always start at the beginning of the pattern, so this is hard-coded -to 0.0" - (declare (ignore line-dash-in)) - (debug-log 2 "medium.lisp -> %translate-line-dash-phase~%") - 0.0) - -(defun %translate-line-dash-count (line-dash-in) - "Indicates the number of solid / empty segments that make up the pattern. -This is equal to the length of the provided line-dash pattern." - (debug-log 2 "medium.lisp -> %translate-line-dash-count~%") - (length line-dash-in)) + ;; Looks like McCLIM doesn't substitute the 'T' line-dash option before + ;; we get to the back end. Boo! + (when (eq dashes T) + ;; Provide default dash pattern... no idea why, but when I use + ;; #(5.0 5.0) as the dafault dash, it gets displayed as a solid + ;; line (no dashing). So the default is larger than it needs to + ;; be. Weird, but at least this works. + (setf dashes #(5.0 5.0 5.0 5.0))) + + ;; We only want to invoke this next bit when 'dashes' is NOT nil. Any + ;; other value at this point is OK. + + ;; Prior to this shorter form, was using: + ;; + ;; (or (listp dashes) + ;; (arrayp dashes) + ;; (vectorp dashes) + ;; (simple-vector-p dashes))) + ;; + ;; ... in place of the current (or...) form. Fewer checks should be quicker. + + (when (and dashes + (or (listp dashes) + (vectorp dashes))) + (assert (evenp (length dashes))) + + ;; Always start the path at the beginning; note that CLIM specifies + ;; that the pattern starts with an UNPAINTED segment and finishes + ;; with a PAINTED segment, Cocoa is the other way around. + ;; We need to add an 'empty' segment to the front and end of the + ;; line. + ;; prefix and prepend '0.0' onto 'dashes'. + + (let ((size (* (+ 2 (length dashes)) 4))) + (ccl::%stack-block ((beagle-dash size)) + (setf (ccl::%get-single-float beagle-dash 0) 0.0) + (dotimes (i (length dashes)) + (setf (ccl::%get-single-float beagle-dash (* (1+ i) 4)) (elt dashes i))) + (setf (ccl::%get-single-float beagle-dash (- 4 size)) 0.0) + (send path :set-line-dash beagle-dash + :count (+ 2 (length dashes)) + :phase 0.0)))) + ,@body)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-finish-output medium [Generic function] +;;; medium-finish-output medium [Generic function] -;;; Ensures that all the output sent to medium has reached its destination, and only then return false. -;;; This is used by finish-output. +;;; Ensures that all the output sent to medium has reached its destination, +;;; and only then return false. This is used by finish-output. ;;; COCOA NOTE: each drawing operation flushes the window already, so ;;; we never get into the position of having unmirrored drawing ops ;;; in the off-screen buffer. (defmethod medium-finish-output ((medium beagle-medium)) - (debug-log 2 "medium.lisp -> medium-finish-output~%") - (progn - (send (send (port-lookup-mirror *beagle-port* (medium-sheet medium)) 'window) 'flush-window-if-needed) - nil)) + (send (send (port-lookup-mirror *beagle-port* (medium-sheet medium)) 'window) + 'flush-window-if-needed) + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-force-output medium [Generic function] +;;; medium-force-output medium [Generic function] -;;; Like medium-finish-output, except that it may return false without waiting for the output to complete. +;;; Like medium-finish-output, except that it may return false without +;;; waiting for the output to complete. ;;; This is used by force-output. ;;; COCOA NOTE: each drawing operation flushes the window already, so @@ -254,117 +411,106 @@ ;;; in the off-screen buffer. (defmethod medium-force-output ((medium beagle-medium)) - (debug-log 2 "medium.lisp -> medium-force-output~%") - (progn - (send (send (port-lookup-mirror *beagle-port* (medium-sheet medium)) 'window) 'flush-window) - nil)) + (send (send (port-lookup-mirror *beagle-port* (medium-sheet medium)) 'window) + 'flush-window) + nil) + -;;; ::FIXME:: How does this get sent? Weird. Not sure this is actually correct... (defmethod medium-beep ((medium beagle-medium)) (#_NSBeep)) ;;; Translate from a CLIM cap-shape style to a Cocoa cap shape. -(defconstant +beagle-cap-shape-map+ `((:butt . ,#$NSButtLineCapStyle) - (:square . ,#$NSSquareLineCapStyle) - (:round . ,#$NSRoundLineCapStyle) - (:no-end-point . ,#$NSRoundLineCapStyle))) +(defconstant +beagle-cap-shape-map+ (list `(:butt . ,#$NSButtLineCapStyle) + `(:square . ,#$NSSquareLineCapStyle) + `(:round . ,#$NSRoundLineCapStyle) + `(:no-end-point . ,#$NSRoundLineCapStyle))) (defun %translate-cap-shape (clim-shape) - (debug-log 2 "medium.lisp -> %translate-cap-shape~%") (let ((beagle-shape (cdr (assoc clim-shape +beagle-cap-shape-map+)))) (if beagle-shape beagle-shape - (progn - (warn "Unknown cap style ~S, using :butt" clim-shape) - #$NSButtLineCapStyle)))) ; Default is :butt, see spec 10.3.1 (why does CLX default to :round?) - -(defconstant +beagle-line-joint-map+ `((:miter . ,#$NSMiterLineJoinStyle) - (:round . ,#$NSRoundLineJoinStyle) - (:bevel . ,#$NSBevelLineJoinStyle) - (:none . ,#$NSBevelLineJoinStyle))) ; Looks like :none = :bevel from spec 10.3.1 + #$NSButtLineCapStyle))) + +(defconstant +beagle-line-joint-map+ (list `(:miter . ,#$NSMiterLineJoinStyle) + `(:round . ,#$NSRoundLineJoinStyle) + `(:bevel . ,#$NSBevelLineJoinStyle) + `(:none . ,#$NSBevelLineJoinStyle))) (defun %translate-joint-shape (clim-joint) - (debug-log 2 "medium.lisp -> %translate-joint-shape~%") (let ((beagle-shape (cdr (assoc clim-joint +beagle-line-joint-map+)))) (if beagle-shape beagle-shape - (progn - (warn "Unknown joint shape ~S, using :miter" clim-joint) - #$NSMiterLineJoinStyle)))) ; default join style = :miter from spec 10.3.1 + #$NSMiterLineJoinStyle))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-copy-area from-drawable from-x from-y width height to-drawable to-x to-y [Generic function] +;;; medium-copy-area from-drawable from-x from-y [Generic function] +;;; width height to-drawable +;;; to-x to-y -;;; Copies the pixels from the source drawable from-drawable at the position (from-x, from-y) to the destination -;;; drawable to-drawable at the position (to-x, to-y). A rectangle whose width and height is specified by width -;;; and height is copied. from-x, from-y, to-x, and to-y are specified in user coordinates. The x and y are -;;; transformed by the user transformation. +;;; Copies the pixels from the source drawable from-drawable at the +;;; position (from-x, from-y) to the destination drawable to-drawable at +;;; the position (to-x, to-y). A rectangle whose width and height is +;;; specified by width and height is copied. from-x, from-y, to-x, and +;;; to-y are specified in user coordinates. The x and y are transformed +;;; by the user transformation. -;;; This is intended to specialize on both the from-drawable and to-drawable arguments. from-drawable and -;;; to-drawable may be either mediums or pixmaps. +;;; This is intended to specialize on both the from-drawable and +;;; to-drawable arguments. from-drawable and to-drawable may be either +;;; mediums or pixmaps. (defun medium-copy-area-aux (from from-x from-y width height to to-x to-y) - "Helper method for copying areas. ``from'' and ``to'' must both be 'mirror' objects. From and To coordinates -must already be transformed as appropriate." -;;; (format *debug-io* "Entered medium-copy-area-aux with from = ~S and to = ~S~%" from to) - (let* ((source-region (ccl::make-ns-rect (+ (round-coordinate from-x) 0.5) - (+ (round-coordinate from-y) 0.5) - (round-coordinate width) - (round-coordinate height))) - (target-point (ccl::make-ns-point (+ (round-coordinate to-x) 0.5) - (+ (round-coordinate to-y) 0.5))) + "Helper method for copying areas. 'from' and 'to' must both be 'mirror' +objects. From and To coordinates must already be transformed as appropriate." + (let* ((source-region (ccl::make-ns-rect (+ from-x 0.5) (+ from-y 0.5) + width height)) + (target-point (ccl::make-ns-point (+ to-x 0.5) + (+ to-y 0.5))) (bitmap-image (send from :copy-bitmap-from-region source-region))) -;;; (format *debug-io* "Set source-region = ~S, target-point = ~S, bitmap image = ~S~%" -;;; source-region target-point (if (eql bitmap-image (%null-ptr)) -;;; "nil" -;;; bitmap-image)) (when (eql bitmap-image (%null-ptr)) (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") (return-from medium-copy-area-aux nil)) -;;; (format *debug-io* "Got a non-null bitmap image~%") - (debug-log 3 "medium.lisp: got bitmap-image ~S~%" (ccl::description bitmap-image)) - (debug-log 3 "pasting bitmap image to: ~A ~A~%" to-x to-y) -;;; (format *debug-io* "Doing the biz...~%") (send to :paste-bitmap bitmap-image :to-point target-point) -;;; (format *debug-io* "releasing the bitmap image") (send bitmap-image 'release))) (defmethod medium-copy-area ((from-drawable beagle-medium) from-x from-y width height (to-drawable beagle-medium) to-x to-y) -;;; (format *debug-io* "medium.lisp -> medium-copy-area (medium medium)~%") - (debug-log 2 "medium.lisp -> medium-copy-area (drawable drawable)~%") - (debug-log 3 " fromx=~A fromy=~A width=~A height=~A tox=~A toy=~A~%" from-x from-y width height to-x to-y) - ;; width + height *are* a width + a height. from-x, from-y and to-x, to-y specify the UPPER-LEFT of the region; - ;; for us they need to specify the LOWER-LEFT. Remember that these will be flipped in the NSView, but I'm not - ;; convinced this is quite correct! ::FIXME:: + ;; width + height *are* a width + a height. from-x, from-y and to-x, to-y specify + ;; the UPPER-LEFT of the region; for us they need to specify the LOWER-LEFT. Remember + ;; that these will be flipped in the NSView, but I'm not convinced this is quite + ;; correct! ::FIXME:: - ;; We appear to COPY the area correctly, but then PASTE it in the wrong place which is a little - ;; weird. Output looks like: + ;; We appear to COPY the area correctly, but then PASTE it in the wrong place which + ;; is a little weird. Output looks like: ;; ;; m ;; Help (with) com ands ;; - ;; with the 2nd 'm' being copied but put in the wrong place. Need to move it down some (i.e. increase y in the - ;; mcclim coord system). Hence to "to-y" massaging. - ;; Additionally, the paste is a couple of pixels off (slightly too low, and slightly too far to the right). - ;; Probably caused by the way we do rounding (note the cursor rectangle is also off slightly when it's moved). + ;; with the 2nd 'm' being copied but put in the wrong place. Need to move it down + ;; some (i.e. increase y in the mcclim coord system). Hence to "to-y" massaging. + ;; Additionally, the paste is a couple of pixels off (slightly too low, and slightly + ;; too far to the right). + ;; Probably caused by the way we do rounding (note the cursor rectangle is also off + ;; slightly when it's moved). ;; Probably want to "round" everything before adding the 0.5 offset. ;; Apparently there's no need to do this for the "from" coordinates... strange. ;;; (setf from-y (+ from-y height)) (setf to-y (+ to-y height)) - ;; Slight problem here in that the region we copy is actually slightly *smaller* than the cursor, so the - ;; bounding rectangle shows through. I guess (but don't know) that this will go away when flipping ink - ;; is implemented "properly" otherwise we'll need to furtle with this by a pixel or so. ::FIXME:: - - ;; Could *probably* fix this by changing the text-size + text-height methods to *not* make use of - ;; Cocoa's built-in text-height function since that appends padding, and then McCLIM uses the ascent + - ;; descent and appends its own padding and I think these two don't match up... + ;; Slight problem here in that the region we copy is actually slightly *smaller* than + ;; the cursor, so the bounding rectangle shows through. I guess (but don't know) that + ;; this will go away when flipping ink is implemented otherwise we'll need to furtle + ;; with this by a pixel or so. ::FIXME:: + + ;; Could *probably* fix this by changing the text-size + text-height methods to *not* + ;; make use of Cocoa's built-in text-height function since that appends padding, and + ;; then McCLIM uses the ascent + descent and appends its own padding and I think these + ;; two don't match up... - ;; Might be better to do this anyway so that Cocoa back end is closer to CLX back end in all this. + ;; Might be better to do this anyway so that Cocoa back end is closer to CLX back end + ;; in all this. (with-transformed-position ((sheet-native-transformation (medium-sheet from-drawable)) from-x from-y) (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable)) @@ -373,26 +519,9 @@ width height (sheet-direct-mirror (medium-sheet to-drawable)) to-x to-y)))) -;;; (let* ((source-region (ccl::make-ns-rect (+ (round-coordinate from-x) 0.5) -;;; (+ (round-coordinate from-y) 0.5) -;;; (round-coordinate width) -;;; (round-coordinate height))) -;;; (target-point (ccl::make-ns-point (+ (round-coordinate to-x) 0.5) -;;; (+ (round-coordinate to-y) 0.5))) -;;; (bitmap-image (send (sheet-direct-mirror (medium-sheet from-drawable)) :copy-bitmap-from-region source-region))) -;;; (when (eql bitmap-image (%null-ptr)) -;;; (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") -;;; nil) -;;; (debug-log 3 "medium.lisp: got bitmap-image ~S~%" (ccl::description bitmap-image)) -;;; (debug-log 3 "pasting bitmap image to: ~A ~A~%" to-x to-y) -;;; (send (sheet-direct-mirror (medium-sheet to-drawable)) :paste-bitmap bitmap-image :to-point target-point) -;;; (send bitmap-image 'release))))) (defmethod medium-copy-area ((from-drawable beagle-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) -;;; (format *debug-io* "medium.lisp -> medium-copy-area (medium pixmap)~%") - (debug-log 2 "medium.lisp -> medium-copy-area (drawable pixmap)~%") -;;; (setf to-y (+ to-y height)) (with-transformed-position ((sheet-native-transformation (medium-sheet from-drawable)) from-x from-y) (medium-copy-area-aux (sheet-direct-mirror (medium-sheet from-drawable)) from-x from-y @@ -401,8 +530,6 @@ (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable beagle-medium) to-x to-y) -;;; (format *debug-io* "medium.lisp -> medium-copy-area (pixmap medium)~%") - (debug-log 2 "medium.lisp -> medium-copy-area (pixmap drawable)~%") (setf to-y (+ to-y height)) (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable)) to-x to-y) @@ -413,27 +540,20 @@ (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) -;;; (format *debug-io* "medium.lisp -> medium-copy-area (pixmap pixmap)~%") - (debug-log 2 "medium.lisp -> medium-copy-area (pixmap pixmap)~%") (medium-copy-area-aux (pixmap-mirror from-drawable) from-x from-y width height (pixmap-mirror to-drawable) to-x to-y)) -;;; (xlib:copy-area (pixmap-mirror from-drawable) -;;; (medium-gcontext from-drawable +background-ink+) -;;; (round from-x) (round from-y) (round width) (round height) -;;; (pixmap-mirror to-drawable) -;;; (round to-x) (round to-y))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-rectangles* medium coord-seq [Generic function] +;;; medium-draw-rectangles* medium coord-seq [Generic function] -;;; Draws a set of rectangles on the medium medium. coord-seq is a sequence of coordinate pairs, -;;; which are real numbers. It is an error if coord-seq does not contain an even number of elements. -;;; Each successive pair of coordinate pairs is taken as the upper-left and lower-right corner of -;;; the rectangle. +;;; Draws a set of rectangles on the medium medium. coord-seq is a +;;; sequence of coordinate pairs, which are real numbers. It is an +;;; error if coord-seq does not contain an even number of elements. +;;; Each successive pair of coordinate pairs is taken as the upper-left +;;; and lower-right corner of the rectangle. (defmethod medium-draw-rectangles* ((medium beagle-medium) coord-seq filled) (let ((tr (sheet-native-transformation (medium-sheet medium)))) @@ -442,39 +562,41 @@ (do-sequence ((left top right bottom) coord-seq) (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - (let ((left (round-coordinate left)) - (top (round-coordinate top)) - (right (round-coordinate right)) - (bottom (round-coordinate bottom))) - (send path :append-bezier-path-with-rect (ccl::make-ns-rect left bottom (- right left) (- top bottom))))) + (let ((rect (ccl::make-ns-rect left bottom (- right left) (- top bottom)))) + (send path :append-bezier-path-with-rect rect))) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-ellipse* medium center-x center-y radius-1-dx radius-1-dy [Generic function] -;;; radius-2-dx radius-2-dy -;;; start-angle end-angle - -;;; Draws an ellipse or elliptical arc on the medium medium. The center of the ellipse is at (x,y), -;;; and the radii are specified by the two vectors (radius-1-dx, radius-1-dy) and (radius-2-dx, -;;; radius-2-dy). - -;;; start-angle and end-angle are real numbers that specify an arc rather than a complete ellipse. -;;; Note that the medium and device transformations must be applied to the angles as well. - -;;; AGAIN, WE HAVE THE NON-STANDARD "filled" PARAMETER. Method is similar in execution (complete with -;;; axis-alignment limitation) to CLX back end. We add another limitation in that we ignore the start -;;; and end angles, but at least we made a start ;-) - -(defmethod medium-draw-ellipse* ((medium beagle-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) +;;; medium-draw-ellipse* medium center-x center-y [Generic function] +;;; radius-1-dx radius-1-dy +;;; radius-2-dx radius-2-dy +;;; start-angle end-angle + +;;; Draws an ellipse or elliptical arc on the medium medium. The center +;;; of the ellipse is at (x,y), and the radii are specified by the two +;;; vectors (radius-1-dx, radius-1-dy) and (radius-2-dx, radius-2-dy). + +;;; start-angle and end-angle are real numbers that specify an arc rather +;;; than a complete ellipse. Note that the medium and device +;;; transformations must be applied to the angles as well. + +;;; Method is similar in execution (complete with axis-alignment +;;; limitation) to CLX back end. We add another limitation in that we +;;; ignore the start and end angles, but at least we made a start ;-) + +(defmethod medium-draw-ellipse* ((medium beagle-medium) center-x center-y + radius-1-dx radius-1-dy radius-2-dx radius-2-dy + start-angle end-angle filled) (declare (ignore start-angle end-angle)) - (debug-log 2 "medium.lisp -> medium-draw-ellipse*~%") ;;; Suspect we should be transforming the radii as well as the centre... (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "medium-draw-ellipse* not implemented for non axis-aligned ellipses.")) - (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) center-x center-y) + (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) + center-x + center-y) (with-beagle-graphics (medium) (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) (radius-dy (abs (+ radius-1-dy radius-2-dy))) @@ -482,206 +604,146 @@ (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) (height (* 2 radius-dy))) - (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect origin-x origin-y width height)) + (send path :append-bezier-path-with-oval-in-rect (ccl::make-ns-rect origin-x origin-y + width height)) (if filled (send mirror :fill-path path :in-colour colour) (send mirror :stroke-path path :in-colour colour)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; NOT IN SPEC... - -(defmethod medium-draw-circle* ((medium beagle-medium) center-x center-y radius start-angle end-angle filled) +(defmethod medium-draw-circle* ((medium beagle-medium) center-x center-y + radius start-angle end-angle filled) (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-beagle-graphics (medium) (with-transformed-position (tr center-x center-y) - (slet ((point (ns-make-point (coerce center-x 'short-float) (coerce center-y 'short-float)))) - (progn - ;; Looks to me like this will give part of a circle with a flattened edge - ;; when (not (eq start-angle end-angle)). Maybe that's what we want... - - ;; Cocoa measures angles in DEGREES (not radians) from the x-axis. Need - ;; to ensure this is what CLIM is doing too! - (send path :append-bezier-path-with-arc-with-center point - :radius radius - :start-angle (/ start-angle (/ pi 180)) - :end-angle (/ end-angle (/ pi 180)) - :clockwise NIL) - (if filled - (send mirror :fill-path path :in-colour colour) - (send mirror :stroke-path path :in-colour colour)))))))) + (slet ((point (ns-make-point (coerce center-x 'short-float) + (coerce center-y 'short-float)))) + (send path :append-bezier-path-with-arc-with-center point + :radius radius + :start-angle (/ start-angle (/ pi 180)) + :end-angle (/ end-angle (/ pi 180)) + :clockwise NIL))) + (if filled + (send mirror :fill-path path :in-colour colour) + (send mirror :stroke-path path :in-colour colour))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-point* medium x y [Generic function] +;;; medium-draw-point* medium x y [Generic function] -;;; Draws a point on the medium medium. +;;; Draws a point on the medium 'medium'. (defmethod medium-draw-point* ((medium beagle-medium) x y) - (debug-log 2 "medium.lisp -> medium-draw-point*~%") - (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) - (cond ((< width 2) - (medium-draw-line* medium x y (1+ x) y)) - (t - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))))) + (let ((width (coerce (line-style-thickness (medium-line-style medium)) + 'short-float))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-points* medium coord-seq [Generic function] +;;; medium-draw-points* medium coord-seq [Generic function] -;;; Draws a set of points on the medium medium. coord-seq is a sequence of coordinate pairs, which -;;; are real numbers. It is an error if coord-seq does not contain an even number of elements. +;;; Draws a set of points on the medium medium. coord-seq is a sequence +;;; of coordinate pairs, which are real numbers. It is an error if +;;; coord-seq does not contain an even number of elements. (defmethod medium-draw-points* ((medium beagle-medium) coord-seq) - (debug-log 2 "medium.lisp -> medium-draw-points*~%") (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) - (cond ((< width 2) - (progn - (do-sequence ((x y) coord-seq) - (medium-draw-line* medium x y (1+ x) y)))) - (t - (progn - (do-sequence ((x y) coord-seq) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T)))))))) + (do-sequence ((x y) coord-seq) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-line* medium x1 y1 x2 y2 [Generic function] +;;; medium-draw-line* medium x1 y1 x2 y2 [Generic function] -;;; Draws a line on the medium medium. The line is drawn from (x1,y1) to (x2,y2). +;;; Draws a line on the medium medium. The line is drawn from (x1,y1) +;;; to (x2,y2). (defmethod medium-draw-line* ((medium beagle-medium) x1 y1 x2 y2) - (debug-log 2 "medium.lisp -> medium-draw-line*~%") - ;; Explanation: Drawing primitives in CLIM are specified in sheet coordinate system. We - ;; need to convert these to native coordinates (i.e. coordinates of the mirror) prior to - ;; drawing. Sheets can have arbitrary units (pretty much) and arbitrary extent. (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-beagle-graphics (medium) (with-transformed-position (tr x1 y1) (with-transformed-position (tr x2 y2) - (let ((x1 (round-coordinate x1)) - (y1 (round-coordinate y1)) - (x2 (round-coordinate x2)) - (y2 (round-coordinate y2))) - (cond ((and (<= #x-8000 x1 #x7FFF) (<= #x-8000 y1 #x7FFF) - (<= #x-8000 x2 #x7FFF) (<= #x-8000 y2 #x7FFF)) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) - (progn - (send path :move-to-point p1) - (send path :line-to-point p2) - (send mirror :stroke-path path :in-colour colour)))) - (t - (let ((line (region-intersection (make-rectangle* #x-8000 #x-8000 #x7FFF #x7FFF) - (make-line* x1 y1 x2 y2)))) - (when (linep line) - (multiple-value-bind (x1 y1) (line-start-point* line) - (multiple-value-bind (x2 y2) (line-end-point* line) - (slet ((p1 (ns-make-point (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate x1))) 'short-float) 0.5) - (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate y1))) 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate x2))) 'short-float) 0.5) - (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate y2))) 'short-float) 0.5)))) - (progn - (send path :move-to-point p1) - (send path :line-to-point p2) - (send mirror :stroke-path path :in-colour colour))))))))))))))) - + (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) + (+ (coerce y1 'short-float) 0.5))) + (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) + (+ (coerce y2 'short-float) 0.5)))) + (send path :move-to-point p1) + (send path :line-to-point p2) + (send mirror :stroke-path path :in-colour colour))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-lines* stream position-seq [Generic function] - -;;; Draws a set of disconnected lines on the medium medium. coord-seq is a sequence of coordinate -;;; pairs, which are real numbers. Each successive pair of coordinate pairs is taken as the start -;;; and end position of each line. It is an error if coord-seq does not contain an even number of -;;; elements. +;;; medium-draw-lines* stream position-seq [Generic function] + +;;; Draws a set of disconnected lines on the medium medium. coord-seq +;;; is a sequence of coordinate pairs, which are real numbers. Each +;;; successive pair of coordinate pairs is taken as the start and end +;;; position of each line. It is an error if coord-seq does not contain +;;; an even number of elements. (defmethod medium-draw-lines* ((medium beagle-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) (do-sequence ((x1 y1 x2 y2) coord-seq) - (let ((x1 (round-coordinate x1)) - (y1 (round-coordinate y1)) - (x2 (round-coordinate x2)) - (y2 (round-coordinate y2))) - (cond ((and (<= #x-8000 x1 #x7FFF) (<= #x-8000 y1 #x7FFF) - (<= #x-8000 x2 #x7FFF) (<= #x-8000 y2 #x7FFF)) - (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) - (+ (coerce y1 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) - (+ (coerce y2 'short-float) 0.5)))) - (progn - (send path :move-to-point p1) - (send path :line-to-point p2)))) - (t - (let ((line (region-intersection (make-rectangle* #x-8000 #x-8000 #x7FFF #x7FFF) - (make-line* x1 y1 x2 y2)))) - (when (linep line) - (multiple-value-bind (x1 y1) (line-start-point* line) - (multiple-value-bind (x2 y2) (line-end-point* line) - (slet ((p1 (ns-make-point (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate x1))) 'short-float) 0.5) - (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate y1))) 'short-float) 0.5))) - (p2 (ns-make-point (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate x2))) 'short-float) 0.5) - (+ (coerce (min #x7FFF (max #x-8000 (round-coordinate y2))) 'short-float) 0.5)))) - (progn - (send path :move-to-point p1) - (send path :line-to-point p2))))))))))) + (slet ((p1 (ns-make-point (+ (coerce x1 'short-float) 0.5) + (+ (coerce y1 'short-float) 0.5))) + (p2 (ns-make-point (+ (coerce x2 'short-float) 0.5) + (+ (coerce y2 'short-float) 0.5)))) + (send path :move-to-point p1) + (send path :line-to-point p2))) (send mirror :stroke-path path :in-colour colour)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-rectangle* medium x1 y1 x2 y2 [Generic function] +;;; medium-draw-rectangle* medium x1 y1 x2 y2 [Generic function] -;;; Draws a rectangle on the medium medium. The corners of the rectangle are at (x1,y1) and (x2,y2). +;;; Draws a rectangle on the medium medium. The corners of the rectangle +;;; are at (x1,y1) and (x2,y2). (defmethod medium-draw-rectangle* ((medium beagle-medium) left top right bottom filled) - (debug-log 2 "medium.lisp -> medium-draw-rectangle*~%") (let ((tr (sheet-native-transformation (medium-sheet medium)))) (with-transformed-position (tr left bottom) (with-transformed-position (tr right top) (with-beagle-graphics (medium) - ;; Cocoa rect specified with x,y,width + height. - ;; x = left, y = bottom, width = right - left, height = top - bottom. (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - ;; When the following have 0.5 added, things go a little wrong. - (let ((left (round-coordinate left)) - (top (round-coordinate top)) - (right (round-coordinate right)) - (bottom (round-coordinate bottom))) - ;; append-bezier-path-with-rect automatically closes the path if needed. - (send path :append-bezier-path-with-rect (ccl::make-ns-rect left bottom (- right left) (- top bottom))) - (if filled - (send mirror :fill-path path :in-colour colour) - (send mirror :stroke-path path :in-colour colour)))))))) + (when (and filled (or (typep ink 'climi::transformed-design) + (typep ink 'climi::indexed-pattern))) + (send mirror :draw-image colour :at-point (ns-make-point (coerce left 'short-float) + (coerce top 'short-float))) + (return-from medium-draw-rectangle* (values))) + (send path :append-bezier-path-with-rect (ccl::make-ns-rect (coerce left 'short-float) + (coerce bottom 'short-float) + (coerce (- right left) 'short-float) + (coerce (- top bottom) 'short-float))) + (if filled + (send mirror :fill-path path :in-colour colour) + (send mirror :stroke-path path :in-colour colour))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-polygon* medium coord-seq closed [Generic function] - -;;; Draws a polygon or polyline on the medium medium. coord-seq is a sequence of coordinate pairs, -;;; which are real numbers. It is an error if coord-seq does not contain an even number of elements. -;;; Each successive coordinate pair is taken as the position of one vertex of the polygon. +;;; medium-draw-polygon* medium coord-seq closed [Generic function] + +;;; Draws a polygon or polyline on the medium medium. coord-seq is a +;;; sequence of coordinate pairs, which are real numbers. It is an error +;;; if coord-seq does not contain an even number of elements. Each +;;; successive coordinate pair is taken as the position of one vertex of +;;; the polygon. (defmethod medium-draw-polygon* ((medium beagle-medium) coord-seq closed filled) - ;; There must be an even number of coordinates - this should be checked at a higher level. (assert (evenp (length coord-seq))) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (with-beagle-graphics (medium) - ;; Move to the start of the polyline - (send path :move-to-point (ns-make-point (coerce (elt coord-seq 0) 'short-float) (coerce (elt coord-seq 1) 'short-float))) + (send path :move-to-point (ns-make-point (coerce (elt coord-seq 0) 'short-float) + (coerce (elt coord-seq 1) 'short-float))) (do ((count 2 (+ count 2))) ((> count (1- (length coord-seq)))) - ;; Note: not offsetting ordinates by +0.5; will have to see if this is useful. (slet ((pt (ns-make-point (coerce (elt coord-seq count) 'short-float) (coerce (elt coord-seq (1+ count)) 'short-float)))) (send path :line-to-point pt))) - ;; ensure polyline joins up if appropriate. This needs to be done after all points have been - ;; set in the bezier path. + ;; ensure polyline joins up if appropriate. This needs to be done after + ;; all points have been set in the bezier path. (when closed (send path 'close-path)) @@ -690,12 +752,14 @@ (send mirror :stroke-path path :in-colour colour))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; medium-draw-text* medium text x y (start 0) end (align-x :left ) [Generic function] -;;; (align-y :baseline ) toward-x toward-y -;;; transform-glyphs - -;;; Draws a character or a string on the medium medium. The text is drawn starting at (x,y), and -;;; towards (toward-x, toward-y). In some implementations of CLIM, medium-draw-text* may call either +;;; medium-draw-text* medium text x y (start 0) end [Generic function] +;;; (align-x :left) +;;; (align-y :baseline) +;;; toward-x toward-y transform-glyphs + +;;; Draws a character or a string on the medium medium. The text is drawn +;;; starting at (x,y), and towards (toward-x, toward-y). In some +;;; implementations of CLIM, medium-draw-text* may call either ;;; medium-draw-string* or medium-draw-character* in order to draw the text. (defmethod medium-draw-text* ((medium beagle-medium) string x y @@ -703,43 +767,36 @@ align-x align-y toward-x toward-y transform-glyphs) (declare (ignore toward-x toward-y transform-glyphs)) - (debug-log 2 "medium.lisp -> medium-draw-text*~%") - (debug-log 3 " x=~A y=~A string=~A~%" x y string) (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) - (%with-beagle-graphics (medium) - (when (characterp string) - (setq string (make-string 1 :initial-element string))) - (when (null end) (setq end (length string))) - (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) - (text-size medium string :start start :end end) - (declare (ignore x-cursor y-cursor)) - (debug-log 3 "draw-text: mark 1~%") - (setq x (- x (ecase align-x - (:left 0) - (:center (round text-width 2)) - (:right text-width)))) - (debug-log 3 "draw-text: mark 2~%") - (setq y (ecase align-y - (:top (- y text-height)) - (:center (- y (floor text-height 2))) - (:baseline (- y baseline)) - (:bottom y)))) - (let ((x (+ (round-coordinate x) 0.5)) - (y (+ (round-coordinate y) 0.5))) - (when (and (<= #x-8000 x #x7FFF) - (<= #x-8000 y #x7FFF)) - (debug-log 3 "draw-text: mark 3~%") - (slet ((point (ns-make-point x y))) - (let ((objc-string (%make-nsstring (subseq string start end)))) - (debug-log 3 "draw-text: mark 4~%") - (send mirror :draw-string objc-string - :at-point point - :with-attributes (reuse-attribute-dictionary medium font :colour colour) - :in-colour colour - :with-width width - :with-cap-style cap - :with-join-style join) - (send objc-string 'release))))))));) + (with-beagle-graphics (medium) + (let ((font (%text-style->beagle-font (or (medium-text-style medium) + *default-text-style*)))) + (when (characterp string) + (setq string (make-string 1 :initial-element string))) + (when (null end) (setq end (length string))) + (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) + (text-size medium string :start start :end end) + (declare (ignore x-cursor y-cursor)) + (setf x (+ (- x (ecase align-x + (:left 0) + (:center (round text-width 2)) + (:right text-width)) 0.5))) + (setf y (+ (ecase align-y + (:top (- y text-height)) + (:center (- y (floor text-height 2))) + (:baseline (- y baseline)) + (:bottom y)) 0.5)) + (slet ((point (ns-make-point (coerce x 'short-float) + (coerce y 'short-float)))) + (let ((objc-string (%make-nsstring (subseq string start end)))) + (send mirror :draw-string objc-string + :at-point point + :with-attributes (reuse-attribute-dictionary medium font :colour colour) + :in-colour colour + :with-width width + :with-cap-style cap + :with-join-style join) + (send objc-string 'release)))))))) ;;; Can't see these making any difference, but it brings us a little closer to equality with ;;; the CLX back end. @@ -757,7 +814,3 @@ (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet)))) -;;; This is currently the same as the one defined in the CLX backend; we need to set -;;; this in Cocoa too I guess (I think it's configurable in Cocoa) ::FIXME:: -(defmethod medium-miter-limit ((medium beagle-medium)) - #.(* pi (/ 11 180))) Index: beagle/mirror.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/mirror.lisp,v retrieving revision 1.2 diff -u -r1.2 mirror.lisp --- beagle/mirror.lisp 8 Aug 2004 16:09:13 -0000 1.2 +++ beagle/mirror.lisp 26 Apr 2005 22:33:45 -0000 @@ -570,6 +570,11 @@ mirror-transformation) (multiple-value-bind (i1 i2 i3 i4 x y) (get-transformation mirror-transformation) + (declare (ignore i1 i2 i3 i4)) + ;; This is why menus aren't being shown in the right place; because they are frames + ;; (borderless, admittedly) the coords provided for them aren't flipped (parent = + ;; screen). Hence, they're at the bottom instead of the top. Can fix now I've realized + ;; what the problem is ;-) (send (send mirror 'window) :set-frame-top-left-point (ns-make-point (coerce x 'short-float) (coerce y 'short-float))) (send (send mirror 'window) :make-key-and-order-front nil))) @@ -578,7 +583,8 @@ (defmethod port-set-mirror-transformation ((port beagle-port) mirror mirror-transformation) (debug-log 2 "mirror.lisp -> port-set-mirror-transformation~%") (debug-log 3 "!!!!!!!! Setting mirror (~S) transfomation to ~S~%" mirror mirror-transformation) - (slet ((frame-origin (send mirror 'frame))) ;position + size in parent + (slet ((mirror-bounds (send mirror 'bounds)) + (frame-origin (send mirror 'frame))) ;position + size _in parent_ (rlet ((point :oint :x (coerce (floor (nth-value 0 (transform-position mirror-transformation 0 0))) 'short-float) :y (coerce (floor (nth-value 1 (transform-position mirror-transformation 0 0))) 'short-float))) @@ -595,12 +601,21 @@ (send mirror :set-frame-origin point) ;; This is how we do the scolling; but it's very inefficient (redraws entire mirror region). ;; ::FIXME:: - ;; Should perhaps be an :after method on update-mirror-geometry? + ;; Should perhaps be an :after method on update-mirror-geometry? This *should* be done automatically + ;; by 'care-for-new-native-transformation' (see climsource:sheets.lisp), but that method never + ;; seems to be invoked... (climi::dispatch-repaint (port-lookup-sheet-for-view port mirror) - (%sheet-mirror-region (port-lookup-sheet-for-view port mirror))) + (untransform-region mirror-transformation (%beagle-region-from-ns-rect mirror-bounds))) +;;; (%sheet-mirror-region (port-lookup-sheet-for-view port mirror))) ))) - + +(defun %beagle-region-from-ns-rect (rect) + (make-bounding-rectangle (pref rect :ect.origin.x) + (pref rect :ect.origin.y) + (+ (pref rect :ect.origin.x) (pref rect :ect.size.width)) + (+ (pref rect :ect.origin.y) (pref rect :ect.size.height)))) + ;;; Nabbed from CLX backend port.lisp - however, I think it's wrong. This (and the CLX) method ;;; actually attempt to put the sheet up on screen. I suspect it only needs to set a flag, and ;;; invoke "notify-sheet-enabled". Maybe not :-) In any case, I think this gets called for every Index: beagle/port.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/beagle/port.lisp,v retrieving revision 1.3 diff -u -r1.3 port.lisp --- beagle/port.lisp 21 Aug 2004 20:48:00 -0000 1.3 +++ beagle/port.lisp 26 Apr 2005 22:33:45 -0000 @@ -103,7 +103,7 @@ (defclass beagle-port (basic-port) ((screen :initform nil :accessor beagle-port-screen) (color-table :initform (make-hash-table :test #'eq)) - (view-table :initform (make-hash-table :test #'equal)) ; Not looking too efficient... + (view-table :initform (make-hash-table :test #'eql)) ; Not looking too efficient... (pointer :reader port-pointer) ;; holds sheet that should receive key events. (key-focus-sheet :initform nil :accessor beagle-port-key-focus) @@ -194,10 +194,10 @@ (or (gethash color table) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) - (let ((nsc (send (@class ns-color) :color-with-calibrated-red r - :green g - :blue b - :alpha alpha))) + (let ((nsc (send (@class ns-color) :color-with-calibrated-red (coerce r 'short-float) + :green (coerce g 'short-float) + :blue (coerce b 'short-float) + :alpha (coerce alpha 'short-float)))) (send nsc 'retain) nsc))))))