mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16648 Modified Files: medium.lisp Log Message: * Backends/gtkairo/medium.lisp (TEXT-STYLE-WIDTH): return max_x_advance instead of computing 1 em. Fixes the cursor position problem in Climacs. (TEXT-SIZE): changed return values almost completely. See comments there. (CLIMI::TEXT-BOUNDING-RECTANGLE*): Reimplemented to look more like what CLIM-CLX does. No real insight, but cannot be worse than it was. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:48:52 1.2 @@ -590,6 +590,18 @@ ;;; TEXT-STYLE-ASCENT +;; FIXME: Cairo documentation states that these numbers, AIUI, are not +;; exact measurements but rather values tweaked by the font designer for +;; better visual effect. +;; +;; What this seems to mean in practise is that, say, ASCENT is nearly +;; identical to text_extent.height in the tests I tried. +;; +;; So which one does CLIM want? What are these function actually being +;; used for? +;; +;; --DFL + (let ((hash (make-hash-table))) (defmethod text-style-ascent :around (text-style (medium gtkairo-medium)) (or (gethash text-style hash) @@ -653,6 +665,11 @@ (cairo_font_extents cr res) ;; ### let's hope that cairo respects ;; height = ascent + descent. + ;; + ;; No, it expressly doesn't. Cairo documentation states that + ;; height includes additional space that is meant to give more + ;; aesthetic line spacing than ascent+descent would. Is that a + ;; problem for us? --DFL (slot res 'cairo_font_extents 'height)))))) @@ -673,9 +690,13 @@ (sync-sheet medium) (cairo_identity_matrix cr) (sync-text-style medium text-style t) - (cffi:with-foreign-object (res 'cairo_text_extents) - (cairo_text_extents cr "m" res) - (slot res 'cairo_text_extents 'width)))))) + ;; This didn't work well for Climacs. --DFL +;;; (cffi:with-foreign-object (res 'cairo_text_extents) +;;; (cairo_text_extents cr "m" res) +;;; (slot res 'cairo_text_extents 'width)) + (cffi:with-foreign-object (res 'cairo_font_extents) + (cairo_font_extents cr res) + (slot res 'cairo_font_extents 'max_x_advance)))))) ;;; TEXT-STYLE-FIXED-WIDTH-P @@ -717,6 +738,27 @@ :start start :end (or end (length string))))) +(defmethod climi::text-bounding-rectangle* + ((medium gtkairo-medium) string &key text-style (start 0) end) + (with-gtk () + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (medium-text-style medium))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (climi::text-bounding-rectangle* (metrik-medium (port medium)) + string + :text-style text-style + :start start + :end (or end (length string))))) + +;; FIXME: TEXT-SIZE [and presumably TEXT-BOUNDING-RECTANGLE*, too] are +;; supposed to take newlines into account. The CLX backend code was +;; written to support that but does not -- T-B-R errors out and T-S +;; doesn't return what WRITE-STRING on the sheet actually does. So +;; let's not steal code from CLIM-CLX when it's broken. Doesn't +;; actually look like anyone has been depending on this after all. +;; -- DFL + (defmethod text-size ((medium metrik-medium) string &key text-style (start 0) end) (with-cairo-medium (medium) @@ -733,17 +775,46 @@ (subseq string start (or end (length string))) res) (cffi:with-foreign-slots - ((width height x_advance y_advance) res cairo_text_extents) - (values (ceiling width) - (ceiling height) - (ceiling x_advance) - (ceiling y_advance) - ;; baseline? - (ceiling (text-style-ascent text-style medium)))))))) + ((x_advance height y_bearing) res cairo_text_extents) + (values + ;; use x_advance instead of width, since CLIM wants to trailing + ;; spaces to be taken into account. + (ceiling x_advance) + (ceiling height) + ;; Sames values again here: The CLIM spec states that these + ;; values differ only for multi-line text. And y_advance is 0 + ;; for european text, which is not what we want. --DFL + (ceiling x_advance) + (ceiling height) + ;; This used to be TEXT-STYLE-ASCENT, but see comment there. + (abs (ceiling y_bearing)))))))) (defmethod climi::text-bounding-rectangle* - ((medium gtkairo-medium) string &key text-style (start 0) end) - (text-size medium string :text-style text-style :start start :end end)) + ((medium metrik-medium) string &key text-style (start 0) end) + (with-cairo-medium (medium) + ;; -> left ascent right descent + (when (characterp string) (setf string (string string))) + (setf text-style (or text-style (make-text-style nil nil nil))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (with-slots (cr) medium + (cairo_identity_matrix cr) + (sync-text-style medium text-style t) + (cffi:with-foreign-object (res 'cairo_text_extents) + (cairo_text_extents cr + (subseq string start (or end (length string))) + res) + ;; This used to be a straight call to TEXT-SIZE. Looking at + ;; what CLIM-CLX does, this looks better to me, but I'm not sure + ;; whether it's 100% right: + ;; --DFL + (cffi:with-foreign-slots + ((height x_advance y_advance x_bearing y_bearing) + res cairo_text_extents) + (values (ceiling x_bearing) + (ceiling y_bearing) + (ceiling x_advance) + (ceiling (+ height y_bearing)))))))) ;;;; ------------------------------------------------------------------------ ;;;; General Designs

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv16577/Backends/gtkairo Modified Files: event.lisp gtk-ffi.lisp Log Message: * Backends/gtkairo/gtk-ffi.lisp (gtkwidget, gtkobject): Moved header into its own structure declaration for correct alignment on 64 bit architectures. (gtkwidget-header): New function. (gtkwidget-flags): New accessor functions. * Backends/gtkairo/event.lisp (connect-signals): Use gtkwidget-flags. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:46:18 1.2 @@ -40,9 +40,8 @@ GDK_ENTER_NOTIFY_MASK GDK_LEAVE_NOTIFY_MASK #+nil GDK_STRUCTURE_MASK)) - (setf (cffi:foreign-slot-value widget 'gtkwidget 'flags) - (logior (cffi:foreign-slot-value widget 'gtkwidget 'flags) - GTK_CAN_FOCUS)) + (setf (gtkwidget-flags widget) + (logior (gtkwidget-flags widget) GTK_CAN_FOCUS)) (connect-signal widget "expose-event" 'expose-handler) (connect-signal widget "motion-notify-event" 'motion-notify-handler) (connect-signal widget "button-press-event" 'button-handler) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:46:18 1.2 @@ -112,14 +112,20 @@ (gdk_threads_leave))))) -;; GROVELME +;;; GROVELME -(cffi:defcstruct gtkwidget +;; must be a separate structure definition in order for padding on AMD64 +;; to work properly. +(cffi:defcstruct gtkobject (gtype :unsigned-long) ;GTypeInstance (ref_count :unsigned-int) ;GObject (qdata :pointer) ; -"- (flags :uint32) ;GtkObject - (private_flags :uint16) ;von hier an endlich GtkWidget + ) + +(cffi:defcstruct gtkwidget + (header gtkobject) + (private_flags :uint16) (state :uint8) (saved_state :uint8) (name :pointer) @@ -133,6 +139,16 @@ (gdkwindow :pointer) (parent :pointer)) +(defun gtkwidget-header (widget) + (cffi:foreign-slot-value widget 'gtkwidget 'header)) + +(defun gtkwidget-flags (widget) + (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags)) + +(defun (setf gtkwidget-flags) (newval widget) + (setf (cffi:foreign-slot-value (gtkwidget-header widget) 'gtkobject 'flags) + newval)) + (cffi:defcstruct gdkeventexpose (type :int) (gdkwindow :pointer)

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14999 Modified Files: mcclim.asd ports.lisp Log Message: * Backends/gtkairo: New directory: Experimental GTK+ backend. * mcclim.asd (clim-gtkairo): New system. (clim-looks): Depend on clim-gtkairo if the gtkairo feature has been set by the user. * ports.lisp (*server-path-search-order*): s/gtk/gtkairo/ --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 17:54:58 1.18 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 18:40:27 1.19 @@ -258,6 +258,26 @@ (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +(defsystem :clim-gtkairo + :depends-on (:clim :cffi) + :components + ((:module "Backends/gtkairo" + :pathname #.(make-pathname :directory '(:relative "Backends" "gtkairo")) + :serial t ;asf wird's ja richten + :components + ((:file "clim-fix") + (:file "package") + (:file "gtk-ffi") + (:file "cairo-ffi") + (:file "port") + (:file "event") + (:file "keysymdef") + (:file "medium") + (:file "pixmap") + (:file "graft") + (:file "frame-manager") + (:file "gadgets"))))) + ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" @@ -283,6 +303,8 @@ ;; cope with possible bugs. ;; #+(or openmcl mcl) :clim-beagle + #+gtkairo :clim-gtkairo + ;; null backend :clim-null ) --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/27 10:44:34 1.51 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/04/17 18:40:27 1.52 @@ -25,7 +25,7 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle :null)) +(defvar *server-path-search-order* '(:genera :ms-windows :gtkairo :clx :x11 :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order*

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14999/Backends/gtkairo Added Files: .cvsignore NOTES cairo-ffi.lisp clim-fix.lisp event.lisp frame-manager.lisp gadgets.lisp graft.lisp gtk-ffi.lisp keysymdef.lisp medium.lisp package.lisp pixmap.lisp port.lisp Log Message: * Backends/gtkairo: New directory: Experimental GTK+ backend. * mcclim.asd (clim-gtkairo): New system. (clim-looks): Depend on clim-gtkairo if the gtkairo feature has been set by the user. * ports.lisp (*server-path-search-order*): s/gtk/gtkairo/ --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/.cvsignore 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/.cvsignore 2006/04/17 18:40:27 1.1 *.fasl --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/NOTES 2006/04/17 18:40:27 1.1 Gilbert Baumann's notes, copied from clim-cairo-2005-03-20/cairo-medium.lisp. ;; - blitting ;; ;; The X11 Cairo backend currently crashes my X server when blittering from ;; one surface to itself. [That is, if we draw to a surface using very same ;; surface as the pattern]. [ Well, no X11 here anywore. Is anything like this still relevant? ] ;; - pixmaps ;; ;; These should be easy to provide. [ David: done ] ;; - alpha impedance mismatch ;; ;; Cairo uses pre-multiplied alpha while CLIM doesn't. So we need to convert ;; things around as needed. [ David: ??? ] ;; - real general designs and optimization short cuts ;; - new drawing options: ;; - :transform-glyphs-p ;; - :alu ;; - MEDIUM-DRAW-ELLIPSE* ;; Need to find a good bezier approximation of circles. ;; - MEDIUM-BEEP [ David: nix is, gepiepe kann ich nicht leiden. ;-) Ein "visual beep" waere aber schick. Vielleicht kann man da ja was basteln? ] ;; - device text styles ;; - find a substitue for CAIRO-FONT-SET-TRANSFORM ;; - abolish this silly CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS ;; - INVOKE-WITH-DRAWING-OPTIONS ;; - care for the proper text transformations. ;; - we need a systematic overview about what drawing option components are ;; transformed under what circumstances in cairo and in clim. ;; - i believe a "cr" is really nothing more than a kind of graphics context, so ;; this time implement a proper cache for those, so that we spend less time ;; tossing options around. [ David: Hmm, let's do some profiling before setting up a cache. Cairo people seem to recommend creating a cairo context for each and every redraw and then throwing it away, and we only create one for every medium, so that shouldn't be too slow. What's important is to not leak the cairo context. Right now I let the sheet destroy contexts when the mirror is destroyed, is that the right thing to do? ] ;; - more alu operations in clim ;; ;; For CAD applications it is really handy to have an OR operation. (Which ;; could be approximated in effect with :saturate). We would need to extend ;; the CLIM general design specification to include alu operations. [As ;; currently there really are only the OVER and FLIPPING operators available]. ;; - More proper separation of a vanilla Cairo media and specific Cario medium ;; like X11, Glitz, PNG, PDF etc. ;; - a WITH-CAIRO macro which can setup the proper FPU mode to make it break ;; less. [ David: oh yes, that's what I had to do in WITH-GTK. Terrible. ] ;;;; NOTES ;; RESOURCES, WHO TO FREE IT? -- It seems that if you destroy a window, a Render ;; picture associated with said window is also destroyed. ;; CAIRO-SET-TARGET-DRAWABLE and perhaps CAIRO-DESTROY do want to destroy that ;; picture on their own. So when we destroy a window we need to know all cairo ;; contexts floating around which associate to the window at hand and target ;; them at the root window (or better the spare window, more below) before we ;; destroy a window. And we need to do this recursively. And we need the extra ;; book keeping. [ David: nix verstehen. Was ist denn ein render picture? Hilfe! ] ;; UNGRAFTED MEDIA -- It happens that an application wants to use a medium ;; before its sheet is grafted. In those situations we'd need a spare window to ;; target the associated cairo medium at. We could use the root window, but bad ;; things happen if the user actually does some drawing instead of merely ;; querying stuff like text extents. So I want to allocate a specific unmapped ;; spare window for those occasions. ;; ;; [There really are two situations: a) using an ungrafted medium, b) ;; using a medium that is grafted to a sheet which itself is not ;; grafted]. [ David: I'm using the root window for text size operations (harmless) and completely ignore drawing operations otherwise. ] ;; FLIPPING INKS -- Cairo can't and for ideological reasons perhaps never will ;; support flipping inks. I myself hate flipping inks even more so than ;; bit-blittering, but there are still a few ancient applications around, which ;; use it. So we'd need to think about some way to support it. One idea is to ;; render the shape to an A1 temporary pixmap surface and use good old X11 to ;; make that pixmap flip pixels around. This breaks some abtractions established ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation. [ David: Das ginge auch mit Cairo, ja. ] ;; - flipping ink ;; ;; Below is some example code to make Cairo render the alpha channel to a one ;; bit depth pixmap on the server. This pixmap can then later be used with X ;; Core requests to flip pixels around. Still, in general flipping inks don't ;; play nice when you have an alpha channel. ;; ;; But: A flippink can't be solved by just setting up the proper Cairo pattern ;; to a Cairo context, but drawing the shape itself must happen on our ;; temporary surface. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/04/17 18:40:27 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) copyright 2005 by Gilbert Baumann <gilbert(a)base-engineering.com> ;;; (c) copyright 2006 David Lichteblau (david(a)lichteblau.com) ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :clim-gtkairo) ;; user-visible structures (cffi:defcstruct cairo_text_extents (x_bearing :double) (y_bearing :double) (width :double) (height :double) (x_advance :double) (y_advance :double)) (cffi:defcstruct cairo_font_extents (ascent :double) (descent :double) (height :double) (max_x_advance :double) (max_y_advance :double)) (cffi:defcstruct cairo_glyph (index :unsigned-int) (x :double) (y :double)) (cffi:defcstruct cairo_matrix_t (xx :double) (yx :double) (xy :double) (yy :double) (x0 :double) (y0 :double)) ;; enums (cffi:defcenum cairo_format :argb32 :rgb24 :a8 :a1) (cffi:defcenum cairo_operator :clear :src :over :in :out :atop :dest :dest_over :dest_in :dest_out :dest_atop :xor :add :saturate) (cffi:defcenum cairo_fill_rule :winding :even_odd) (cffi:defcenum cairo_line_cap :butt :round :square) (cffi:defcenum cairo_line_join :miter :round :bevel) (cffi:defcenum cairo_font_slant :normal :italic :oblique) (cffi:defcenum cairo_font_weight :normal :bold) (cffi:defcenum cairo_status :success :no_memory :invalid_restore :invalid_pop_group :no_current_point :invalid_matrix :invalid_status :null_pointer :invalid_string :invalid_path_data :read_error :write_error :surface_finished :surface_type_mismatch :pattern_type_mismatch :invalid_content :invalid_format :invalid_visual :file_not_found :invalid_dash) (cffi:defcenum cairo_filter :fast :good :best :nearest :bilinear :gaussian) (cffi:defcenum cairo_extend :none :repeat :reflect) ;;; Functions for manipulating state objects (defcfun "cairo_create" :pointer (surface :pointer)) (defcfun "cairo_reference" :void (cr :pointer)) (defcfun "cairo_destroy" :void (cr :pointer)) (defcfun "cairo_save" :void (cr :pointer)) (defcfun "cairo_restore" :void (cr :pointer)) ;;; XXX: Replace with cairo_current_gstate/cairo_set_gstate ;;;(defcfun "cairo_copy" ;;; :void ;;; (destination :pointer) ;;; (source :pointer)) ;;; Modify state ;;;(defcfun "cairo_set_target_surface" ;;; :void ;;; (cr :pointer) ;;; (surface :pointer)) ;;; ;;;(defcfun "cairo_set_target_image" ;;; :void ;;; (cr :pointer) ;;; (data :pointer) ;(* (unsigned 8)) ;;; (format cairo_format) ;;; (width :int) ;;; (height :int) ;;; (stride :int)) (defcfun "cairo_set_operator" :void (cr :pointer) (op cairo_operator)) ;;; Colors (defcfun "cairo_set_source_rgb" :void (cr :pointer) (red :double) (green :double) (blue :double)) (defcfun "cairo_set_source_rgba" :void (cr :pointer) (red :double) (green :double) (blue :double) (alpha :double)) (defcfun "cairo_set_source" :void (cr :pointer) (pattern :pointer)) (defcfun "cairo_set_tolerance" :void (cr :pointer) (tolerance :double)) (defcfun "cairo_set_fill_rule" :void (cr :pointer) (fill_rule cairo_fill_rule)) (defcfun "cairo_set_line_width" :void (cr :pointer) (w :double)) (defcfun "cairo_set_line_cap" :void (cr :pointer) (line_cap cairo_line_cap)) (defcfun "cairo_set_line_join" :void (cr :pointer) (line_join cairo_line_join)) (defcfun "cairo_set_dash" :void (cr :pointer) (dashes :pointer) ;*double (ndash :int) (offset :double)) (defcfun "cairo_set_miter_limit" :int (cr :pointer) (limit :double)) ;;; Transformations (defcfun "cairo_translate" :void (cr :pointer) (tx :double) (ty :double)) (defcfun "cairo_scale" :void (cr :pointer) (sx :double) (sy :double)) (defcfun "cairo_rotate" :void (cr :pointer) (angle :double)) (defcfun "cairo_set_matrix" :void (cr :pointer) (matrix :pointer)) (defcfun "cairo_identity_matrix" :void (cr :pointer)) ;;;(defcfun "cairo_transform_point" ;;; :void ;;; (cr :pointer) ;;; (x :pointer) ;*double ;;; (y :pointer) ;*double ;;; ) ;;;(defcfun "cairo_transform_distance" ;;; :void ;;; (cr :pointer) ;;; (dx :pointer) ;*double ;;; (dy :pointer) ;*double ;;; ) ;;;(defcfun "cairo_inverse_transform_point" ;;; :void ;;; (cr :pointer) ;;; (x :pointer) ;*double ;;; (y :pointer) ;*double ;;; ) ;;; ;;;(defcfun "cairo_inverse_transform_distance" [537 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/04/17 18:40:27 1.1 [563 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/04/17 18:40:27 1.1 [860 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/04/17 18:40:27 1.1 [967 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/04/17 18:40:27 1.1 [1135 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/graft.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/graft.lisp 2006/04/17 18:40:27 1.1 [1178 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/04/17 18:40:27 1.1 [1913 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keysymdef.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keysymdef.lisp 2006/04/17 18:40:27 1.1 [3699 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/04/17 18:40:27 1.1 [4610 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/package.lisp 2006/04/17 18:40:27 1.1 [4616 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pixmap.lisp 2006/04/17 18:40:27 1.1 [4717 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/04/17 18:40:27 1.1 [5336 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14955/gtkairo Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/gtkairo added to the repository

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14900 Modified Files: gadgets.lisp Log Message: * gadgets.lisp (dis-/armed-callback text-field-pane): Added a hack to ensure initialization of the text field before it is being used. Needed to make the gadget test start up with the gtkairo backend. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/30 12:07:59 1.99 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/04/17 18:37:21 1.100 @@ -2562,6 +2562,7 @@ (let ((port (port gadget))) (setf (previous-focus gadget) (port-keyboard-input-focus port)) (setf (port-keyboard-input-focus port) gadget)) + (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid)))) @@ -2571,6 +2572,7 @@ (let ((port (port gadget))) (setf (port-keyboard-input-focus port) (previous-focus gadget)) (setf (previous-focus gadget) nil)) + (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow))))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv11135 Modified Files: medium.lisp Log Message: * Backends/CLX/medium.lisp (climi::text-bounding-rectangle*): Do not error out when the string contains newlines. [Whether the return values are right is a different matter...] --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/03/23 11:59:00 1.73 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/04/17 18:12:16 1.74 @@ -757,7 +757,7 @@ font-ascent font-descent direction first-not-done)) (multiple-value-bind (minx miny maxx maxy) - (text-bounding-rectangle* + (climi::text-bounding-rectangle* medium string :text-style text-style :start (1+ position-newline) :end end) (values (min minx left) (- ascent)

1 0

[mcclim-cvs] CVS mcclim/Examples
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv8858/Examples Modified Files: demodemo.lisp Added Files: text-size-test.lisp Log Message: * Examples/text-size-test.lisp: New file. Visual test for the TEXT-SIZE function. * Examples/demodemo.lisp: Added a button for text-size-test. * mcclim.asd (clim-examples): Added text-size-test.lisp. --- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/10 09:48:40 1.9 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/04/17 17:54:58 1.10 @@ -72,7 +72,8 @@ (make-demo-button "Table Test" 'table-test) (make-demo-button "Scroll Test" 'Scroll-test) (make-demo-button "List Test" 'list-test) - (make-demo-button "HBOX Test" 'hbox-test))))))))) + (make-demo-button "HBOX Test" 'hbox-test) + (make-demo-button "Text Size Test" 'text-size-test))))))))) (defun demodemo () #+nil --- /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:59 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/text-size-test.lisp 2006/04/17 17:54:59 1.1 ;;; -*- Mode: Lisp; -*- ;;; (c) 2006 David Lichteblau (david(a)lichteblau.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (define-application-frame text-size-test () () (:panes (canvas :application :min-width 600 :display-time t :display-function 'display-canvas) (text (make-pane 'text-field :value "ytmM")) (family (with-radio-box () (make-pane 'toggle-button :label "Fixed" :id :fixed) (radio-box-current-selection (make-pane 'toggle-button :label "Serif" :id :serif)) (make-pane 'toggle-button :label "Sans Serif" :id :sans-serif))) (face (with-radio-box (:type :some-of) (make-pane 'toggle-button :label "Bold" :id :bold) (make-pane 'toggle-button :label "Italic" :id :italic))) (size (make-pane 'slider :orientation :horizontal :value 200 :min-value 1 :max-value 1000))) (:layouts (default (vertically () (labelling (:label "Text") text) (horizontally () (labelling (:label "Family") family) (labelling (:label "Face") face)) (labelling (:label "Size") size) canvas)))) (defmethod display-canvas (frame stream) (window-clear stream) (let* ((pane-width (rectangle-width (sheet-region stream))) (pane-height (rectangle-height (sheet-region stream))) (str (gadget-value (find-pane-named frame 'text))) (size (gadget-value (find-pane-named frame 'size))) (family (gadget-id (gadget-value (find-pane-named frame 'family)))) (faces (mapcar #'gadget-id (gadget-value (find-pane-named frame 'face)))) (face (if (cdr faces) '(:bold :italic) (car faces))) (style (make-text-style family face size))) (multiple-value-bind (width height final-x final-y baseline) (text-size stream str :text-style style) (let ((x1 (/ (- pane-width width) 2)) (y1 (/ (- pane-height height) 2))) (draw-line* stream 0 (+ y1 baseline) pane-width (+ y1 baseline) :ink +green+) (draw-text* stream str x1 (+ y1 baseline) :text-style style) ;; Here an attempt at testing text with newlines, results are garbage ;; even with CLIM-CLX: ;;; (setf (stream-cursor-position stream) (values x1 y1)) ;;; (with-text-style (stream style) ;;; (write-string str stream)) (draw-rectangle* stream x1 y1 (+ x1 width) (+ y1 height) :ink +red+ :filled nil) (draw-rectangle* stream x1 y1 (+ x1 final-x) (+ y1 final-y) :ink +blue+ :filled nil))))) (define-text-size-test-command (com-quit-text-size-test :menu "Quit") () (frame-exit *application-frame*)) (define-text-size-test-command (com-update :menu "Update") () (display-canvas *application-frame* (frame-standard-output *application-frame*)))

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 17 Apr '06

17 Apr '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8858 Modified Files: mcclim.asd Log Message: * Examples/text-size-test.lisp: New file. Visual test for the TEXT-SIZE function. * Examples/demodemo.lisp: Added a button for text-size-test. * mcclim.asd (clim-examples): Added text-size-test.lisp. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/10 09:48:40 1.17 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/04/17 17:54:58 1.18 @@ -316,7 +316,8 @@ (:file "accepting-values") (:file "method-browser") (:file "dragndrop-translator") - (:file "draggable-graph"))) + (:file "draggable-graph") + (:file "text-size-test"))) (:module "Goatee" :components ((:file "goatee-test")))))

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by crhodes 10 Apr '06

10 Apr '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20022 Modified Files: dev-commands.lisp Log Message: Slightly better editability in the listener: now fboundp (setf foo) things stand a chance of having the Edit Definition command work. Printing methods with EQL specializers works better. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/29 10:43:37 1.34 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/04/10 21:24:53 1.35 @@ -37,10 +37,20 @@ ;;; Presentation types -(define-presentation-type class () :inherit-from 'expression) +(define-presentation-type specializer () :inherit-from 'expression) +(define-presentation-type class () :inherit-from 'specializer) +(define-presentation-type eql-specializer () :inherit-from 'specializer) (define-presentation-type class-name () :inherit-from 'symbol) (define-presentation-type slot-definition () :inherit-from 'expression) -(define-presentation-type function-name () :inherit-from 'symbol) + +(define-presentation-type-abbreviation function-name () + `(and expression (satisfies legal-and-fboundp))) + +(defun legal-and-fboundp (object) + (and #+sbcl (sb-int:valid-function-name-p object) + #-sbcl (typep object '(or symbol (cons (eql setf)))) + (fboundp object))) + (define-presentation-type process () :inherit-from 'expression) (define-presentation-type generic-function () :inherit-from 't) @@ -67,9 +77,7 @@ (define-presentation-type package-name () :inherit-from 'string) (define-presentation-method presentation-typep (object (type package-name)) - (find-package 'object)) - - + (find-package object)) ;;; Presentation methods @@ -98,8 +106,10 @@ (write-char #\( stream) (present arg 'symbol :stream stream) (write-char #\space stream) - (with-output-as-presentation (stream spec 'class) - (format stream "~S" (clim-mop:class-name spec))) + (with-output-as-presentation (stream spec 'specializer) + (if (typep spec 'class) + (format stream "~S" (clim-mop:class-name spec)) + (format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec))))) (write-char #\) stream)))) (when optional (format stream " &optional ~{~A ~^ ~}" optional)) @@ -187,13 +197,31 @@ (object) (clim-mop:class-name object)) +(define-presentation-translator expression-to-function-name + (expression function-name lisp-dev-commands + :documentation ((object stream) (format stream "~A" object)) + :gesture t + :tester ((object) (legal-and-fboundp object)) + :tester-definitive t) + (object) + object) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands - :documentation ((object stream) (format stream "Function ~A" object)) + :documentation ((object stream) (format stream "~A" object)) :gesture t - :tester ((object) (fboundp object)) + :tester ((object) (legal-and-fboundp object)) :tester-definitive t) - (object) object) + (object) + object) +#+nil ; doesn't work for some reason +(define-presentation-translator sequence-to-function-name + ((sequence t) function-name lisp-dev-commands + :documentation ((object stream) (format stream "~A" object)) + :gesture t + :tester ((object) (legal-and-fboundp object)) + :tester-definitive t) + (object) + object) ;;; Application commands @@ -336,7 +364,7 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((fsym 'function-name :prompt "function-name")) + ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(trace ,fsym)) @@ -347,7 +375,7 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((fsym 'symbol :prompt "function name")) + ((fsym 'function-name :prompt "function name")) (if (fboundp fsym) (progn (eval `(untrace ,fsym)) @@ -572,10 +600,16 @@ (note "No accessors") (progn (with-ink (readers) - (if readers (dolist (reader readers) (format t "~A~%" reader)) - (note "No readers~%"))) + (if readers + (dolist (reader readers) + (hackish-present reader) + (terpri)) + (note "No readers~%"))) (with-ink (writers) - (if writers (dolist (writer writers) (format t "~A~%" writer)) + (if writers + (dolist (writer writers) + (hackish-present writer) + (terpri)) (note "No writers")))))) (fcell (documentation :left) @@ -1379,19 +1413,14 @@ :command-table lisp-commands :menu t :provide-output-destination-keyword nil) - ((symbol 'symbol :prompt "function-name")) - (clim-sys:make-process (lambda () (ed symbol)))) - -(defun editable-definition-p (symbol) - (fboundp symbol)) + ((function-name 'function-name :prompt "function name")) + (clim-sys:make-process (lambda () (ed function-name)))) (define-presentation-to-command-translator edit-definition - (symbol com-edit-definition lisp-commands :gesture :select + (function-name com-edit-definition lisp-commands :gesture :select :pointer-documentation ((object stream) (format stream "Edit Definition of ~A" object)) - :documentation ((stream) (format stream "Edit Definition")) - :tester ((object) - (editable-definition-p object))) + :documentation ((stream) (format stream "Edit Definition"))) (object) (list object))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs