(:bilevel 0)
(:full 1))
+(define-g-enum "GdkInterpType"
+ gdk-interp-type
+ (:export t :type-initializer "gdk_interp_type_get_type")
+ (:nearest 0)
+ (:tiles 1)
+ (:bilinear 2)
+ (:hyper 3))
+
+(define-g-enum "GdkPixbufRotation"
+ gdk-pixbuf-rotation
+ (:export t :type-initializer "gdk_pixbuf_rotation_get_type")
+ (:none 0)
+ (:counterclockwise 90)
+ (:upsidedown 180)
+ (:clockwise 270))
+
(define-g-enum "GdkColorspace" colorspace ()
:rgb)
((:cffi visual colormap-visual (g-object visual)
"gdk_colormap_get_visual" nil)
(:cffi screen colormap-screen (g-object screen)
- "gdk_colormap_get_screeen" nil)))
+ "gdk_colormap_get_screen" nil)))
(define-g-object-class "GdkScreen" screen (:type-initializer "gdk_screen_get_type")
((font-options screen-font-options "font-options" "gpointer" t t)
(gdk-pixbuf-get-from-image pixbuf image (null-pointer) src-x src-y dest-x dest-y width height))
(export 'pixbuf-get-from-image)
+
+(defcfun gdk-pixbuf-scale-simple (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (dest-width :int)
+ (dest-height :int)
+ (interp-type gdk-interp-type))
+
+(defun pixbuf-scale-simple (pixbuf dest-width dest-height &key (interp-type :bilinear))
+ (gdk-pixbuf-scale-simple pixbuf dest-width dest-height interp-type))
+
+(export 'pixbuf-scale-simple)
+
+(defcfun (pixbuf-scale "gdk_pixbuf_scale") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type))
+
+(export 'pixbuf-scale)
+
+(defcfun (pixbuf-composite-color-simple "gdk_pixbuf_composite_color_simple") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (dest-width :int)
+ (dest-height :int)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int)
+ (check-size :int)
+ (color-1 :uint32)
+ (color-2 :uint32))
+
+(export 'pixbuf-composite-color-simple)
+
+(defcfun (pixbuf-composite "gdk_pixbuf_composite") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int))
+
+(export 'pixbuf-composite)
+
+(defcfun (pixbuf-composite-color "gdk_pixbuf_composite_color") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int)
+ (check-x :int)
+ (check-y :int)
+ (check-size :int)
+ (color-1 :uint32)
+ (color-2 :uint32))
+
+(export 'pixbuf-composite-color)
+
+(defcfun (pixbuf-rotate-simple "gdk_pixbuf_rotate_simple") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (angle gdk-pixbuf-rotation))
+
+(export 'pixbuf-rotate-simple)
+
+(defcfun (pixbuf-flip "gdk_pixbuf_flip") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (horizontal :boolean))
+
+(export 'pixbuf-flip)
nil "gtk_menu_tool_button_set_arrow_tooltip_text")
(:cffi gtk::arrow-tooltip-markup gtk::menu-tool-button-arrow-tooltip-markup :string
nil "gtk_menu_tool_button_set_arrow_tooltip_markup"))
+ ("GtkRadioButton"
+ (:cffi gtk::group gtk::radio-button-group (gslist gtk::radio-button :free-from-foreign nil :free-to-foreign nil)
+ nil "gtk_radio_button_set_group"))
("GtkUIManager"
(:cffi gtk::accel-group gtk::ui-manager-accel-group g-object
"gtk_ui_manager_get_accel_group" nil))
(:file "glib.quark")
(:file "glib.gerror")
(:file "glib.utils")
+ (:file "glib.rand")
(:file "gobject.init")
(:file "gobject.ffi.package")
(data :pointer)
(next :pointer))
+(defcfun g-slist-alloc (:pointer g-slist))
+
(defcfun g-slist-free :void (list (:pointer g-slist)))
(defun g-slist-next (list)
(until (null-pointer-p c))
(collect (convert-from-foreign (foreign-slot-value c 'g-slist 'data) (gslist-type-type type))))
(when (gslist-type-free-from-foreign type)
- (g-slist-free pointer))))
\ No newline at end of file
+ (g-slist-free pointer))))
+
+(defmethod translate-to-foreign (list (type gslist-type))
+ (let ((result (null-pointer)) last)
+ (iter (for item in list)
+ (for n = (g-slist-alloc))
+ (for ptr = (convert-to-foreign item (gslist-type-type type)))
+ (setf (foreign-slot-value n 'g-slist 'data) ptr)
+ (setf (foreign-slot-value n 'g-slist 'next) (null-pointer))
+ (when last
+ (setf (foreign-slot-value last 'g-slist 'next) n))
+ (setf last n)
+ (when (first-iteration-p)
+ (setf result n)))
+ result))
+
--- /dev/null
+(in-package :glib)
+
+(defcfun (random-set-seed "g_random_set_seed") :void
+ (seed :uint32))
+
+(export 'random-set-seed)
+
+(defcfun (random-int "g_random_int") :uint32)
+
+(export 'random-int)
+
+(defcfun (random-int-range "g_random_int_range") :int32
+ (begin :int32)
+ (end :int32))
+
+(export 'random-int-range)
+
+(defun random-boolean ()
+ (logtest (random-int) #X8000))
+
+(export 'random-boolean)
+
+(defcfun (random-double "g_random_double") :double)
+
+(export 'random-double)
+
+(defcfun (random-double-range "g_random_double_range") :double
+ (begin :double)
+ (end :double))
+
+(export 'random-double-range)
+
(:file "gtk.functions")
(:file "gtk.base-classes")
(:file "gtk.dialog")
+ (:file "gtk.about-dialog")
(:file "gtk.window")
(:file "gtk.window-group")
(:file "gtk.icon-factory")
--- /dev/null
+(in-package :gtk)
+
+(defvar *about-dialog-url-func* nil)
+
+(defcallback about-dialog-url-func-cb :void
+ ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+ (declare (ignore user-data))
+ (funcall *about-dialog-url-func* dialog link))
+
+(defcallback about-dialog-url-func-destroy-cb :void
+ ((data :pointer))
+ (declare (ignore data))
+ (setf *about-dialog-url-func* nil))
+
+(defcfun gtk-about-dialog-set-url-hook :void
+ (func :pointer)
+ (data :pointer)
+ (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-url-hook) (new-value)
+ (if new-value
+ (gtk-about-dialog-set-url-hook (callback about-dialog-url-func-cb)
+ (null-pointer)
+ (callback about-dialog-url-func-destroy-cb))
+ (gtk-about-dialog-set-url-hook (null-pointer)
+ (null-pointer)
+ (null-pointer)))
+ (setf *about-dialog-url-func* new-value))
+
+(export 'about-dialog-global-url-hook)
+
+(defvar *about-dialog-email-func* nil)
+
+(defcallback about-dialog-email-func-cb :void
+ ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+ (declare (ignore user-data))
+ (funcall *about-dialog-email-func* dialog link))
+
+(defcallback about-dialog-email-func-destroy-cb :void
+ ((data :pointer))
+ (declare (ignore data))
+ (setf *about-dialog-email-func* nil))
+
+(defcfun gtk-about-dialog-set-email-hook :void
+ (func :pointer)
+ (data :pointer)
+ (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-email-hook) (new-value)
+ (if new-value
+ (gtk-about-dialog-set-email-hook (callback about-dialog-email-func-cb)
+ (null-pointer)
+ (callback about-dialog-email-func-destroy-cb))
+ (gtk-about-dialog-set-email-hook (null-pointer)
+ (null-pointer)
+ (null-pointer)))
+ (setf *about-dialog-email-func* new-value))
+
+(export 'about-dialog-global-email-hook)
+
(:superclass check-button :export t :interfaces
("AtkImplementorIface" "GtkActivatable" "GtkBuildable")
:type-initializer "gtk_radio_button_get_type")
- ((group radio-button-group "group" "GtkRadioButton" nil
- t)))
+ ((:cffi group radio-button-group
+ (gslist g-object :free-from-foreign nil
+ :free-to-foreign nil)
+ "gtk_radio_button_get_group" "gtk_radio_button_set_group")))
(define-g-object-class "GtkComboBox" combo-box
(:superclass bin :export t :interfaces
(gethash id (tree-lisp-store-id-map tree)))
(defmethod tree-model-get-iter-impl ((store tree-lisp-store) iter path)
- (let* ((node (get-node-by-path store path))
- (node-idx (get-assigned-id store node)))
- (setf (tree-iter-stamp iter) 0
- (tree-iter-user-data iter) node-idx)))
+ (ignore-errors
+ (let* ((node (get-node-by-path store path))
+ (node-idx (get-assigned-id store node)))
+ (setf (tree-iter-stamp iter) 0
+ (tree-iter-user-data iter) node-idx))))
(defun get-node-by-iter (tree iter)
(get-node-by-id tree (tree-iter-user-data iter)))
(free-stable-pointer data))
(defcfun gtk-tree-view-column-set-cell-data-func :void
- (tree-column (g-object tree-column))
+ (tree-column (g-object tree-view-column))
(cell-renderer (g-object cell-renderer))
(func :pointer)
(func-data :pointer)
(allocate-stable-pointer function)
(callback gtk-tree-cell-data-func-destroy-cb)))
+(export 'tree-view-column-set-cell-data-function)
+
(defcfun (tree-view-column-clear-attributes "gtk_tree_view_column_clear_attributes") :void
(tree-column (g-object tree-column))
(cell-renderer (g-object cell-renderer)))
(unless (eq (ui-prop-name prop) :var)
(appending (list (ui-prop-name prop) (ui-prop-value prop)))))))
-(defvar *ui-child-packers* (make-hash-table))
-
-(defmacro def-ui-child-packer (class (var child-def child) &body body)
- `(setf (gethash ',class *ui-child-packers*)
- (lambda (,var ,child-def ,child) ,@body)))
-
-(def-ui-child-packer container (w d child)
- (declare (ignore d))
- `(container-add ,w ,child))
-
-(defun get-ui-child-prop-value (d name required-p context)
- (let ((prop (find name (ui-child-props d) :key #'ui-prop-name)))
- (if (and required-p (null prop))
- (error "~A is a mandatory child property for ~A" name context)
- (when prop (ui-prop-value prop)))))
-
-(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))
- (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))
- (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name)))
- `(if (null (paned-child-1 ,p))
- (paned-pack-1 ,p ,child
- ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
- ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))
- (paned-pack-2 ,p ,child
- ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
- ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))))))
-
-(def-ui-child-packer table (table d child)
- `(table-attach ,table ,child
- ,(get-ui-child-prop-value d :left t "table packing")
- ,(get-ui-child-prop-value d :right t "table packing")
- ,(get-ui-child-prop-value d :top t "table packing")
- ,(get-ui-child-prop-value d :bottom t "table packing")
- ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil)))
- (when x-options
- (list :x-options x-options)))
- ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
- (when y-options
- (list :y-options y-options)))
- ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
- (when x-padding
- (list :x-padding x-padding)))
- ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
- (when y-padding
- (list :y-padding y-padding)))))
-
-(defun get-child-packer-fn (d)
- (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
- (while class)
- (for packer = (gethash (class-name class) *ui-child-packers*))
- (when packer (return packer))))
-
-(defun get-child-packer (d var)
- (let ((fn (get-child-packer-fn d)))
- (when fn
- (let ((forms (iter (for child in (ui-d-children d))
- (for child-var = (ui-d-var (ui-child-v child)))
- (collect (funcall fn var child child-var)))))
- (when forms (cons 'progn forms))))))
-
-(defun get-ui-d-initializer (d var)
- (get-child-packer d var))
+(defgeneric pack-child (container child &key))
+
+(defmethod pack-child ((w container) child &key)
+ (container-add w child))
+
+(defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position)
+ (box-pack-start b child
+ :expand expand
+ :fill fill
+ :padding padding)
+ (when pack-type
+ (setf (box-child-pack-type b child) pack-type))
+ (when position
+ (setf (box-child-position b child) position)))
+
+(defmethod pack-child ((p paned) child &key (resize 'default) (shrink t))
+ (if (null (paned-child-1 p))
+ (paned-pack-1 p child
+ :resize (if (eq resize 'default) nil resize)
+ :shrink shrink)
+ (paned-pack-2 p child
+ :resize (if (eq resize 'default) t resize)
+ :shrink shrink)))
+
+(defmethod pack-child ((table table) child &key
+ left right top bottom
+ (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0))
+
+ (unless left
+ (error "left is a mandatory child property for table packing"))
+ (unless right
+ (error "right is a mandatory child property for table packing"))
+ (unless top
+ (error "top is a mandatory child property for table packing"))
+ (unless bottom
+ (error "bottom is a mandatory child property for table packing"))
+
+ (table-attach table child
+ :left left
+ :right right
+ :top top
+ :bottom bottom
+ :x-options x-options
+ :y-options y-options
+ :x-padding x-padding
+ :y-padding y-padding))
+
+(defmethod pack-child ((w tree-view) child &key)
+ (tree-view-append-column w child))
+
+(defmethod pack-child ((w tree-view-column) child &key (expand t) attributes)
+ (tree-view-column-pack-start w child :expand expand)
+ (iter (for a on attributes by #'cddr)
+ (tree-view-column-add-attribute w child
+ (first a)
+ (second a))))
+
+(defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default))
+ (toolbar-insert b child -1)
+ (unless (eq expand 'default)
+ (container-call-set-property b child "expand" expand +g-type-boolean+))
+ (unless (eq homogeneous 'default)
+ (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+)))
(defun set-ui-expansion-1 (d)
(when (ui-d-class d)
;; only direct-vars do not have class
(setf (ui-d-var d) (get-ui-d-var d)
- (ui-d-initform d) (get-ui-d-initform d))
- (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
+ (ui-d-initform d) (get-ui-d-initform d))))
(defun set-ui-expansion (description)
(iter (for child in (ui-d-children description))
(let* ((description (parse-ui-description ui-description))
(items (flattened-ui-descriptions description)))
(set-ui-expansion description)
- `(let (,@(iter (for i in items)
- (collect (list (ui-d-var i)
- (ui-d-initform i)))))
- ,@(iter (for i in items)
- (when (ui-d-initializer i)
- (collect (ui-d-initializer i))))
+ `(let (,@(iter (for item in items)
+ (collect (list (ui-d-var item)
+ (ui-d-initform item)))))
+ ,@(iter (for item in items)
+ (appending (iter (for child in (ui-d-children item))
+ (for child-var = (ui-d-var (ui-child-v child)))
+ (let ((props
+ (iter (for p in (ui-child-props child))
+ (appending (list (ui-prop-name p) (ui-prop-value p))))))
+ (collect (list* 'pack-child (ui-d-var item) child-var props))))))
+
,@body)))
+
projects / cl-gtk2.git / commitdiff