(defsystem :cl-gtk2-cairo
:name :cl-gtk2-cairo
- :version "0.1"
+ :version "0.1.1"
:author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
:license "LLGPL"
:serial t
@lisp
(ensure-gtk-main)
@end lisp
-This function ensures that the Gtk+ main loop is started in background thread. If the loop has not been started or if had been terminated, restarts the background thread.
+This function ensures that the Gtk+ main loop is started.
-@RFunction join-main-thread
+If your Lisp supports multithreading, it starts the main loop in background thread (if it had not been started) and immediately returns. If your Lisp does not support multithreading, the main loop is started and waits for it to complete.
+
+Calls to @ref{ensure-gtk-main} must be paired by calls to @ref{leave-gtk-main}. When the @ref{leave-gtk-main} is called the same number of time as @ref{ensure-gtk-main} is called then the main loop quits (e.g., main loops are nested).
+
+It is also useful to call @ref{join-gtk-main} after @ref{ensure-gtk-main} to wait for main loop to quit.
+
+@RFunction leave-gtk-main
+@lisp
+(leave-gtk-main)
+@end lisp
+This function terminates the gtk main loop.
+
+Calls to @ref{ensure-gtk-main} must be paired by calls to @ref{leave-gtk-main}. When the @ref{leave-gtk-main} is called the same number of time as @ref{ensure-gtk-main} is called then the main loop quits (e.g., main loops are nested).
+
+
+@RFunction join-gtk-main
@lisp
-(join-main-thread)
+(join-gtk-thread)
@end lisp
-This function waits for the background thread that runs the Gtk+ main loop to quit.
+This function waits for the background thread that runs the Gtk+ main loop to quit. See @ref{ensure-gtk-main}.
@RFunction gtk-main-iteration
@lisp
@item @uref{http://common-lisp.net/project/cl-cairo2/,,cl-cairo2} (if you intend to use <code>cl-gtk2-gtkglext</code>)
@end itemize
-At first, source code should be downloded. Current version of CL-GTK2 can be downloaded from @uref{http://common-lisp.net/project/cl-gtk2/files/cl-gtk2-0.1.tar.gz}.
+At first, source code should be downloded. Current version of CL-GTK2 can be downloaded from @uref{http://common-lisp.net/project/cl-gtk2/files/cl-gtk2-0.1.1.tar.gz}.
Development tree of CL-GTK2 can be cloned with @uref{http://git-scm.org/,,Git}:
@example
(defsystem :cl-gtk2-gdk
:name :cl-gtk2-gdk
- :version "0.1"
+ :version "0.1.1"
:author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
:license "LLGPL"
:serial t
(:file "gdk.drag-and-drop")
(:file "gdk.input-devices")
(:file "gdk.pango"))
- :depends-on (:cl-gtk2-glib :cffi :cl-gtk2-pango))
\ No newline at end of file
+ :depends-on (:cl-gtk2-glib :cffi :cl-gtk2-pango))
(context (g-object drag-context))
(time :uint32))
-(export 'gdk-drag-abord)
+(export 'gdk-drag-abort)
(defcfun gdk-drop-reply :void
(context (g-object drag-context))
(defmethod translate-to-foreign (value (type gdk-atom-as-string-type))
(gdk-atom-intern value nil))
+(defcfun gdk-region-new :pointer)
+
+(define-g-boxed-opaque region nil :alloc (gdk-region-new))
+
+(export (boxed-related-symbols 'region))
+
+(define-g-boxed-cstruct point nil
+ (x :int :initform 0)
+ (y :int :initform 0))
+
+(export (boxed-related-symbols 'point))
+
+(define-g-boxed-cstruct span nil
+ (x :int :initform 0)
+ (y :int :initform 0)
+ (width :int :initform 0))
+
+(export (boxed-related-symbols 'span))
+
+(define-g-boxed-cstruct segment nil
+ (x1 :int :initform 0)
+ (y1 :int :initform 0)
+ (x2 :int :initform 0)
+ (y2 :int :initform 0))
+
+(export (boxed-related-symbols 'segment))
+
+(define-g-boxed-cstruct trapezoid nil
+ (y1 :double :initform 0d0)
+ (x11 :double :initform 0d0)
+ (x21 :double :initform 0d0)
+ (y2 :double :initform 0d0)
+ (x12 :double :initform 0d0)
+ (x22 :double :initform 0d0))
+
+(export (boxed-related-symbols 'trapezoid))
+
+(define-g-boxed-opaque font "GdkFont"
+ :alloc (error "GDK:FONT objects may not be allocated directly"))
+
+(export (boxed-related-symbols 'font))
+
+(define-g-boxed-cstruct color "GdkColor"
+ (pixel :uint32 :initform 0)
+ (red :uint16 :initform 0)
+ (green :uint16 :initform 0)
+ (blue :uint16 :initform 0))
+
+(export (boxed-related-symbols 'color))
+
+(define-g-object-class "GdkDrawable" drawable ()
+ ((:cffi display drawable-display (g-object display)
+ "gdk_drawable_get_display" nil)
+ (:cffi screen drawable-screen (g-object screen)
+ "gdk_drawable_get_screen" nil)
+ (:cffi visual drawable-visual (g-object visual)
+ "gdk_drawable_get_visual" nil)
+ (:cffi colormap drawable-colormap (g-object colormap)
+ "gdk_drawable_get_colormap" "gdk_drawable_set_colormap")
+ (:cffi depth drawable-depth :int
+ "gdk_drawable_get_depth" nil)
+ (:cffi clip-region drawable-clip-region (g-boxed-foreign region :return)
+ "gdk_drawable_get_clip_region" nil)
+ (:cffi visible-region drawable-visible-region (g-boxed-foreign region :return)
+ "gdk_drawable_get_visible_region" nil)))
+
(define-g-object-class "GdkWindow" gdk-window (:superclass drawable)
- ((:cffi window-type gdk-window-window-type gdk-window-type
+ (#+gtk-2.18
+ (cursor gdk-window-cursor "cursor"
+ "GdkCursor" t t)
+ #-gtk-2.18
+ (:cffi cursor gdk-window-cursor (g-boxed-foreign cursor :return)
+ "gdk_window_get_cursor" "gdk_window_set_cursor")
+ (:cffi window-type gdk-window-window-type gdk-window-type
"gdk_window_get_window_type" nil)
(:cffi is-destroyed gdk-window-is-destroyed :boolean
"gdk_window_is_destroyed" nil)
(:cffi window-stack screen-window-stack (glib:glist (g-object gdk-window) :free-from-foreign t)
"gdk_screen_get_window_stack" nil)))
-(defcfun gdk-region-new :pointer)
-
-(define-g-boxed-opaque region nil :alloc (gdk-region-new))
-
-(export (boxed-related-symbols 'region))
-
-(define-g-boxed-cstruct point nil
- (x :int :initform 0)
- (y :int :initform 0))
-
-(export (boxed-related-symbols 'point))
-
-(define-g-boxed-cstruct span nil
- (x :int :initform 0)
- (y :int :initform 0)
- (width :int :initform 0))
-
-(export (boxed-related-symbols 'span))
-
-(define-g-boxed-cstruct segment nil
- (x1 :int :initform 0)
- (y1 :int :initform 0)
- (x2 :int :initform 0)
- (y2 :int :initform 0))
-
-(export (boxed-related-symbols 'segment))
-
-(define-g-boxed-cstruct trapezoid nil
- (y1 :double :initform 0d0)
- (x11 :double :initform 0d0)
- (x21 :double :initform 0d0)
- (y2 :double :initform 0d0)
- (x12 :double :initform 0d0)
- (x22 :double :initform 0d0))
-
-(export (boxed-related-symbols 'trapezoid))
-
-(define-g-boxed-opaque font "GdkFont"
- :alloc (error "GDK:FONT objects may not be allocated directly"))
-
-(export (boxed-related-symbols 'font))
-
-(define-g-boxed-cstruct color "GdkColor"
- (pixel :uint32 :initform 0)
- (red :uint16 :initform 0)
- (green :uint16 :initform 0)
- (blue :uint16 :initform 0))
-
-(export (boxed-related-symbols 'color))
-
(define-g-object-class "GdkGC" graphics-context ()
((:cffi screen graphics-context-screen (g-object screen)
"gdk_gc_get_screen" nil)
(:cffi colormap graphics-context-colormap (g-object colormap)
"gdk_gc_get_colormap" "gdk_gc_set_colormap")))
-(define-g-object-class "GdkDrawable" drawable ()
- ((:cffi display drawable-display (g-object display)
- "gdk_drawable_get_display" nil)
- (:cffi screen drawable-screen (g-object screen)
- "gdk_drawable_get_screen" nil)
- (:cffi visual drawable-visual (g-object visual)
- "gdk_drawable_get_visual" nil)
- (:cffi colormap drawable-colormap (g-object colormap)
- "gdk_drawable_get_colormap" "gdk_drawable_set_colormap")
- (:cffi depth drawable-depth :int
- "gdk_drawable_get_depth" nil)
- (:cffi clip-region drawable-clip-region (g-boxed-foreign region :return)
- "gdk_drawable_get_clip_region" nil)
- (:cffi visible-region drawable-visible-region (g-boxed-foreign region :return)
- "gdk_drawable_get_visible_region" nil)))
-
(define-g-object-class "GdkPixmap" pixmap (:superclass drawable) ())
(define-g-object-class "GdkKeymap" keymap
(in-package :gdk)
(glib:at-init ()
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (define-foreign-library gdk
- (:unix (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so"))
- (:windows "libgdk-win32-2.0-0.dll")
- (t "libgdk-2.0"))
- (define-foreign-library gdk-pixbuf
- (:unix (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so"))
- (:windows (:or "libgdk_pixbuf-win32-2.0-0" "libgdk_pixbuf-2.0-0.dll"))
- (t "libgdk_pixbuf-2.0")))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-foreign-library gdk
+ (:unix (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so"))
+ (:windows "libgdk-win32-2.0-0.dll")
+ (t "libgdk-2.0"))
+ (define-foreign-library gdk-pixbuf
+ (:unix (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so"))
+ (:windows (:or "libgdk_pixbuf-win32-2.0-0" "libgdk_pixbuf-2.0-0.dll"))
+ (t "libgdk_pixbuf-2.0"))
+
+ (define-foreign-library gtk
+ (:unix (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so"))
+ (:windows (:or "libgtk-2.0-0.dll" "libgtk-win32-2.0-0.dll"))
+ (t "libgtk-2.0")))
- (use-foreign-library gdk)
- (use-foreign-library gdk-pixbuf))
\ No newline at end of file
+ (use-foreign-library gdk)
+ (use-foreign-library gdk-pixbuf)
+ (use-foreign-library gtk))
+
+(defcvar (*gtk-major-version* "gtk_major_version" :read-only t :library gtk) :uint)
+(defcvar (*gtk-minor-version* "gtk_minor_version" :read-only t :library gtk) :uint)
+(defcvar (*gtk-micro-version* "gtk_micro_version" :read-only t :library gtk) :uint)
+(defcvar (*gtk-binary-age* "gtk_binary_age" :read-only t :library gtk) :uint)
+(defcvar (*gtk-interface-age* "gtk_interface_age" :read-only t :library gtk) :uint)
+
+(glib:push-library-version-features gtk *gtk-major-version* *gtk-minor-version*
+ 2 2
+ 2 4
+ 2 6
+ 2 8
+ 2 10
+ 2 12
+ 2 14
+ 2 16
+ 2 18)
+
+(glib:require-library-version "Gtk+" 2 16 *gtk-major-version* *gtk-minor-version*)
(defcfun gdk-threads-leave :void)
(export 'gdk-threads-leave)
+(defmacro with-gdk-threads-lock (&body body)
+ `(progn
+ (gdk-threads-enter)
+ (unwind-protect
+ (progn ,@body)
+ (gdk-threads-leave))))
+(export 'with-gdk-threads-lock)
+
;; ignored:
;; void gdk_threads_set_lock_functions (GCallback enter_fn,
;; GCallback leave_fn);
(export 'gdk-window-move-region)
-;; TODO: (because of >= 2.18)
-;; void gdk_window_flush (GdkWindow *window);
-;; gboolean gdk_window_ensure_native (GdkWindow *window);
+#+gtk-2.18
+(progn
+ (defcfun gdk-window-flush :void
+ (window (g-object gdk-window)))
+ (export 'gdk-window-flush)
+ (defcfun gdk-window-ensure-native :void
+ (window (g-object gdk-window)))
+ (export 'gdk-window-ensure-native))
(defcfun gdk-window-reparent :void
(window (g-object gdk-window))
(export 'gdk-window-lower)
+#+gtk-2.18
(defcfun gdk-window-restack :void
(window (g-object gdk-window))
(sibling (g-object gdk-window))
(above :boolean))
+#+gtk-2.18
(export 'gdk-window-restack)
(defcfun gdk-window-focus :void
;; gint *x,
;; gint *y);
-(defcfun gdk_window_get_root_coords :void
- (window (g-object gdk-window))
- (x :int)
- (y :int)
- (root-x :int)
- (root-y :int))
-
-(defun gdk-window-get-root-coords (window x y)
- (with-foreign-objects ((root-x :int) (root-y :int))
- (gdk_window_get_root_coords window x y root-x root-y)
- (values (mem-ref root-x :int) (mem-ref root-y :int))))
+#+gtk-2.18
+(progn
+ (defcfun gdk_window_get_root_coords :void
+ (window (g-object gdk-window))
+ (x :int)
+ (y :int)
+ (root-x :int)
+ (root-y :int))
+
+ (defun gdk-window-get-root-coords (window x y)
+ (with-foreign-objects ((root-x :int) (root-y :int))
+ (gdk_window_get_root_coords window x y root-x root-y)
+ (values (mem-ref root-x :int) (mem-ref root-y :int))))
+
+ (export 'gdk-window-get-root-coords))
(defcfun gdk_window_get_pointer (g-object gdk-window)
(window (g-object gdk-window))
;; GdkPointerHooks;
;; GdkPointerHooks * gdk_set_pointer_hooks (const GdkPointerHooks *new_hooks);
-(defcfun gdk-offscreen-window-get-pixmap (g-object pixmap)
- (window (g-object gdk-window)))
+#+gtk-2.18
+(progn
+ (defcfun gdk-offscreen-window-get-pixmap (g-object pixmap)
+ (window (g-object gdk-window)))
-(export 'gdk-offscreen-window-get-pixmap)
+ (export 'gdk-offscreen-window-get-pixmap)
-(defcfun (gdk-offscreen-window-embedder "gdk_offscreen_window_get_embedder") (g-object gdk-window)
- (window (g-object gdk-window)))
+ (defcfun (gdk-offscreen-window-embedder "gdk_offscreen_window_get_embedder") (g-object gdk-window)
+ (window (g-object gdk-window)))
-(defcfun gdk_offscreen_window_set_embedder :void
- (window (g-object gdk-window))
- (embedder (g-object gdk-window)))
+ (defcfun gdk_offscreen_window_set_embedder :void
+ (window (g-object gdk-window))
+ (embedder (g-object gdk-window)))
-(defun (setf gdk-offscreen-window-embedder) (new-value window)
- (gdk_offscreen_window_set_embedder window new-value))
+ (defun (setf gdk-offscreen-window-embedder) (new-value window)
+ (gdk_offscreen_window_set_embedder window new-value))
-(export 'gdk-offscreen-window-embedder)
+ (export 'gdk-offscreen-window-embedder)
-(defcfun gdk-window-geometry-changed :void
- (window (g-object gdk-window)))
+ (defcfun gdk-window-geometry-changed :void
+ (window (g-object gdk-window)))
-(export 'gdk-window-geometry-changed)
+ (export 'gdk-window-geometry-changed))
(defcfun gdk-window-redirect-to-drawable :void
(window (g-object gdk-window))
(defsystem :cl-gtk2-glib
:name :cl-gtk2-glib
- :version "0.1"
+ :version "0.1.1"
:author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
:license "LLGPL"
:serial t
(:file "glib.string")
(:file "glib.quark")
(:file "glib.gerror")
+ (:file "glib.utils")
(:file "gobject.init")
(:file "gobject.ffi.package")
(:file "gobject.boxed")
(:file "gobject.object-function"))
- :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
\ No newline at end of file
+ :depends-on (:cffi :trivial-garbage :iterate :bordeaux-threads :iterate :closer-mop))
#:g-error-condition-domain
#:g-error-condition-code
#:g-error-condition-message
- #:g-spawn-flags)
+ #:g-spawn-flags
+ #:push-library-version-features
+ #:foreign-library-minimum-version-mismatch
+ #:require-library-version)
(:documentation
"Cl-gtk2-glib is wrapper for @a[http://library.gnome.org/devel/glib/]{GLib}."))
(use-foreign-library glib)
(use-foreign-library gthread))
+(defmacro push-library-version-features (library-name major-version-var minor-version-var &body versions)
+ `(eval-when (:load-toplevel :execute)
+ ,@(iter (for (major minor) on versions by #'cddr)
+ (collect
+ `(when (or (and (= ,major-version-var ,major) (>= ,minor-version-var ,minor))
+ (> ,major-version-var ,major))
+ (pushnew ,(intern (format nil "~A-~A.~A" (string library-name) major minor) (find-package :keyword)) *features*))))))
+
+(define-condition foreign-library-minimum-version-mismatch (error)
+ ((library :initarg :library :reader .library)
+ (minimum-version :initarg :minimum-version :reader .minimum-version)
+ (actual-version :initarg :actual-version :reader .actual-version))
+ (:report (lambda (c s)
+ (format s "Library ~A has too old version: it is ~A but required to be at least ~A"
+ (.library c)
+ (.actual-version c)
+ (.minimum-version c)))))
+
+(defun require-library-version (library min-major-version min-minor-version major-version minor-version)
+ (unless (or (> major-version min-major-version)
+ (and (= major-version min-major-version)
+ (>= minor-version min-minor-version)))
+ (restart-case
+ (error 'foreign-library-minimum-version-mismatch
+ :library library
+ :minimum-version (format nil "~A.~A" min-major-version min-minor-version)
+ :actual-version (format nil "~A.~A" major-version minor-version))
+ (ignore () :report "Ignore version requirement" nil))))
+
;;
;; Glib Fundamentals
;;
(defcvar (*glib-binary-age* "glib_binary_age" :read-only t :library glib) :uint)
(defcvar (*glib-interface-age* "glib_interface_age" :read-only t :library glib) :uint)
+(push-library-version-features glib *glib-major-version* *glib-micro-version*
+ 2 2
+ 2 4
+ 2 6
+ 2 8
+ 2 10
+ 2 12
+ 2 14
+ 2 16
+ 2 18
+ 2 20
+ 2 22)
+
+(require-library-version "Glib" 2 20 *glib-major-version* *glib-minor-version*)
+
;;
;; Omitted:
;; Limits of Basic Types, Standard Macros, Type Conversion Macros, Byte Order Macros,
--- /dev/null
+(in-package :glib)
+
+(defcfun g-get-user-cache-dir :string)
+
+(defun get-user-cache-dir ()
+ (g-get-user-cache-dir))
+
+(export 'get-user-cache-dir)
+
+(defcfun g-get-user-data-dir :string)
+
+(defun get-user-data-dir ()
+ (g-get-user-data-dir))
+
+(export 'get-user-data-dir)
+
+(defcfun g-get-user-config-dir :string)
+
+(defun get-user-config-dir ()
+ (g-get-user-config-dir))
+
+(export 'get-user-config-dir)
+
+(defcfun g-build-filenamev (:string :free-from-foreign t)
+ (args :pointer))
+
+(defun build-filename (&rest args)
+ (let* ((n (length args))
+ (arr (g-malloc (* (1+ n) (foreign-type-size :pointer)))))
+
+ (iter (for i from 0)
+ (for arg in args)
+ (setf (mem-aref arr :pointer i) (g-strdup arg)))
+ (setf (mem-aref arr :pointer n) (null-pointer))
+
+ (prog1
+ (g-build-filenamev arr)
+
+ (iter (for i from 0)
+ (for str-ptr = (mem-aref arr :pointer i))
+ (until (null-pointer-p str-ptr))
+ (g-free str-ptr))
+ (g-free arr))))
+
+(export 'build-filename)
+
(make-instance 'boxed-opaque-foreign-type :info info :return-p return-p))
(defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type))
- (prog1 (g-boxed-opaque-pointer proxy)
- (when (g-boxed-foreign-return-p type)
- (tg:cancel-finalization proxy)
- (setf (g-boxed-opaque-pointer proxy) nil))))
+ (if (null proxy)
+ (null-pointer)
+ (prog1 (g-boxed-opaque-pointer proxy)
+ (when (g-boxed-foreign-return-p type)
+ (tg:cancel-finalization proxy)
+ (setf (g-boxed-opaque-pointer proxy) nil)))))
(defmethod free-translated-object (native (type boxed-opaque-foreign-type) param)
(declare (ignore native type param)))
(defpackage :gobject
- (:use :cl :glib :cffi :tg :bordeaux-threads :iter :closer-mop :gobject.ffi)
- #+(or clozure-common-lisp openmcl) (:shadowing-import-from :closer-mop #:defgeneric #:ensure-generic-function #:standard-generic-function)
+ (:use :c2cl :glib :cffi :tg :bordeaux-threads :iter :closer-mop :gobject.ffi)
(:export #:g-type
#:g-type-string
#:g-type-numeric
(defsystem :cl-gtk2-gtkglext
:name :cl-gtk2-gtkglext
- :version "0.1"
+ :version "0.1.1"
:author "Vitaly Mayatskikh <v.mayatskih@gmail.com>"
:license "LLGPL"
:serial t
+(defpackage #:cl-gtk2-gtk-system
+ (:use #:cl #:asdf))
+
+(in-package #:cl-gtk2-gtk-system)
+
+(defclass plain-file (static-file)
+ ((type :initarg :type :reader plain-file-type :initform nil)))
+
+(defmethod source-file-type ((c plain-file) (s module))
+ (plain-file-type c))
+
(defsystem :cl-gtk2-gtk
:name :cl-gtk2-gtk
- :version "0.1"
+ :version "0.1.1"
:author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
:license "LLGPL"
:serial t
(:file "gtk.dialog")
(:file "gtk.window")
(:file "gtk.window-group")
+ (:file "gtk.icon-factory")
(:file "gtk.image")
(:file "gtk.label")
(:file "gtk.progress-bar")
(:file "gtk.scale-button")
(:file "gtk.entry")
(:file "gtk.spin-button")
+ (:file "gtk.selections")
+ (:file "gtk.dnd")
(:file "gtk.text")
(:file "gtk.tree-model")
(:file "gtk.tree-view-column")
(:file "gtk.link-button")
(:file "gtk.list-store")
(:file "gtk.tree-store")
+ (:file "gtk.tree-model-filter")
+ (:file "gtk.clipboard")
(:file "gtk.main-loop-events")
(:file "gtk.demo")
(:file "gtk.timer")
(:module "demo-files"
- :pathname "demo"
- :components ((:static-file "demo1.glade")
- (:static-file "demo1.ui")
- (:static-file "text-editor.glade")
- (:static-file "text-editor.ui"))))
+ :pathname "demo/"
+ :components ((:plain-file "demo1" :type "ui")
+ (:plain-file "text-editor" :type "ui"))))
:depends-on (:cl-gtk2-glib :cffi :cl-gtk2-gdk :bordeaux-threads :iterate :cl-gtk2-pango))
+++ /dev/null
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">
-<!--Generated with glade3 3.4.5 on Wed Mar 18 23:56:40 2009 -->
-<glade-interface>
- <widget class="GtkWindow" id="window1">
- <property name="title" translatable="yes">Gtk Builder Demo</property>
- <property name="window_position">GTK_WIN_POS_CENTER</property>
- <property name="icon_name">gtk-unindent</property>
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkMenuBar" id="menubar1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkMenuItem" id="menuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_File</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-new</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-open</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-save</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-save-as</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">
- <property name="visible">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem5">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-quit</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="quit_cb"/>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Edit</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu2">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem6">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-cut</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem7">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-copy</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem8">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-paste</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem9">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-delete</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_View</property>
- <property name="use_underline">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Help</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu3">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem10">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-about</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="about_cb"/>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToolbar" id="toolbar1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkToolButton" id="toolbutton1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Button1</property>
- <property name="stock_id">gtk-about</property>
- <signal name="clicked" handler="toolbutton1_clicked_cb"/>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToggleToolButton" id="Red">
- <property name="visible">True</property>
- <property name="stock_id">gtk-no</property>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="position">1</property>
- </packing>
- </child>
- <child>
- <widget class="GtkScrolledWindow" id="scrolledwindow1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <child>
- <widget class="GtkTextView" id="textview1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="position">2</property>
- </packing>
- </child>
- <child>
- <widget class="GtkStatusbar" id="statusbar1">
- <property name="visible">True</property>
- <property name="spacing">2</property>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="position">3</property>
- </packing>
- </child>
- </widget>
- </child>
- </widget>
-</glade-interface>
+++ /dev/null
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">
-<!--Generated with glade3 3.4.5 on Thu Mar 19 02:56:11 2009 -->
-<glade-interface>
- <widget class="GtkWindow" id="window1">
- <property name="title" translatable="yes">Lisp IDE :)</property>
- <property name="window_position">GTK_WIN_POS_CENTER</property>
- <property name="default_width">300</property>
- <property name="default_height">200</property>
- <property name="icon_name">accessories-text-editor</property>
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkMenuBar" id="menubar1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkMenuItem" id="menuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_File</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-new</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="new"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-open</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="open"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-save</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="save"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-save-as</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="save-as"/>
- </widget>
- </child>
- <child>
- <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">
- <property name="visible">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem5">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-quit</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="quit"/>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Edit</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu2">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem6">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-cut</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="cut"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem7">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-copy</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="copy"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem8">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-paste</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="paste"/>
- </widget>
- </child>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem9">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-delete</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="delete"/>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_View</property>
- <property name="use_underline">True</property>
- </widget>
- </child>
- <child>
- <widget class="GtkMenuItem" id="menuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Help</property>
- <property name="use_underline">True</property>
- <child>
- <widget class="GtkMenu" id="menu3">
- <property name="visible">True</property>
- <child>
- <widget class="GtkImageMenuItem" id="imagemenuitem10">
- <property name="visible">True</property>
- <property name="label" translatable="yes">gtk-about</property>
- <property name="use_underline">True</property>
- <property name="use_stock">True</property>
- <signal name="activate" handler="about"/>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToolbar" id="toolbar1">
- <property name="visible">True</property>
- <property name="toolbar_style">GTK_TOOLBAR_ICONS</property>
- <child>
- <widget class="GtkToolButton" id="toolbutton1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">New</property>
- <property name="stock_id">gtk-new</property>
- <signal name="clicked" handler="new"/>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToolButton" id="toolbutton2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Open</property>
- <property name="stock_id">gtk-open</property>
- <signal name="clicked" handler="open"/>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToolButton" id="toolbutton3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Save</property>
- <property name="stock_id">gtk-save</property>
- <signal name="clicked" handler="save"/>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- <child>
- <widget class="GtkToolButton" id="toolbutton4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Save as</property>
- <property name="stock_id">gtk-save-as</property>
- <signal name="clicked" handler="save-as"/>
- </widget>
- </child>
- <child>
- <widget class="GtkToolButton" id="toolbutton5">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Eval</property>
- <property name="stock_id">gtk-execute</property>
- <signal name="clicked" handler="eval"/>
- </widget>
- <packing>
- <property name="homogeneous">True</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="position">1</property>
- </packing>
- </child>
- <child>
- <widget class="GtkScrolledWindow" id="scrolledwindow1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <child>
- <widget class="GtkTextView" id="textview1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="position">2</property>
- </packing>
- </child>
- <child>
- <widget class="GtkStatusbar" id="statusbar1">
- <property name="visible">True</property>
- <property name="spacing">2</property>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="position">3</property>
- </packing>
- </child>
- </widget>
- </child>
- </widget>
-</glade-interface>
; TODO: gtk_cell_renderer_stop_editing
-; TODO: gtk_cell_renderer_get_fixed_size
+(defcfun gtk-cell-renderer-get-fixed-size :void
+ (cell (g-object cell-renderer))
+ (width (:pointer :int))
+ (height (:pointer :int)))
+
+(defun cell-renderer-get-fixed-size (cell)
+ (with-foreign-objects ((width :int) (height :int))
+ (gtk-cell-renderer-get-fixed-size cell width height)
+ (values (mem-ref width :int)
+ (mem-ref height :int))))
+
+(export 'cell-renderer-get-fixed-size)
+
+(defcfun (cell-renderer-set-fixed-size "gtk_cell_renderer_set_fixed_size") :void
+ (cell (g-object cell-renderer))
+ (width :int)
+ (height :int))
+
+(export 'cell-renderer-set-fixed-size)
; TODO: GtkCellRendererAccel
(defun container-call-get-property (container child property-name type)
(with-foreign-object (gvalue 'g-value)
- (g-value-unset gvalue)
+ (g-value-zero gvalue)
(g-value-init gvalue (ensure-g-type type))
(gtk-container-child-get-property container child property-name gvalue)
(prog1 (parse-g-value gvalue)
--- /dev/null
+(in-package :gtk)
+
+(defcfun gtk-clipboard-set-text :void
+ (clipboard g-object)
+ (text :string)
+ (len :int))
+
+(defun clipboard-set-text (clipboard text)
+ (gtk-clipboard-set-text clipboard text -1))
+
+(export 'clipboard-set-text)
+
(defpackage :gtk-demo
(:use :cl :gtk :gdk :gobject :iter)
- (:export #:demo-all
- #:test
- #:test-entry
- #:table-packing
- #:test-pixbuf
- #:test-image
- #:test-progress-bar
- #:test-statusbar
- #:test-scale-button
- #:test-text-view
- #:demo-code-editor
- #:test-treeview-list
- #:test-combo-box
- #:test-ui-manager
- #:test-color-button
- #:test-color-selection
- #:test-file-chooser
- #:test-font-chooser
- #:test-notebook
- #:test-calendar
- #:test-box-child-property
- #:test-builder
- #:demo-text-editor
- #:demo-class-browser
- #:demo-treeview-tree
- #:test-custom-window
- #:test-assistant
- #:test-entry-completion
- #:test-ui-markup
- #:test-list-store
- #:test-tree-store
- #:test-gdk))
+ (:export #:demo))
(in-package :gtk-demo)
(defparameter *src-location* (asdf:component-pathname (asdf:find-system :cl-gtk2-gtk)))
+(defclass link-text-tag (text-tag)
+ ()
+ (:metaclass gobject-class))
+
+(defun make-link-fn-tag (buffer fn)
+ (let ((tag (make-instance 'link-text-tag :foreground "blue" :underline :single)))
+ (text-tag-table-add (text-buffer-tag-table buffer) tag)
+ (connect-signal tag "event"
+ (lambda (tag object event it)
+ (declare (ignore tag object it))
+ (when (and (eq (event-type event) :button-release)
+ (eq (event-button-button event) 1))
+ (when fn
+ (funcall fn)))))
+ tag))
+
+(defun get-page (name)
+ (or (get name 'demo-page)
+ (get 'page-404 'demo-page)))
+
+(defun (setf get-page) (page name)
+ (setf (get name 'demo-page) page))
+
+(defmacro def-demo-page ((name &key (index 'index)) &body body)
+ `(setf (get-page ',name)
+ '(,@(when index (list `(:p (:link "To main" ,index))))
+ ,@body)))
+
+(def-demo-page (page-404)
+ (:p "Non-existent page"))
+
+(def-demo-page (index :index nil)
+ (:p (:b "cl-gtk2 demonstration"))
+ (:p "")
+ (:p "This demo application is a demonstration of what cl-gtk2 can do. You can click on any of blue underlined links to invoke the demonstration.")
+ (:p "")
+ (:p "You may try these demos:")
+ (:ol (:fn "Demonstrates usage of tree store" test-tree-store)
+ (:fn "Simple test of packing widgets into GtkTable"
+ table-packing)
+ (:fn "Test of GtkStatusbar" test-statusbar)
+ (:fn "Not working example of GtkEntryCompletion"
+ test-entry-completion)
+ (:fn "Simple test of non-GObject subclass of GtkWindow"
+ test-custom-window)
+ (:fn "Testing progress-bar" test-progress-bar)
+ (:fn "Simple test of GtkAssistant wizard" test-assistant)
+ (:fn "Using GtkImage with stock icon" test-image)
+ (:fn "Test of GtkCalendar" test-calendar)
+ (:fn "Test of GtkBuilder" test-builder)
+ (:fn "Test of GtkColorButton" test-color-button)
+ (:fn "Test of UI Markup" test-ui-markup)
+ (:fn "Test of scale button with icons" test-scale-button)
+ (:fn "Testing GtkComboBox" test-combo-box)
+ (:fn "Advanced demo: show s-expression tree structure"
+ demo-treeview-tree)
+ (:fn "Test of child-property usage" test-box-child-property)
+ (:fn "Demonstrates usage of list store" test-list-store)
+ (:fn "Test various gdk primitives" test-gdk)
+ (:fn "Test GtkNotebook" test-notebook)
+ (:fn "More advanced example: text editor with ability to evaluate lisp expressions"
+ demo-text-editor)
+ (:fn "(not completed)" test-pixbuf)
+ (:fn "Testing GtkTextEntry" test-entry)
+ (:fn "Test of treeview with CL-GTK2-GTK:ARRAY-LIST-STORE"
+ test-treeview-list)
+ (:fn "Test of GtkFileChooser" test-file-chooser)
+ (:fn "Test of GtkColorSelection" test-color-selection)
+ (:fn "Test of GtkTextView" test-text-view)
+ (:fn "A simple test of 'on-expose' event" test)
+ (:fn "Show slots of a given class" demo-class-browser)
+ (:fn "Testing GtkUIManager" test-ui-manager)
+ (:fn "GtkFontChooser" test-font-chooser)))
+
+(defun clear-text-tag-table (table)
+ (let (tags)
+ (text-tag-table-foreach table
+ (lambda (tag)
+ (push tag tags)))
+ (iter (for tag in tags)
+ (text-tag-table-remove table tag))))
+
+(defun fill-demo-text-buffer (buffer text-view &optional (page 'index))
+ (declare (ignorable text-view))
+ (clear-text-tag-table (text-buffer-tag-table buffer))
+ (setf (text-buffer-text buffer) "")
+ (text-tag-table-add (text-buffer-tag-table buffer) (make-instance 'text-tag :name "bold" :weight 700))
+ (labels ((insert-text (text)
+ (text-buffer-insert buffer text))
+ (insert-link (text fn)
+ (let ((offset (text-iter-offset (text-buffer-get-end-iter buffer))))
+ (text-buffer-insert buffer text)
+ (text-buffer-apply-tag buffer (make-link-fn-tag buffer fn)
+ (text-buffer-get-iter-at-offset buffer offset)
+ (text-buffer-get-end-iter buffer))))
+ (insert-newline ()
+ (text-buffer-insert buffer (format nil "~%")))
+ (process-paragraph (node)
+ (map nil #'process (rest node))
+ (insert-newline))
+ (process-link (node)
+ (insert-link (second node) (lambda () (fill-demo-text-buffer buffer text-view (third node)))))
+ (process-fn (node)
+ (insert-link (second node) (third node)))
+ (process-ul (node)
+ (iter (for n in (rest node))
+ (for i from 1)
+ (insert-text "* ")
+ (process n)
+ (insert-newline)))
+ (process-ol (node)
+ (iter (for n in (rest node))
+ (for i from 1)
+ (insert-text (format nil "~A. " i))
+ (process n)
+ (insert-newline)))
+ (process-bold (node)
+ (let ((offset (text-iter-offset (text-buffer-get-end-iter buffer))))
+ (map nil #'process (rest node))
+ (text-buffer-apply-tag buffer "bold" (text-buffer-get-iter-at-offset buffer offset) (text-buffer-get-end-iter buffer))))
+ (process (node)
+ (cond
+ ((stringp node) (insert-text node))
+ ((and (listp node) (eq (car node) :p)) (process-paragraph node))
+ ((and (listp node) (eq (car node) :link)) (process-link node))
+ ((and (listp node) (eq (car node) :fn)) (process-fn node))
+ ((and (listp node) (eq (car node) :ul)) (process-ul node))
+ ((and (listp node) (eq (car node) :ol)) (process-ol node))
+ ((and (listp node) (eq (car node) :b)) (process-bold node))
+ ((listp node) (map nil #'process node))
+ (t (error "Do not know how to proceed")))))
+ (process (get-page page))))
+
+(defun make-demo-text-buffer (text-view)
+ (let ((buffer (make-instance 'text-buffer)))
+ (fill-demo-text-buffer buffer text-view)
+ buffer))
+
+(defvar *active-tag* nil)
+
+(defun tv-motion-notify (tv event)
+ (multiple-value-bind (x y)
+ (text-view-window-to-buffer-coords tv :text
+ (round (event-motion-x event)) (round (event-motion-y event)))
+ (let ((it (text-view-get-iter-at-location tv x y)))
+ (if it
+ (let ((tags (text-iter-tags it)))
+ (if tags
+ (loop
+ for tag in tags
+ when (typep tag 'link-text-tag)
+ do (progn
+ (when *active-tag*
+ (setf (text-tag-foreground *active-tag*) "blue"
+ *active-tag* nil))
+ (setf (gdk-window-cursor (text-view-get-window tv :text))
+ (cursor-new-for-display (drawable-display (text-view-get-window tv :text))
+ :hand2)
+ *active-tag* tag
+ (text-tag-foreground *active-tag*) "red")))
+ (progn
+ (setf (gdk-window-cursor (text-view-get-window tv :text)) nil)
+ (when *active-tag*
+ (setf (text-tag-foreground *active-tag*) "blue"
+ *active-tag* nil)))))
+ (progn
+ (setf (gdk-window-cursor (text-view-get-window tv :text)) nil)
+ (when *active-tag*
+ (setf (text-tag-foreground *active-tag*) "blue"
+ *active-tag* nil)))))))
+
+(defun make-demo-text-view ()
+ (let ((tv (make-instance 'text-view :editable nil :cursor-visible nil :wrap-mode :word :pixels-below-lines 1 :left-margin 5 :right-margin 5)))
+ (setf (text-view-buffer tv)
+ (make-demo-text-buffer tv))
+ (connect-signal tv "motion-notify-event" #'tv-motion-notify)
+ tv))
+
+(defun demo ()
+ (within-main-loop
+ (let-ui
+ (gtk-window
+ :var w
+ :title "Gtk+ demo for Lisp"
+ :window-position :center
+ :default-width 500
+ :default-height 500
+ (scrolled-window
+ :hscrollbar-policy :automatic
+ :vscrollbar-policy :automatic
+ (:expr (make-demo-text-view))))
+ (connect-signal w "destroy"
+ (lambda (w)
+ (declare (ignore w))
+ (leave-gtk-main)))
+ (widget-show w))))
+
(defun test ()
"A simple test of 'on-expose' event"
(within-main-loop
- (let ((window (make-instance 'gtk-window :type :toplevel :app-paintable t))
+ (let ((window (make-instance 'gtk-window :type :toplevel))
+ (area (make-instance 'drawing-area))
x y)
- (g-signal-connect window "destroy" (lambda (widget)
- (declare (ignore widget))
- (leave-gtk-main)))
- (g-signal-connect window "motion-notify-event" (lambda (widget event)
- (declare (ignore widget))
- (setf x (event-motion-x event)
- y (event-motion-y event))
- (widget-queue-draw window)))
- (g-signal-connect window "expose-event"
- (lambda (widget event)
- (declare (ignore widget event))
- (let* ((gdk-window (widget-window window))
- (gc (graphics-context-new gdk-window))
- (layout (widget-create-pango-layout window (format nil "X: ~F~%Y: ~F" x y))))
- (draw-layout gdk-window gc 0 0 layout)
- (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 0 :blue 0))
- (multiple-value-bind (x y) (drawable-get-size gdk-window)
- (draw-line gdk-window gc 0 0 x y)))))
- (g-signal-connect window "configure-event"
- (lambda (widget event)
- (declare (ignore widget event))
- (widget-queue-draw window)))
- (widget-show window)
- (push :pointer-motion-mask (gdk-window-events (widget-window window))))))
+ (container-add window area)
+ (connect-signal window "destroy" (lambda (widget)
+ (declare (ignore widget))
+ (leave-gtk-main)))
+ (connect-signal area "motion-notify-event"
+ (lambda (widget event)
+ (declare (ignore widget))
+ (setf x (event-motion-x event)
+ y (event-motion-y event))
+ (widget-queue-draw window)))
+ (connect-signal area "expose-event"
+ (lambda (widget event)
+ (declare (ignore widget event))
+ (let* ((gdk-window (widget-window area))
+ (gc (graphics-context-new gdk-window))
+ (layout (widget-create-pango-layout area (format nil "X: ~F~%Y: ~F" x y))))
+ (draw-layout gdk-window gc 0 0 layout)
+ (setf (graphics-context-rgb-fg-color gc) (make-color :red 65535 :green 0 :blue 0))
+ (multiple-value-bind (x y) (drawable-get-size gdk-window)
+ (draw-line gdk-window gc 0 0 x y)))))
+ (connect-signal area "realize"
+ (lambda (widget)
+ (declare (ignore widget))
+ (pushnew :pointer-motion-mask (gdk-window-events (widget-window area)))))
+ (connect-signal area "configure-event"
+ (lambda (widget event)
+ (declare (ignore widget event))
+ (widget-queue-draw area)))
+ (widget-show window))))
(defun test-entry ()
"Testing GtkTextEntry"
(box-pack-start box w)
(container-add w text-view))
(container-add window box)
- (g-signal-connect window "destroy" (lambda (widget) (declare (ignore widget)) (leave-gtk-main)))
- (g-signal-connect window "delete-event" (lambda (widget event)
- (declare (ignore widget event))
- (let ((dlg (make-instance 'message-dialog
- :text "Are you sure?"
- :buttons :yes-no)))
- (let ((response (dialog-run dlg)))
- (object-destroy dlg)
- (not (eq :yes response))))))
- (g-signal-connect button "clicked" (lambda (button)
- (declare (ignore button))
- (setf (text-buffer-text text-buffer)
- (format nil "~A~%~A" (text-buffer-text text-buffer) (entry-text entry))
- (entry-text entry) "")))
- (g-signal-connect button-select "clicked" (lambda (button)
- (declare (ignore button))
- (editable-select-region entry 5 10)))
- (g-signal-connect button-insert "clicked" (lambda (button)
- (declare (ignore button))
- (editable-insert-text entry "hello" 2)))
+ (connect-signal window "destroy" (lambda (widget) (declare (ignore widget)) (leave-gtk-main)))
+ (connect-signal window "delete-event" (lambda (widget event)
+ (declare (ignore widget event))
+ (let ((dlg (make-instance 'message-dialog
+ :text "Are you sure?"
+ :buttons :yes-no)))
+ (let ((response (dialog-run dlg)))
+ (object-destroy dlg)
+ (not (eq :yes response))))))
+ (connect-signal button "clicked" (lambda (button)
+ (declare (ignore button))
+ (setf (text-buffer-text text-buffer)
+ (format nil "~A~%~A" (text-buffer-text text-buffer) (entry-text entry))
+ (entry-text entry) "")))
+ (connect-signal button-select "clicked" (lambda (button)
+ (declare (ignore button))
+ (editable-select-region entry 5 10)))
+ (connect-signal button-insert "clicked" (lambda (button)
+ (declare (ignore button))
+ (editable-insert-text entry "hello" 2)))
(widget-show window))))
(defun table-packing ()
(table-attach table button-1 0 1 0 1)
(table-attach table button-2 1 2 0 1)
(table-attach table button-q 0 2 1 2)
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button-q "clicked" (lambda (b) (declare (ignore b)) (object-destroy window)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button-q "clicked" (lambda (b) (declare (ignore b)) (object-destroy window)))
(widget-show window))))
(defun test-pixbuf ()
"(not completed)"
(within-main-loop
- (let* ((window (make-instance 'gtk-window :title "Test pixbuf" :request-width 600 :request-height 240))
- (vbox (make-instance 'v-box))
- (eventbox (make-instance 'event-box))
- (vbox-1 (make-instance 'v-box)))
- (container-add window vbox)
- (box-pack-start vbox (make-instance 'label :text "Placing bg image" :font "Times New Roman Italic 10" :color "#00f" :request-height 40))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (box-pack-start vbox eventbox)
- (container-add eventbox vbox-1)
- (box-pack-start vbox-1 (make-instance 'label :text "This is the eventbox"))
- (box-pack-start vbox-1 (make-instance 'label :text "The green ball is the bg"))
- (widget-show window))))
+ (let* ((window (make-instance 'gtk-window :title "Test pixbuf" :width-request 600 :height-request 240))
+ (vbox (make-instance 'v-box))
+ (eventbox (make-instance 'event-box))
+ (vbox-1 (make-instance 'v-box)))
+ (container-add window vbox)
+ (box-pack-start vbox (make-instance 'label :text "Placing bg image" :font "Times New Roman Italic 10" :color "#00f" :height-request 40))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (box-pack-start vbox eventbox)
+ (container-add eventbox vbox-1)
+ (box-pack-start vbox-1 (make-instance 'label :text "This is the eventbox"))
+ (box-pack-start vbox-1 (make-instance 'label :text "The green ball is the bg"))
+ (widget-show window))))
(defun test-image ()
"Using GtkImage with stock icon"
(let* ((window (make-instance 'gtk-window :title "Test images"))
(image (make-instance 'image :icon-name "applications-development" :icon-size 6)))
(container-add window image)
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show window))))
(defun test-progress-bar ()
(button-pulse (make-instance 'button :label "Pulse"))
(button-set (make-instance 'button :label "Set"))
(entry (make-instance 'entry)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(container-add window v-box)
(box-pack-start v-box p-bar)
(box-pack-start v-box button-pulse)
(box-pack-start v-box button-set)
(box-pack-start v-box entry)
- (g-signal-connect button-pulse "clicked" (lambda (w) (declare (ignore w)) (progress-bar-pulse p-bar)))
- (g-signal-connect button-set "clicked" (lambda (w)
- (declare (ignore w))
- (setf (progress-bar-fraction p-bar)
- (coerce (read-from-string (entry-text entry)) 'real))))
+ (connect-signal button-pulse "clicked" (lambda (w) (declare (ignore w)) (progress-bar-pulse p-bar)))
+ (connect-signal button-set "clicked" (lambda (w)
+ (declare (ignore w))
+ (setf (progress-bar-fraction p-bar)
+ (coerce (read-from-string (entry-text entry)) 'real))))
(widget-show window))))
(defun test-statusbar ()
(entry (make-instance 'entry))
(icon (make-instance 'status-icon :icon-name "applications-development")))
(set-status-icon-tooltip icon "An icon from lisp program")
- (g-signal-connect window "destroy" (lambda (w)
- (declare (ignore w))
- #+ (or) (setf (status-icon-visible icon) nil)
- (leave-gtk-main)))
- (g-signal-connect button-push "clicked" (lambda (b)
- (declare (ignore b))
- (statusbar-push statusbar "lisp-prog" (entry-text entry))))
- (g-signal-connect button-pop "clicked" (lambda (b)
- (declare (ignore b))
- (statusbar-pop statusbar "lisp-prog")))
- (g-signal-connect icon "activate" (lambda (i)
- (declare (ignore i))
- (let ((message-dialog (make-instance 'message-dialog
- :buttons :ok
- :text "You clicked on icon!")))
- (dialog-run message-dialog)
- (object-destroy message-dialog))))
+ (connect-signal window "destroy" (lambda (w)
+ (declare (ignore w))
+ #+ (or) (setf (status-icon-visible icon) nil)
+ (leave-gtk-main)))
+ (connect-signal button-push "clicked" (lambda (b)
+ (declare (ignore b))
+ (statusbar-push statusbar "lisp-prog" (entry-text entry))))
+ (connect-signal button-pop "clicked" (lambda (b)
+ (declare (ignore b))
+ (statusbar-pop statusbar "lisp-prog")))
+ (connect-signal icon "activate" (lambda (i)
+ (declare (ignore i))
+ (let ((message-dialog (make-instance 'message-dialog
+ :buttons :ok
+ :text "You clicked on icon!")))
+ (dialog-run message-dialog)
+ (object-destroy message-dialog))))
(container-add window v-box)
(box-pack-start v-box h-box :expand nil)
(box-pack-start h-box entry)
(within-main-loop
(let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing scale button"))
(button (make-instance 'scale-button :icons (list "media-seek-backward" "media-seek-forward" "media-playback-stop" "media-playback-start") :adjustment (make-instance 'adjustment :lower -40 :upper 50 :value 20))))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(container-add window button)
(widget-show window))))
(v (make-instance 'text-view :buffer buffer :wrap-mode :word))
(box (make-instance 'v-box))
(scrolled (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button "clicked" (lambda (b)
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button "clicked" (lambda (b)
+ (declare (ignore b))
+ (multiple-value-bind (i1 i2) (text-buffer-get-selection-bounds buffer)
+ (when (and i1 i2)
+ (let* ((i1 i1) (i2 i2)
+ (dialog (make-instance 'message-dialog :buttons :ok)))
+ (setf (message-dialog-text dialog)
+ (format nil "selection: from (~A,~A) to (~A,~A)"
+ (text-iter-line i1) (text-iter-line-offset i1)
+ (text-iter-line i2) (text-iter-line-offset i2)))
+ (dialog-run dialog)
+ (object-destroy dialog))))))
+ (connect-signal bold-btn "clicked" (Lambda (b)
(declare (ignore b))
- (multiple-value-bind (i1 i2) (text-buffer-get-selection-bounds buffer)
- (when (and i1 i2)
- (let* ((i1 i1) (i2 i2)
- (dialog (make-instance 'message-dialog :buttons :ok)))
- (setf (message-dialog-text dialog)
- (format nil "selection: from (~A,~A) to (~A,~A)"
- (text-iter-line i1) (text-iter-line-offset i1)
- (text-iter-line i2) (text-iter-line-offset i2)))
- (dialog-run dialog)
- (object-destroy dialog))))))
- (g-signal-connect bold-btn "clicked" (Lambda (b)
- (declare (ignore b))
- (multiple-value-bind (start end) (text-buffer-get-selection-bounds buffer)
- (when (and start end)
- (let* ((start start)
- (end end)
- (tag (text-tag-table-lookup (text-buffer-tag-table buffer) "bold")))
- (if (text-iter-has-tag start tag)
- (text-buffer-remove-tag buffer tag start end)
- (text-buffer-apply-tag buffer tag start end)))))))
- (g-signal-connect button-insert "clicked" (lambda (b)
- (declare (ignore b))
- (let* ((iter (text-buffer-get-iter-at-mark buffer (text-buffer-get-mark buffer "insert")))
- (anchor (text-buffer-insert-child-anchor buffer iter))
- (button (make-instance 'button :label "A button!")))
- (widget-show button)
- (text-view-add-child-at-anchor v button anchor))))
+ (multiple-value-bind (start end) (text-buffer-get-selection-bounds buffer)
+ (when (and start end)
+ (let* ((start start)
+ (end end)
+ (tag (text-tag-table-lookup (text-buffer-tag-table buffer) "bold")))
+ (if (text-iter-has-tag start tag)
+ (text-buffer-remove-tag buffer tag start end)
+ (text-buffer-apply-tag buffer tag start end)))))))
+ (connect-signal button-insert "clicked" (lambda (b)
+ (declare (ignore b))
+ (let* ((iter (text-buffer-get-iter-at-mark buffer (text-buffer-get-mark buffer "insert")))
+ (anchor (text-buffer-insert-child-anchor buffer iter))
+ (button (make-instance 'button :label "A button!")))
+ (widget-show button)
+ (text-view-add-child-at-anchor v button anchor))))
(let ((tag (make-instance 'text-tag :name "bold" :weight 700)))
(text-tag-table-add (text-buffer-tag-table buffer) tag)
- (g-signal-connect tag "event"
- (lambda (tag object event iter)
- (declare (ignore tag object iter))
- (when (eq (event-type event) :button-release)
- (let ((dlg (make-instance 'message-dialog :text "You clicked on bold text." :buttons :ok)))
- (dialog-run dlg)
- (object-destroy dlg))))))
+ (connect-signal tag "event"
+ (lambda (tag object event iter)
+ (declare (ignore tag object iter))
+ (when (eq (event-type event) :button-release)
+ (let ((dlg (make-instance 'message-dialog :text "You clicked on bold text." :buttons :ok)))
+ (dialog-run dlg)
+ (object-destroy dlg))))))
(container-add window box)
(container-add scrolled v)
(box-pack-start box button :expand nil)
(scrolled (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
(buffer (make-instance 'text-buffer))
(view (make-instance 'text-view :buffer buffer)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(container-add window scrolled)
(container-add scrolled view)
(widget-show window)
- (g-signal-connect buffer "insert-text" (lambda (buffer location text len)
- (let* ((buffer buffer)
- (location location))
- (format t "~A~%" (list buffer location text len))))))))
+ (connect-signal buffer "insert-text" (lambda (buffer location text len)
+ (let* ((buffer buffer)
+ (location location))
+ (format t "~A~%" (list buffer location text len))))))))
(defstruct tvi title value)
(store-add-item model (make-tvi :title "Saturday" :value 6))
(store-add-item model (make-tvi :title "Sunday" :value 7))
(setf (tree-view-model tv) model (tree-view-tooltip-column tv) 0)
- (gobject:g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (gobject:g-signal-connect button "clicked" (lambda (b)
- (declare (ignore b))
- (store-add-item model (make-tvi :title (entry-text title-entry)
- :value (or (parse-integer (entry-text value-entry)
- :junk-allowed t)
- 0)))))
- (g-signal-connect tv "row-activated" (lambda (tv path column)
- (declare (ignore tv column))
- (format t "You clicked on row ~A~%" (tree-path-indices path))))
+ (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (gobject:connect-signal button "clicked" (lambda (b)
+ (declare (ignore b))
+ (store-add-item model (make-tvi :title (entry-text title-entry)
+ :value (or (parse-integer (entry-text value-entry)
+ :junk-allowed t)
+ 0)))))
+ (connect-signal tv "row-activated" (lambda (tv path column)
+ (declare (ignore tv column))
+ (show-message (format nil "You clicked on row ~A" (tree-path-indices path)))))
(container-add window v-box)
(box-pack-start v-box h-box :expand nil)
(box-pack-start h-box title-entry :expand nil)
(store-add-item model (make-tvi :title "Friday" :value 5))
(store-add-item model (make-tvi :title "Saturday" :value 6))
(store-add-item model (make-tvi :title "Sunday" :value 7))
- (gobject:g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (gobject:g-signal-connect button "clicked" (lambda (b)
- (declare (ignore b))
- (store-add-item model (make-tvi :title (entry-text title-entry)
- :value (or (parse-integer (entry-text value-entry)
- :junk-allowed t)
- 0)))))
- (g-signal-connect combo-box "changed" (lambda (c)
- (declare (ignore c))
- (format t "You clicked on row ~A~%" (combo-box-active combo-box))))
+ (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (gobject:connect-signal button "clicked" (lambda (b)
+ (declare (ignore b))
+ (store-add-item model (make-tvi :title (entry-text title-entry)
+ :value (or (parse-integer (entry-text value-entry)
+ :junk-allowed t)
+ 0)))))
+ (connect-signal combo-box "changed" (lambda (c)
+ (declare (ignore c))
+ (show-message (format nil "You clicked on row ~A~%" (combo-box-active combo-box)))))
(container-add window v-box)
(box-pack-start v-box h-box :expand nil)
(box-pack-start h-box title-entry :expand nil)
<separator/>
</toolbar>
</ui>")
- (gobject:g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (gobject:connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(iter (with fn = (lambda (action) (when print-confirmation (format t "Action ~A with name ~A activated~%" action (action-name action)))))
(with action-group = (make-instance 'action-group :name "Actions"))
(finally (let ((a (make-instance 'toggle-action :name "print-confirm" :label "Print" :stock-id "gtk-print-report" :active t)))
- (g-signal-connect a "toggled" (lambda (action) (setf print-confirmation (toggle-action-active action))))
+ (connect-signal a "toggled" (lambda (action) (setf print-confirmation (toggle-action-active action))))
(action-group-add-action action-group a))
(ui-manager-insert-action-group ui-manager action-group 0))
(for (name stock-id) in '(("justify-left" "gtk-justify-left")
("justify-right" "gtk-justify-right")
("zoom-in" "gtk-zoom-in")))
(for action = (make-instance 'action :name name :stock-id stock-id))
- (g-signal-connect action "activate" fn)
+ (connect-signal action "activate" fn)
(action-group-add-action action-group action))
(let ((widget (ui-manager-widget ui-manager "/toolbar1")))
(when widget
(within-main-loop
(let ((window (make-instance 'gtk-window :title "Color button" :type :toplevel :window-position :center :width-request 100 :height-request 100))
(button (make-instance 'color-button :title "Color button")))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button "color-set" (lambda (b)
- (declare (ignore b))
- (format t "Chose color ~A~%" (color-button-color button))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button "color-set" (lambda (b)
+ (declare (ignore b))
+ (show-message (format nil "Chose color ~A" (color-button-color button)))))
(container-add window button)
(widget-show window))))
(within-main-loop
(let ((window (make-instance 'gtk-window :title "Color selection" :type :toplevel :window-position :center))
(selection (make-instance 'color-selection :has-opacity-control t)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect selection "color-changed" (lambda (s) (declare (ignore s)) (unless (color-selection-adjusting-p selection) (format t "color: ~A~%" (color-selection-current-color selection)))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal selection "color-changed" (lambda (s) (declare (ignore s)) (unless (color-selection-adjusting-p selection) (format t "color: ~A~%" (color-selection-current-color selection)))))
(container-add window selection)
(widget-show window))))
(v-box (make-instance 'v-box))
(button (make-instance 'file-chooser-button :action :open))
(b (make-instance 'button :label "Choose for save" :stock-id "gtk-save")))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button "file-set" (lambda (b) (declare (ignore b)) (format t "File set: ~A~%" (file-chooser-filename button))))
- (g-signal-connect b "clicked" (lambda (b)
- (declare (ignore b))
- (let ((d (make-instance 'file-chooser-dialog :action :save :title "Choose file to save")))
- (dialog-add-button d "gtk-save" :accept)
- (dialog-add-button d "gtk-cancel" :cancel)
- (when (eq (dialog-run d) :accept)
- (format t "saved to file ~A~%" (file-chooser-filename d)))
- (object-destroy d))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button "file-set" (lambda (b) (declare (ignore b)) (format t "File set: ~A~%" (file-chooser-filename button))))
+ (connect-signal b "clicked" (lambda (b)
+ (declare (ignore b))
+ (let ((d (make-instance 'file-chooser-dialog :action :save :title "Choose file to save")))
+ (dialog-add-button d "gtk-save" :accept)
+ (dialog-add-button d "gtk-cancel" :cancel)
+ (when (eq (dialog-run d) :accept)
+ (format t "saved to file ~A~%" (file-chooser-filename d)))
+ (object-destroy d))))
(container-add window v-box)
(box-pack-start v-box button)
(box-pack-start v-box b)
(let ((window (make-instance 'gtk-window :title "fonts" :type :toplevel :window-position :center :default-width 100 :default-height 100))
(v-box (make-instance 'v-box))
(button (make-instance 'font-button :title "Choose font" :font-name "Sans 10")))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button "font-set" (lambda (b) (declare (ignore b)) (format t "Chose font ~A~%" (font-button-font-name button))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button "font-set" (lambda (b) (declare (ignore b)) (format t "Chose font ~A~%" (font-button-font-name button))))
(container-add window v-box)
(box-pack-start v-box button)
(widget-show window))))
(let ((window (make-instance 'gtk-window :title "Notebook" :type :toplevel :window-position :center :default-width 100 :default-height 100))
(expander (make-instance 'expander :expanded t :label "notebook"))
(notebook (make-instance 'notebook :enable-popup t)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(iter (for i from 0 to 5)
(for page = (make-instance 'label :label (format nil "Label for page ~A" i)))
(for tab-label = (make-instance 'label :label (format nil "Tab ~A" i)))
(for tab-button = (make-instance 'button
:image (make-instance 'image :stock "gtk-close" :icon-size 1)
:relief :none))
- (g-signal-connect tab-button "clicked"
- (let ((page page))
- (lambda (button)
- (declare (ignore button))
- (format t "Removing page ~A~%" page)
- (notebook-remove-page notebook page))))
+ (connect-signal tab-button "clicked"
+ (let ((page page))
+ (lambda (button)
+ (declare (ignore button))
+ (format t "Removing page ~A~%" page)
+ (notebook-remove-page notebook page))))
(for tab-hbox = (make-instance 'h-box))
(box-pack-start tab-hbox tab-label)
(box-pack-start tab-hbox tab-button)
(within-main-loop
(let ((window (make-instance 'gtk-window :title "Calendar" :type :toplevel :window-position :center :default-width 100 :default-height 100))
(calendar (make-instance 'calendar :detail-function #'calendar-detail)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect calendar "day-selected" (lambda (c) (declare (ignore c)) (format t "selected: year ~A month ~A day ~A~%"
- (calendar-year calendar)
- (calendar-month calendar)
- (calendar-day calendar))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal calendar "day-selected" (lambda (c) (declare (ignore c)) (format t "selected: year ~A month ~A day ~A~%"
+ (calendar-year calendar)
+ (calendar-month calendar)
+ (calendar-day calendar))))
(container-add window calendar)
(widget-show window))))
(let ((window (make-instance 'gtk-window :title "Text box child property" :type :toplevel :window-position :center :width-request 200 :height-request 200))
(box (make-instance 'h-box))
(button (make-instance 'toggle-button :active t :label "Expand")))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect button "toggled" (lambda (b) (declare (ignore b)) (setf (box-child-expand box button) (toggle-button-active button))))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal button "toggled" (lambda (b) (declare (ignore b)) (setf (box-child-expand box button) (toggle-button-active button))))
(container-add window box)
(box-pack-start box button)
(widget-show window))))
(setf (text-buffer-text (text-view-buffer text-view))
(format nil "Clicked ~A times~%" (incf c)))
(statusbar-pop (builder-get-object builder "statusbar1")
- "times")
+ "times")
(statusbar-push (builder-get-object builder "statusbar1")
- "times"
- (format nil "~A times" c))))
+ "times"
+ (format nil "~A times" c))))
("quit_cb" ,(lambda (&rest args)
(print args)
(object-destroy (builder-get-object builder "window1"))))
:logo-icon-name "gtk-apply")))
(dialog-run d)
(object-destroy d)))))))
- (g-signal-connect (builder-get-object builder "window1") "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal (builder-get-object builder "window1") "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(statusbar-push (builder-get-object builder "statusbar1") "times" "0 times")
(widget-show (builder-get-object builder "window1")))))
("about" ,#'about)
("quit" ,#'quit)
("eval" ,#'cb-eval)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
- (g-signal-connect (text-view-buffer text-view) "changed" (lambda (b) (declare (ignore b)) (setf modified-p t) (set-properties)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (connect-signal (text-view-buffer text-view) "changed" (lambda (b) (declare (ignore b)) (setf modified-p t) (set-properties)))
(widget-show window)))))
(defun demo-class-browser ()
"Show slots of a given class"
(let ((output *standard-output*))
- (with-main-loop
- (let* ((window (make-instance 'gtk-window
- :window-position :center
- :title "Class Browser"
- :default-width 400
- :default-height 600))
- (search-entry (make-instance 'entry))
- (search-button (make-instance 'button :label "Search"))
- (scroll (make-instance 'scrolled-window
- :hscrollbar-policy :automatic
- :vscrollbar-policy :automatic))
- (slots-model (make-instance 'array-list-store))
- (slots-list (make-instance 'tree-view :model slots-model)))
- (let ((v-box (make-instance 'v-box))
- (search-box (make-instance 'h-box)))
- (container-add window v-box)
- (box-pack-start v-box search-box :expand nil)
- (box-pack-start search-box search-entry)
- (box-pack-start search-box search-button :expand nil)
- (box-pack-start v-box scroll)
- (container-add scroll slots-list))
- (store-add-column slots-model "gchararray"
- (lambda (slot)
- (format nil "~S" (closer-mop:slot-definition-name slot))))
- (let ((col (make-instance 'tree-view-column :title "Slot name"))
- (cr (make-instance 'cell-renderer-text)))
- (tree-view-column-pack-start col cr)
- (tree-view-column-add-attribute col cr "text" 0)
- (tree-view-append-column slots-list col))
- (labels ((display-class-slots (class)
- (format output "Displaying ~A~%" class)
- (loop
- repeat (store-items-count slots-model)
- do (store-remove-item slots-model (store-item slots-model 0)))
- (closer-mop:finalize-inheritance class)
- (loop
- for slot in (closer-mop:class-slots class)
- do (store-add-item slots-model slot)))
- (on-search-clicked (button)
- (declare (ignore button))
- (with-gtk-message-error-handler
- (let* ((class-name (read-from-string (entry-text search-entry)))
- (class (find-class class-name)))
- (display-class-slots class)))))
- (g-signal-connect search-button "clicked" #'on-search-clicked))
- (widget-show window)))))
+ (within-main-loop
+ (let* ((window (make-instance 'gtk-window
+ :window-position :center
+ :title "Class Browser"
+ :default-width 400
+ :default-height 600))
+ (search-entry (make-instance 'entry))
+ (search-button (make-instance 'button :label "Search"))
+ (scroll (make-instance 'scrolled-window
+ :hscrollbar-policy :automatic
+ :vscrollbar-policy :automatic))
+ (slots-model (make-instance 'array-list-store))
+ (slots-list (make-instance 'tree-view :model slots-model)))
+ (let ((v-box (make-instance 'v-box))
+ (search-box (make-instance 'h-box)))
+ (container-add window v-box)
+ (box-pack-start v-box search-box :expand nil)
+ (box-pack-start search-box search-entry)
+ (box-pack-start search-box search-button :expand nil)
+ (box-pack-start v-box scroll)
+ (container-add scroll slots-list))
+ (store-add-column slots-model "gchararray"
+ (lambda (slot)
+ (format nil "~S" (closer-mop:slot-definition-name slot))))
+ (let ((col (make-instance 'tree-view-column :title "Slot name"))
+ (cr (make-instance 'cell-renderer-text)))
+ (tree-view-column-pack-start col cr)
+ (tree-view-column-add-attribute col cr "text" 0)
+ (tree-view-append-column slots-list col))
+ (labels ((display-class-slots (class)
+ (format output "Displaying ~A~%" class)
+ (loop
+ repeat (store-items-count slots-model)
+ do (store-remove-item slots-model (store-item slots-model 0)))
+ (closer-mop:finalize-inheritance class)
+ (loop
+ for slot in (closer-mop:class-slots class)
+ do (store-add-item slots-model slot)))
+ (on-search-clicked (button)
+ (declare (ignore button))
+ (with-gtk-message-error-handler
+ (let* ((class-name (read-from-string (entry-text search-entry)))
+ (class (find-class class-name)))
+ (display-class-slots class)))))
+ (connect-signal search-button "clicked" #'on-search-clicked))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
+ (widget-show window)))))
(defun make-tree-from-sexp (l)
(setf l (if (listp l) l (list l)))
(tree-view-tooltip-column tree-view) 0)
(connect-signal tree-view "row-activated" (lambda (tv path column)
(declare (ignore tv column))
- (format t "You clicked on row ~A~%" (tree-path-indices path))))
+ (show-message (format nil "You clicked on row ~A" (tree-path-indices path)))))
(connect-signal button "clicked" (lambda (b)
(declare (ignore b))
(let ((object (read-from-string (entry-text entry))))
(tree-view-append-column tree-view column)
(print (tree-view-column-tree-view column))
(print (tree-view-column-cell-renderers column)))
+ (connect-signal window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show window))))
(defclass custom-window (gtk-window)
"Simple test of non-GObject subclass of GtkWindow"
(within-main-loop
(let ((w (make-instance 'custom-window)))
+ (connect-signal w "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show w))))
(defun test-assistant ()
(let ((w (make-instance 'label :label "A label in action area")))
(widget-show w)
(assistant-add-action-widget d w))
+ (connect-signal d "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(connect-signal d "cancel" (lambda (assistant)
(declare (ignore assistant))
(object-destroy d)
- (format output "Canceled~%")))
+ (show-message "Canceled")))
(connect-signal d "close" (lambda (assistant)
(declare (ignore assistant))
(object-destroy d)
- (format output "Thank you, ~A~%" (entry-text entry))))
+ (show-message (format nil "Thank you, ~A!" (entry-text entry)))))
(connect-signal d "prepare" (lambda (assistant page-widget)
(declare (ignore assistant page-widget))
(format output "Assistant ~A has ~A pages and is on ~Ath page~%"
(e (make-instance 'entry :completion completion)))
(setf (entry-completion-text-column completion) 0)
(container-add w e))
+ (connect-signal w "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show w))))
-(defun demo-all ()
- (within-main-loop
- (let* ((window (make-instance 'gtk-window
- :title "cl-gtk2-gtk demo"
- :window-position :center
- :default-width 500
- :default-height 500))
- (scrolled (make-instance 'scrolled-window
- :hscrollbar-policy :automatic
- :vscrollbar-policy :automatic))
- (viewport (make-instance 'viewport))
- (v-box-buttons (make-instance 'v-box))
- (v-box-top (make-instance 'v-box)))
- (container-add window v-box-top)
- (box-pack-start v-box-top (make-instance 'label :label "These are the demos of cl-gtk2-gtk:") :expand nil)
- (box-pack-start v-box-top scrolled)
- (container-add scrolled viewport)
- (container-add viewport v-box-buttons)
- (iter (for s in-package :gtk-demo :external-only t)
- (for fn = (fdefinition s))
- (unless fn (next-iteration))
- (when (eq s 'gtk-demo:demo-all) (next-iteration))
- (for docstring = (documentation fn t))
- (for description = (format nil "~A~@[~%~A~]" (string-downcase (symbol-name s)) docstring))
- (for label = (make-instance 'label :label description :justify :center))
- (for button = (make-instance 'button))
- (container-add button label)
- (connect-signal button "clicked"
- (let ((fn fn))
- (lambda (b)
- (declare (ignore b))
- (funcall fn))))
- (box-pack-start v-box-buttons button :expand nil))
- (widget-show window))))
-
(defun test-ui-markup ()
(within-main-loop
(let ((label (make-instance 'label :label "Hello!")))
(label :label "2 x 1") :left 0 :right 2 :top 0 :bottom 1
(label :label "1 x 1") :left 0 :right 1 :top 1 :bottom 2
(label :label "1 x 1") :left 1 :right 2 :top 1 :bottom 2)))
+ (connect-signal w "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(connect-signal btn "clicked"
(lambda (b)
(declare (ignore b))
:buttons :ok)))
(dialog-run dialog)
(object-destroy dialog)))))
+ (connect-signal w "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show w))))
(defun test-tree-store ()
:buttons :ok)))
(dialog-run dialog)
(object-destroy dialog)))))
+ (connect-signal w "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
(widget-show w))))
(defun test-gdk-expose (gdk-window)
"Test various gdk primitives"
(within-main-loop
(let ((window (make-instance 'gtk-window :type :toplevel :app-paintable t)))
- (g-signal-connect window "destroy" (lambda (widget)
- (declare (ignore widget))
- (leave-gtk-main)))
- (g-signal-connect window "destroy" (lambda (widget)
- (declare (ignore widget))
- (leave-gtk-main)))
- (g-signal-connect window "expose-event"
- (lambda (widget event)
- (declare (ignore widget event))
- (test-gdk-expose (widget-window window))))
- (g-signal-connect window "configure-event"
- (lambda (widget event)
- (declare (ignore widget event))
- (widget-queue-draw window)))
+ (connect-signal window "destroy" (lambda (widget)
+ (declare (ignore widget))
+ (leave-gtk-main)))
+ (connect-signal window "expose-event"
+ (lambda (widget event)
+ (declare (ignore widget event))
+ (test-gdk-expose (widget-window window))))
+ (connect-signal window "configure-event"
+ (lambda (widget event)
+ (declare (ignore widget event))
+ (widget-queue-draw window)))
(widget-show window)
(push :pointer-motion-mask (gdk-window-events (widget-window window))))))
--- /dev/null
+(in-package :gtk)
+
+(defcfun (drag-finish "gtk_drag_finish") :void
+ (context (g-object drag-context))
+ (success :boolean)
+ (del :boolean)
+ (time :uint32))
+
+(export 'drag-finish)
+
--- /dev/null
+(in-package :gtk)
+
+;; icon-source
+
+(at-init () (foreign-funcall "gtk_icon_source_get_type" :int))
+
+(defcfun gtk-icon-source-new :pointer)
+
+(define-g-boxed-opaque icon-source "GtkIconSource"
+ :alloc (gtk-icon-source-new))
+
+(export 'icon-source)
+
+(define-boxed-opaque-accessor icon-source icon-source-filename
+ :reader "gtk_icon_source_get_filename"
+ :writer "gtk_icon_source_set_filename"
+ :type (:string :free-from-foreign nil))
+
+(export 'icon-source-filename)
+
+(define-boxed-opaque-accessor icon-source icon-source-icon-name
+ :reader "gtk_icon_source_get_icon_name"
+ :writer "gtk_icon_source_set_icon_name"
+ :type (:string :free-from-foreign nil))
+
+(export 'icon-source-icon-name)
+
+#|
+GtkTextDirection gtk_icon_source_get_direction (const GtkIconSource *source);
+gboolean gtk_icon_source_get_direction_wildcarded
+ (const GtkIconSource *source);
+GdkPixbuf* gtk_icon_source_get_pixbuf (const GtkIconSource *source);
+GtkIconSize gtk_icon_source_get_size (const GtkIconSource *source);
+gboolean gtk_icon_source_get_size_wildcarded (const GtkIconSource *source);
+GtkStateType gtk_icon_source_get_state (const GtkIconSource *source);
+gboolean gtk_icon_source_get_state_wildcarded
+ (const GtkIconSource *source);
+
+void gtk_icon_source_set_direction (GtkIconSource *source,
+ GtkTextDirection direction);
+void gtk_icon_source_set_direction_wildcarded
+ (GtkIconSource *source,
+ gboolean setting);
+void gtk_icon_source_set_pixbuf (GtkIconSource *source,
+ GdkPixbuf *pixbuf);
+void gtk_icon_source_set_size (GtkIconSource *source,
+ GtkIconSize size);
+void gtk_icon_source_set_size_wildcarded (GtkIconSource *source,
+ gboolean setting);
+void gtk_icon_source_set_state (GtkIconSource *source,
+ GtkStateType state);
+void gtk_icon_source_set_state_wildcarded
+ (GtkIconSource *source,
+ gboolean setting);
+|#
+
+
+;; icon-set
+
+(at-init () (foreign-funcall "gtk_icon_set_get_type" :int))
+
+(defcfun gtk-icon-set-new :pointer)
+
+(define-g-boxed-opaque icon-set "GtkIconSet"
+ :alloc (gtk-icon-set-new))
+
+(export 'icon-set)
+
+(defcfun gtk-icon-set-add-source :void
+ (icon-set (g-boxed-foreign icon-set))
+ (source (g-boxed-foreign icon-source)))
+
+(defun icon-set-add-source (icon-set icon-source)
+ (gtk-icon-set-add-source icon-set icon-source))
+
+(export 'icon-set-add-source)
+
+#|
+GtkIconSet* gtk_icon_set_new_from_pixbuf (GdkPixbuf *pixbuf);
+GdkPixbuf* gtk_icon_set_render_icon (GtkIconSet *icon_set,
+ GtkStyle *style,
+ GtkTextDirection direction,
+ GtkStateType state,
+ GtkIconSize size,
+ GtkWidget *widget,
+ const char *detail);
+void gtk_icon_set_get_sizes (GtkIconSet *icon_set,
+ GtkIconSize **sizes,
+ gint *n_sizes);
+
+gboolean gtk_icon_size_lookup (GtkIconSize size,
+ gint *width,
+ gint *height);
+gboolean gtk_icon_size_lookup_for_settings (GtkSettings *settings,
+ GtkIconSize size,
+ gint *width,
+ gint *height);
+GtkIconSize gtk_icon_size_register (const gchar *name,
+ gint width,
+ gint height);
+void gtk_icon_size_register_alias (const gchar *alias,
+ GtkIconSize target);
+GtkIconSize gtk_icon_size_from_name (const gchar *name);
+const gchar* gtk_icon_size_get_name (GtkIconSize size);
+|#
+
+;; icon-factory
+
+(defcfun gtk-icon-factory-add :void
+ (factory (g-object icon-factory))
+ (stock-id :string)
+ (icon-set (g-boxed-foreign icon-set)))
+
+(defun icon-factory-add (factory stock-id icon-set)
+ (gtk-icon-factory-add factory stock-id icon-set))
+
+(export 'icon-factory-add)
+
+(defcfun gtk-icon-factory-add-default :void
+ (factory (g-object icon-factory)))
+
+(defun icon-factory-add-default (factory)
+ (gtk-icon-factory-add-default factory))
+
+(export 'icon-factory-add-default)
+
+(defcfun gtk-icon-factory-lookup (g-boxed-foreign icon-set :return)
+ (factory (g-object icon-factory))
+ (stock-id :string))
+
+(defun icon-factory-lookup (factory stock-id)
+ (gtk-icon-factory-lookup factory stock-id))
+
+(export 'icon-factory-lookup)
+
+(defcfun gtk-icon-factory-lookup-default (g-boxed-foreign icon-set :return)
+ (stock-id :string))
+
+(defun icon-factory-lookup-default (stock-id)
+ (gtk-icon-factory-lookup-default stock-id))
+
+(export 'icon-factory-lookup-default)
+
+(defcfun gtk-icon-factory-remove-default :void
+ (factory (g-object icon-factory)))
+
+(defun icon-factory-remove-default (factory)
+ (gtk-icon-factory-remove-default factory))
+
(at-init () (gtk-init))
-(defcfun gtk-main :void)
+(defcfun (%gtk-main "gtk_main") :void)
-#+thread-support
-(defvar *main-thread* nil)
-
-#+thread-support
-(at-finalize ()
- (when (and *main-thread* (bt:thread-alive-p *main-thread*))
- (bt:destroy-thread *main-thread*)
- (setf *main-thread* nil)))
-
-#+thread-support
-(defun ensure-gtk-main ()
- (when (and *main-thread* (not (bt:thread-alive-p *main-thread*)))
- (setf *main-thread* nil))
- (unless *main-thread*
- (setf *main-thread* (bt:make-thread (lambda () (gtk-main)) :name "cl-gtk2 main thread"))))
-
-#+thread-support
-(defun join-main-thread ()
- (when *main-thread*
- (bt:join-thread *main-thread*)))
+(defun gtk-main ()
+ (with-gdk-threads-lock (%gtk-main)))
#+thread-support
-(export 'join-main-thread)
+(progn
+ (defvar *main-thread* nil)
+ (defvar *main-thread-level* nil)
+ (defvar *main-thread-lock* (bt:make-lock "*main-thread* lock"))
+
+ (at-finalize ()
+ (when (and *main-thread* (bt:thread-alive-p *main-thread*))
+ (bt:destroy-thread *main-thread*)
+ (setf *main-thread* nil)))
+
+ (defun ensure-gtk-main ()
+ (bt:with-lock-held (*main-thread-lock*)
+ (when (and *main-thread* (not (bt:thread-alive-p *main-thread*)))
+ (setf *main-thread* nil))
+ (unless *main-thread*
+ (setf *main-thread* (bt:make-thread (lambda () (gtk-main)) :name "cl-gtk2 main thread")
+ *main-thread-level* 0))
+ (incf *main-thread-level*))
+ (values))
+
+ (defun join-gtk-main ()
+ (when *main-thread*
+ (bt:join-thread *main-thread*)))
+
+ (defun leave-gtk-main ()
+ (bt:with-lock-held (*main-thread-lock*)
+ (decf *main-thread-level*)
+ (when (zerop *main-thread-level*)
+ (gtk-main-quit)))))
#-thread-support
-(defun ensure-gtk-main ()
- (gtk-main))
+(progn
+ (defun ensure-gtk-main ()
+ (gtk-main)
+ (values))
-(export 'ensure-gtk-main)
-
-#+thread-support
-(defun leave-gtk-main ()) ;noop on multithreading
+ (defun leave-gtk-main ()
+ (gtk-main-quit))
+
+ (defun join-gtk-main ()))
-#-thread-support
-(defun leave-gtk-main ()
- (gtk-main-quit))
+(export 'ensure-gtk-main)
(export 'leave-gtk-main)
+(export 'join-gtk-main)
+
(defcfun gtk-main-level :uint)
(defcfun gtk-main-quit :void)
(in-package :gtk)
-(at-init ()
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (define-foreign-library gtk
- (:unix (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so"))
- (:windows (:or "libgtk-2.0-0.dll" "libgtk-win32-2.0-0.dll"))
- (t "libgtk-2.0")))
-
- (use-foreign-library gtk))
-
#+sbcl (when (and (find-package "SB-EXT")
(find-symbol "SET-FLOATING-POINT-MODES" (find-package "SB-EXT")))
- (funcall (find-symbol "SET-FLOATING-POINT-MODES" (find-package "SB-EXT")) :traps nil))
\ No newline at end of file
+ (funcall (find-symbol "SET-FLOATING-POINT-MODES" (find-package "SB-EXT")) :traps nil))
--- /dev/null
+(in-package :gtk)
+
+(define-g-boxed-cstruct target-entry "GtkTargetEntry"
+ (target :string :initform 0)
+ (flags target-flags :initform 0)
+ (info :uint :initform 0))
+
+(export (boxed-related-symbols 'target-entry))
+
--- /dev/null
+(in-package :gtk)
+
+(defcallback gtk-tree-model-filter-visible-func-callback :boolean
+ ((tree-model g-object) (iter (g-boxed-foreign tree-iter)) (data :pointer))
+ (let ((fn (get-stable-pointer-value data)))
+ (restart-case
+ (funcall fn tree-model iter)
+ (return-true () t)
+ (return-false () nil))))
+
+(defcfun gtk-tree-model-filter-set-visible-func :void
+ (filter (g-object tree-model-filter))
+ (func :pointer)
+ (data :pointer)
+ (destroy-notify :pointer))
+
+(defun tree-model-filter-set-visible-function (tree-model-filter function)
+ (gtk-tree-model-filter-set-visible-func
+ tree-model-filter
+ (callback gtk-tree-model-filter-visible-func-callback)
+ (allocate-stable-pointer function)
+ (callback stable-pointer-free-destroy-notify-callback)))
+
+(export 'tree-model-filter-set-visible-function)
+
+#|
+
+typedef void (* GtkTreeModelFilterModifyFunc) (GtkTreeModel *model,
+ GtkTreeIter *iter,
+ GValue *value,
+ gint column,
+ gpointer data);
+
+void gtk_tree_model_filter_set_modify_func (GtkTreeModelFilter *filter,
+ gint n_columns,
+ GType *types,
+ GtkTreeModelFilterModifyFunc func,
+ gpointer data,
+ GDestroyNotify destroy);
+
+void gtk_tree_model_filter_set_visible_column (GtkTreeModelFilter *filter,
+ gint column);
+
+/* conversion */
+gboolean gtk_tree_model_filter_convert_child_iter_to_iter (GtkTreeModelFilter *filter,
+ GtkTreeIter *filter_iter,
+ GtkTreeIter *child_iter);
+|#
+
+(defcfun gtk-tree-model-filter-convert-iter-to-child-iter :void
+ (filter (g-object tree-model-filter))
+ (child-iter (g-boxed-foreign tree-iter))
+ (filter-iter (g-boxed-foreign tree-iter)))
+
+(defun tree-model-filter-convert-iter-to-child-iter (filter iter)
+ (let ((child-iter (make-instance 'tree-iter)))
+ (gtk-tree-model-filter-convert-iter-to-child-iter filter child-iter iter)
+ child-iter))
+
+(export 'tree-model-filter-convert-iter-to-child-iter)
+
+#|
+GtkTreePath *gtk_tree_model_filter_convert_child_path_to_path (GtkTreeModelFilter *filter,
+ GtkTreePath *child_path);
+
+GtkTreePath *gtk_tree_model_filter_convert_path_to_child_path (GtkTreeModelFilter *filter,
+ GtkTreePath *filter_path);
+|#
+
+;; extras
+
+(defcfun gtk-tree-model-filter-refilter :void
+ (filter (g-object tree-model-filter)))
+
+(defun tree-model-filter-refilter (filter)
+ (gtk-tree-model-filter-refilter filter))
+
+(export 'tree-model-filter-refilter)
+
+(defcfun gtk-tree-model-filter-clear-cache :void
+ (filter (g-object tree-model-filter)))
+
+(defun tree-model-filter-clear-cache (filter)
+ (gtk-tree-model-filter-clear-cache filter))
+
+(export 'tree-model-filter-clear-cache)
(export 'tree-view-convert-widget-to-tree-coords)
-; TODO: gtk_tree_view_enable_model_drag_dest
+(defcfun gtk-tree-view-enable-model-drag-dest :void
+ (tree-view (g-object tree-view))
+ (targets :pointer)
+ (n-targets :int)
+ (actions gdk-drag-action))
-; TODO: gtk_tree_view_enable_model_drag_source
+(defun tree-view-enable-model-drag-dest (tree-view targets actions)
+ (with-foreign-boxed-array (n-targets targets-ptr target-entry targets)
+ (gtk-tree-view-enable-model-drag-dest tree-view targets-ptr n-targets actions)))
+
+(export 'tree-view-enable-model-drag-dest)
+
+(defcfun gtk-tree-view-enable-model-drag-source :void
+ (tree-view (g-object tree-view))
+ (start-button-mask modifier-type)
+ (targets :pointer)
+ (n-targets :int)
+ (actions gdk-drag-action))
+
+(defun tree-view-enable-model-drag-source (tree-view start-button-mask targets actions)
+ (with-foreign-boxed-array (n-targets targets-ptr target-entry targets)
+ (gtk-tree-view-enable-model-drag-source tree-view start-button-mask targets-ptr n-targets actions)))
+
+(export 'tree-view-enable-model-drag-source)
; TODO: gtk_tree_view_unset_rows_drag_source
; TOOD: gtk_tree_view_get_drag_dest_row
-; TOOD: gtk_tree_view_get_dest_row_at_pos
+(defcfun gtk-tree-view-get-dest-row-at-pos :boolean
+ (tree_view (g-object tree-view))
+ (drag-x :int)
+ (drag-y :int)
+ (path :pointer)
+ (pos :pointer))
+
+(defun tree-view-get-dest-row-at-pos (tree-view x y)
+ (with-foreign-objects ((path :pointer) (pos :int))
+ (when (gtk-tree-view-get-dest-row-at-pos tree-view x y path pos)
+ (values (mem-ref path '(g-boxed-foreign tree-path :return))
+ (mem-ref pos 'tree-view-drop-position)))))
+
+(export 'tree-view-get-dest-row-at-pos)
; TOOD: gtk_tree_view_create_drag_icon
; TODO: GtkWidget
+(define-g-boxed-cstruct selection-data "GtkSelectionData"
+ (selection gdk-atom-as-string :initform nil)
+ (target gdk-atom-as-string :initform nil)
+ (type gdk-atom-as-string :initform nil)
+ (format :int :initform 0)
+ (data :pointer :initform (null-pointer))
+ (length :int :initform 0)
+ (display (g-object display) :initform nil))
+
+(export (boxed-related-symbols 'selection-data))
+
(defun widget-flags (widget)
(convert-from-foreign (gtk-object-flags-as-integer widget) 'widget-flags))
(defcstruct %gtk-widget
(:object %gtk-object)
(:private-flags :uint16)
- (:state state-type)
- (:saved-state state-type)
+ (:state :uint8)
+ (:saved-state :uint8)
(:name (:pointer :char))
(:style :pointer)
(:requisition requisition-cstruct)
(:parent :pointer))
(defun widget-state (widget)
- (foreign-slot-value (pointer widget) '%gtk-widget :state))
+ (convert-from-foreign (foreign-slot-value (pointer widget) '%gtk-widget :state) 'state-type))
(export 'widget-state)
(defun widget-saved-state (widget)
- (foreign-slot-value (pointer widget) '%gtk-widget :saved-state))
+ (convert-from-foreign (foreign-slot-value (pointer widget) '%gtk-widget :saved-state) 'state-type))
(export 'widget-saved-state)
(defun widget-snapshot (widget &optional clip-rectangle)
(gtk-widget-get-snapshot widget clip-rectangle))
-(export 'widget-snapshot)
\ No newline at end of file
+(export 'widget-snapshot)
(def-ui-child-packer box (b d child)
(let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
(fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name))
- (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name)))
- `(box-pack-start ,b ,child
- ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
- ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
- ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))))
+ (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name))
+ (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name)))
+ `(progn
+ (box-pack-start ,b ,child
+ ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
+ ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
+ ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))
+ ,@(when pack-type-prop
+ (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop)))))))
(def-ui-child-packer paned (p d child)
(let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
(defsystem :cl-gtk2-pango
:name :cl-gtk2-pango
- :version "0.1"
+ :version "0.1.1"
:author "Kalyanov Dmitry <Kalyanov.Dmitry@gmail.com>"
:license "LLGPL"
:serial t
projects / cl-gtk2.git / commitdiff