Dear Peter,
hi List,
thank you for you recent suggestion to use g_timeout_add in order
to escape the linearity of cellular time.
Attached is my current, annotated patch queue for cells-gtk3.
Everything is also available via git at:
http://public.efil.de/gitweb/?p=cells-gtk.git
$ git clone http://public.efil.de/git/cells-gtk.git
For some reason several functions from fm-utilities.lisp (for example
#'container and #'upper) stopped working. When I roll back CELLS to
the last revision of May, 21. everything works as expected.
Either I'm doing something stupid or there exists a problem in cells.
Anybody working with newest CVS? I didn't read anything on cells-devel.
Note:
Patch #4 replaces all occurrences off #'upper with #'fm-parent or
#'fm-parent-typed which still work fine. You might well want to skip that one.
/Ingo
--
Ingo Bormuth, voicebox & telefax: +49-(0)-12125-10226517
PGP public key 86326EC9 at http://ibormuth.efil.de/contact
_______________________________________________________________________
EINE FÜR ALLE: die kostenlose WEB.DE-Plattform für Freunde und Deine
Homepage mit eigenem Namen. Jetzt starten! http://unddu.de/[EMAIL PROTECTED]
>From 4188a535392e1455f03e4b415475fd437a9be089 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Sun, 22 Jun 2008 19:57:24 +0200
Subject: [PATCH] Fix: gtk-container-add should return :void
---
gtk-ffi/gtk-other.lisp | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/gtk-ffi/gtk-other.lisp b/gtk-ffi/gtk-other.lisp
index 57c6f0a..5e274e4 100644
--- a/gtk-ffi/gtk-other.lisp
+++ b/gtk-ffi/gtk-other.lisp
@@ -51,7 +51,7 @@
(xpad :float)
(ypad :float)))
;;container
- (gtk-container-add :pointer
+ (gtk-container-add :void
((container :pointer)
(widget :pointer)))
(gtk-container-remove :void
--
1.5.5.4
>From f3986b92519ca9fd1044efed5e4a4f0713f49473 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 05:03:12 +0200
Subject: [PATCH] Add columns-autosize. And minor typo.
---
gtk-ffi/gtk-list-tree.lisp | 4 +++-
1 files changed, 3 insertions(+), 1 deletions(-)
diff --git a/gtk-ffi/gtk-list-tree.lisp b/gtk-ffi/gtk-list-tree.lisp
index 73fd76c..703cfbf 100644
--- a/gtk-ffi/gtk-list-tree.lisp
+++ b/gtk-ffi/gtk-list-tree.lisp
@@ -37,7 +37,7 @@
(iter :pointer)))
(gtk-list-store-clear :void
((list-store :pointer)))
- ;;tre-store
+ ;;tree-store
(gtk-tree-store-newv :pointer
((n-columns :int)
(col-types :pointer)))
@@ -170,6 +170,8 @@
(gtk-tree-view-column-set-visible :void
((tree-column :pointer)
(spacing gtk-boolean)))
+ (gtk-tree-view-column-columns-autosize :void
+ ((tree-column :pointer)))
(gtk-tree-view-column-set-reorderable :void
((tree-column :pointer)
(resizable gtk-boolean)))
--
1.5.5.4
>From 0ac9aa8b4370ebc47f3694bf0157bf3a9316b9f0 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 07:19:53 +0200
Subject: [PATCH] Replace cells:upper by cells:fm-parent and cells:fm-ascendant-typed.
Seems there is a bug in cells (or I'm doing something stupid).
---
cells-gtk/buttons.lisp | 10 +++++-----
cells-gtk/cairo-drawing-area.lisp | 10 +++++-----
cells-gtk/menus.lisp | 10 +++++-----
cells-gtk/test-gtk/test-buttons.lisp | 12 ++++++------
cells-gtk/test-gtk/test-drawing.lisp | 4 ++--
cells-gtk/test-gtk/test-textview.lisp | 2 +-
cells-gtk/test-gtk/test-tree-view.lisp | 10 +++++-----
cells-gtk/tree-view.lisp | 8 ++++----
8 files changed, 33 insertions(+), 33 deletions(-)
diff --git a/cells-gtk/buttons.lisp b/cells-gtk/buttons.lisp
index ea1ae28..5174c69 100644
--- a/cells-gtk/buttons.lisp
+++ b/cells-gtk/buttons.lisp
@@ -79,12 +79,12 @@
(def-widget radio-button (check-button)
() () ()
- :new-tail (c_1 (and (upper self box)
+ :new-tail (c_1 (and (fm-ascendant-typed self 'box)
(not (eql (first (kids (fm-parent self))) self))
'-from-widget))
- :new-args (c_1 (assert (upper self box))
- (and (upper self box)
+ :new-args (c_1 (assert (fm-ascendant-typed self 'box))
+ (and (fm-ascendant-typed self 'box)
(list
(if (eql (first (kids .parent)) self)
+c-null+
@@ -95,6 +95,6 @@
(setf (value self) state)))))
(defobserver .value ((self radio-button))
- (when (and new-value (upper self box))
+ (when (and new-value (fm-ascendant-typed self 'box))
(with-integrity (:change 'radio-up-to-box)
- (setf (value (upper self box)) (md-name self)))))
+ (setf (value (fm-ascendant-typed self 'box)) (md-name self)))))
diff --git a/cells-gtk/cairo-drawing-area.lisp b/cells-gtk/cairo-drawing-area.lisp
index 0aece0b..cf7fd0e 100644
--- a/cells-gtk/cairo-drawing-area.lisp
+++ b/cells-gtk/cairo-drawing-area.lisp
@@ -55,7 +55,7 @@ neesds to be wrapped in parens."
collecting `(,slot-name :initform (c? ,initform)
:reader ,slot-name)))
(from-upper-slots (loop for slot-name in from-upper
- collecting `(,slot-name :initform (c? (,slot-name (upper self)))
+ collecting `(,slot-name :initform (c? (,slot-name (fm-parent self)))
:reader ,slot-name))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defmodel ,name (,@superclasses)
@@ -363,14 +363,14 @@ anchor-point."))
( :readers ((selected-p (when-bind (w (^widget)) (true (member self (selection w))))))
:no-redraw
(draggable dragged-p mouse-over-p selectable selected-p)
- :default-initargs (:widget (c? (bwhen (parent (upper self)) (widget parent))))))
+ :default-initargs (:widget (c? (bwhen (parent (fm-parent self)) (widget parent))))))
(defmodify primitive (draggable)
(deb "modify primitive ~a with ~a" self property-list))
(defmethod remove-primitive ((primitive primitive))
- (when (upper primitive)
- (setf (kids (upper primitive)) (remove primitive (kids (upper primitive)))))
+ (when (fm-parent primitive)
+ (setf (kids (fm-parent primitive)) (remove primitive (kids (fm-parent primitive)))))
(bwhen (widget (widget primitive))
(with-accessors ((.canvas .canvas)) widget
(when (member primitive .canvas)
@@ -630,7 +630,7 @@ anchor-point."))
(defprimitive arrow-head (path)
((closed t)
(filled t))
- (:readers ((points (let ((u (upper self))) (list (p2 u) (fin-1 u) (fin-2 u)))))
+ (:readers ((points (let ((u (fm-parent self))) (list (p2 u) (fin-1 u) (fin-2 u)))))
:from-upper (rgb alpha fill-rgb fill-alpha widget)))
(defprimitive arrow-line (line)
diff --git a/cells-gtk/menus.lisp b/cells-gtk/menus.lisp
index bcfabf1..19f2348 100644
--- a/cells-gtk/menus.lisp
+++ b/cells-gtk/menus.lisp
@@ -249,7 +249,7 @@
(defobserver accel ((self menu-item))
(when new-value
- (bwhen (win (upper self window))
+ (bwhen (win (fm-ascendant-typed self'window))
(multiple-value-bind (key mods) (accel-key-mods new-value)
(gtk-widget-add-accelerator (id self) "activate" (accel-group win) key mods 1)))))
@@ -279,12 +279,12 @@
(def-widget radio-menu-item (check-menu-item)
() () ()
- :new-tail (c? (let ((in-group-p (upper self menu-item))
+ :new-tail (c? (let ((in-group-p (fm-ascendant-typed self'menu-item))
(not-first-p (not (eql (first (kids (fm-parent self))) self))))
(when (and in-group-p not-first-p)
'-from-widget)))
- :new-args (c_1 (let ((in-group-p (upper self menu-item))
+ :new-args (c_1 (let ((in-group-p (fm-ascendant-typed self'menu-item))
(not-first-p (not (eql (first (kids (fm-parent self))) self))))
(if (and in-group-p not-first-p)
(list (id (first (kids (fm-parent self)))))
@@ -292,8 +292,8 @@
(defobserver .value ((self radio-menu-item))
(with-integrity (:change 'radio-menu-item-value)
- (when (and new-value (upper self menu-item))
- (setf (value (upper self menu-item)) (md-name self)))))
+ (when (and new-value (fm-ascendant-typed self'menu-item))
+ (setf (value (fm-ascendant-typed self'menu-item)) (md-name self)))))
(def-widget image-menu-item (menu-item)
((stock :accessor stock :initarg :stock :initform nil)
diff --git a/cells-gtk/test-gtk/test-buttons.lisp b/cells-gtk/test-gtk/test-buttons.lisp
index f832fa5..7bc9f62 100644
--- a/cells-gtk/test-gtk/test-buttons.lisp
+++ b/cells-gtk/test-gtk/test-buttons.lisp
@@ -3,7 +3,7 @@
(defmodel test-buttons (vbox)
((nclics :accessor nclics :initform (c-in 0)))
(:default-initargs
- :kids (c? (the-kids
+ :kids (kids-list?
(mk-label :text (c? (trc "### executing toggled button rule")
(format nil "Toggled button active = ~a"
(with-widget (w :toggled-button)
@@ -20,16 +20,16 @@
(value w)))))
(mk-hseparator)
(mk-label :text (c? (format nil "Button clicked ~a times"
- (nclics (upper self test-buttons))))
+ (nclics (fm-ascendant-typed self 'test-buttons))))
:selectable t)
(mk-hseparator)
(mk-hbox
- :kids (c? (the-kids
+ :kids (kids-list?
(mk-button :stock :apply
:tooltip "Click ....."
:on-clicked (callback (widget event data)
- (incf (nclics (upper self test-buttons)))))
+ (incf (nclics (fm-ascendant-typed self 'test-buttons)))))
(mk-button :label "Continuable error"
:on-clicked (callback (widget event data)
(trc "issuing continuable error" widget event)
@@ -42,7 +42,7 @@
"_Toggled Button")))
(mk-check-button :md-name :check-button
:markup (with-markup (:foreground :green)
- "_Check Button")))))
+ "_Check Button"))))
(mk-hbox
:md-name :radio-group
:kids (kids-list?
@@ -58,4 +58,4 @@
(format nil "Toggled button active = ~a"
(with-widget (w :toggled-button)
(trc " FOUND WIDGET 2" w (value w))
- (value w)))))))))))
+ (value w))))))))))
diff --git a/cells-gtk/test-gtk/test-drawing.lisp b/cells-gtk/test-gtk/test-drawing.lisp
index ef62316..7dbbef2 100644
--- a/cells-gtk/test-gtk/test-drawing.lisp
+++ b/cells-gtk/test-gtk/test-drawing.lisp
@@ -126,9 +126,9 @@
'line
:fm-parent *parent*
:widget (widget self)
- :p1 (c? (2d:v+ (p (upper self))
+ :p1 (c? (2d:v+ (p (fm-parent self))
(2d:cartesian-coords (2d:v-polar phi (* r 1.2)))))
- :p2 (c? (2d:v+ (p (upper self))
+ :p2 (c? (2d:v+ (p (fm-parent self))
(2d:cartesian-coords (2d:v-polar phi (+ (* r 1.2) l)))))
:rgb '(1 1 0)
:line-width 3
diff --git a/cells-gtk/test-gtk/test-textview.lisp b/cells-gtk/test-gtk/test-textview.lisp
index 3c7562d..08e299d 100644
--- a/cells-gtk/test-gtk/test-textview.lisp
+++ b/cells-gtk/test-gtk/test-textview.lisp
@@ -17,7 +17,7 @@
(mk-scrolled-window
:kids (kids-list?
(mk-text-view
- :buffer (c? (buffer (upper self test-textview)))
+ :buffer (c? (buffer (fm-ascendant-typed self 'test-textview)))
#+libcellsgtk :populate-popup
#+libcellsgtk
(c?
diff --git a/cells-gtk/test-gtk/test-tree-view.lisp b/cells-gtk/test-gtk/test-tree-view.lisp
index 36c7269..f3ca760 100644
--- a/cells-gtk/test-gtk/test-tree-view.lisp
+++ b/cells-gtk/test-gtk/test-tree-view.lisp
@@ -58,7 +58,7 @@
(defmacro root ()
- '(data (upper self test-tree-view)))
+ '(data (fm-ascendant-typed self 'test-tree-view)))
(defmodel test-tree-view (notebook)
((data :accessor data :initform (c-in (make-sample-tree "tree" 3)))
@@ -161,7 +161,7 @@
(:boolean (:title "Boolean"))
(:date (:title "Date")))
:select-if (c? (widget-value :selection-predicate))
- :items (c? (items (upper self test-tree-view)))
+ :items (c? (items (fm-ascendant-typed self 'test-tree-view)))
:print-fn (lambda (item)
(list (string$ item) (icon$ item) (int$ item) (float$ item)
(double$ item) (boolean$ item) (date$ item))))))))
@@ -221,7 +221,7 @@
#'(lambda (val)
(list :foreground (if (> val 5) "red" "blue"))))
(:string (:title "Gtk address")))
- :roots (c? (list (upper self gtk-app)))
+ :roots (c? (list (fm-ascendant-typed self 'gtk-app)))
:children-fn #'cells:kids
:print-fn #'(lambda (item)
(list
@@ -265,7 +265,7 @@
:on-clicked (callback (w e d)
(with-widget-value (node :tree-1)
(with-integrity (:change 'tv-del-node)
- (setf (kids (upper node)) (remove node (kids (upper node))))))))))
+ (setf (kids (fm-ascendant-typed 'node)) (remove node (kids (fm-parent node))))))))))
(mk-scrolled-window
:expand t :fill t
:kids (kids-list? (mk-node-tree (root) :expand t :fill t :md-name :tree-1)))))))
@@ -295,6 +295,6 @@
:on-clicked (callback (w e d)
(with-widget-value (node :tree-2)
(with-integrity (:change 'tv-del-node)
- (setf (kids (upper node)) (remove node (kids (upper node))))))))
+ (setf (kids (fm-ascendant-typed 'node)) (remove node (kids (fm-parent node))))))))
)))))))))))))
diff --git a/cells-gtk/tree-view.lisp b/cells-gtk/tree-view.lisp
index b8f8749..c295029 100644
--- a/cells-gtk/tree-view.lisp
+++ b/cells-gtk/tree-view.lisp
@@ -476,7 +476,7 @@ Creates an observer node observing source. To be specialized on subclasses of f
()
(:default-initargs
:kids (kids-list?
- (progn #+msg(print (list "CALCULATE KIDS for family observer" self "on" (^value) "-- parent" (upper self)))
+ (progn #+msg(print (list "CALCULATE KIDS for family observer" self "on" (^value) "-- parent" (fm-parent self)))
(bwhen (val (^value)) ;; not sure why not
(unless (deadp val)
(trcx nil "creating kids" val (slot-value val 'cells::.md-state) (kids val))
@@ -489,11 +489,11 @@ Creates an observer node observing source. To be specialized on subclasses of f
;;; this is too early -- upper self is not set yet
(defmethod initialize-instance :after ((self family-observer) &rest initargs)
(declare (ignorable initargs))
- #+msg (print (list "CREATE family observer" self "on" (value self) "-- parent" (upper self))))
+ #+msg (print (list "CREATE family observer" self "on" (value self) "-- parent" (fm-parent self))))
;;; this is too late, gets called for children before parent
(defmethod md-awaken :after ((self family-observer))
- #+msg (print (list "AWAKEN family observer" self "on" (value self) "-- parent" (upper self))))
+ #+msg (print (list "AWAKEN family observer" self "on" (value self) "-- parent" (fm-parent self))))
;;; then the cells stuff for observing slots
@@ -596,7 +596,7 @@ without default-pointer, body is not executed -- path and iter are null-pointer.
(defmodel cells-tree-node (family-observer)
((row :reader row :initarg :row))
(:default-initargs
- :row (c? (when-bind* ((parent (upper self)) (pos (position self (kids parent))))
+ :row (c? (when-bind* ((parent (fm-parent self)) (pos (position self (kids parent))))
(unless (or (deadp parent) (deadp self))
#+msg (format t "~&create row for ~a (parent ~a) -- " (value self) (value parent))
(let ((new-row (tree-row-create (row parent) (id parent))))
--
1.5.5.4
>From 470540bcb3bf06bb12cc603fa4751290d222ae13 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 22:04:00 +0200
Subject: [PATCH] Upgrade CFFI to current darcs (0.9.2+)
Get rid of gtk-ffi-impl.lisp (cffi now depends on babel).
---
gtk-ffi/gtk-ffi-impl.lisp | 40 ----------------------------------------
gtk-ffi/gtk-ffi.asd | 3 +--
gtk-ffi/gtk-ffi.lisp | 11 ++++-------
gtk-ffi/gtk-utilities.lisp | 2 +-
4 files changed, 6 insertions(+), 50 deletions(-)
delete mode 100644 gtk-ffi/gtk-ffi-impl.lisp
diff --git a/gtk-ffi/gtk-ffi-impl.lisp b/gtk-ffi/gtk-ffi-impl.lisp
deleted file mode 100644
index 8096d6d..0000000
--- a/gtk-ffi/gtk-ffi-impl.lisp
+++ /dev/null
@@ -1,40 +0,0 @@
-
-#|
-
-Implementation dependent stuff goes here
-
-Currently supported
-
- -- sbcl: utf-8 string handling
- -- clisp: utf-8 string handling (thanks to Ingo Bormuth)
-
-|#
-
-(in-package :gtk-ffi)
-
-
-;;;
-;;; UTF-8 string handling
-;;;
-
-(defun lisp-to-utf-8 (str)
- #-(or clisp sbcl) (return-from lisp-to-utf-8 str)
- (when str
- #+clisp (ext:convert-string-to-bytes str charset:utf-8)
- #+sbcl (sb-ext:string-to-octets str :external-format :utf-8)))
-
-(defun utf-8-to-lisp (str)
- #-(or clisp sbcl) (return-from utf-8-to-lisp str)
- (when str
- (let* ((nat (lisp-to-utf-8 str))
- (oct (coerce (loop for i from 0 below (length nat)
- for b = (aref nat i)
- collect b
- ;; ph: gtk gives us 4 bytes per char ; why ?
- if (= b 195) do (incf i 2))
- '(vector (unsigned-byte 8)))))
- #+clisp (ext:convert-string-from-bytes oct charset:utf-8)
- #+sbcl (sb-ext:octets-to-string oct :external-format :utf-8))))
-
-
-
diff --git a/gtk-ffi/gtk-ffi.asd b/gtk-ffi/gtk-ffi.asd
index 4c507fa..2cf9389 100644
--- a/gtk-ffi/gtk-ffi.asd
+++ b/gtk-ffi/gtk-ffi.asd
@@ -22,9 +22,8 @@
)
:components
((:file "package")
- (:file "gtk-ffi-impl" :depends-on ("package"))
(:file "gtk-threads" :depends-on ("package"))
- (:file "gtk-ffi" :depends-on ("gtk-threads" "gtk-ffi-impl"))
+ (:file "gtk-ffi" :depends-on ("gtk-threads"))
#+cells-gtk-opengl (:file "gtk-gl-ext" :depends-on ("package"))
(:file "gtk-core" :depends-on ("gtk-ffi"))
(:file "gtk-other" :depends-on ("gtk-ffi"))
diff --git a/gtk-ffi/gtk-ffi.lisp b/gtk-ffi/gtk-ffi.lisp
index e7f583d..2f279ec 100644
--- a/gtk-ffi/gtk-ffi.lisp
+++ b/gtk-ffi/gtk-ffi.lisp
@@ -86,10 +86,10 @@
(defmethod cffi:translate-to-foreign (value (type gtk-string-type))
(when (null value) (setf value "")) ; pod ???
- (cffi:foreign-string-alloc value))
+ (cffi:foreign-string-alloc value :encoding :utf-8))
-(defmethod cffi:translate-from-foreign (value (type gtk-string-type))
- (utf-8-to-lisp (cffi:foreign-string-to-lisp value)))
+(defmethod cffi:translate-from-foreign (ptr (type gtk-string-type))
+ (cffi:foreign-string-to-lisp ptr :encoding :utf-8))
@@ -218,10 +218,7 @@
,(when (with-debug-p name)
`(format *trace-output* "~%Calling (~A ~{~A~^ ~})"
,(string-downcase (string name)) (list ,@(mapcar 'car arguments)))))
- (let ((result ,(let ((fn `(,gtk-name ,@(mapcar #'(lambda (arg) (if (eql (cadr arg) 'gtk-string)
- `(lisp-to-utf-8 ,(car arg))
- (car arg)))
- arguments))))
+ (let ((result ,(let ((fn `(,gtk-name ,@(mapcar 'car arguments))))
#+cells-gtk-threads (if (with-gdk-threads-p name) `(with-gdk-threads ,fn) fn)
#-cells-gtk-threads fn)))
(when *gtk-debug*
diff --git a/gtk-ffi/gtk-utilities.lisp b/gtk-ffi/gtk-utilities.lisp
index 0b41dff..f826b80 100644
--- a/gtk-ffi/gtk-utilities.lisp
+++ b/gtk-ffi/gtk-utilities.lisp
@@ -213,7 +213,7 @@
returned-value)))
(prog1
(cond
- (ret$ (utf-8-to-lisp (uffi:convert-from-cstring ret$))) ; ph 01/2008: here we need to convert back from gtk utf-8 to lisp
+ (ret$ (cffi:foreign-string-to-lisp ret$ :encoding :utf-8))
((eq col-type :boolean)
(not (zerop returned-value)))
(t returned-value))
--
1.5.5.4
From c4e69555d0a00a8f4fe357763399af6fe13cb867 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 21:28:06 +0200
Subject: [PATCH] Add some special character examples to test-display.lisp.
Also add comments and clean up.
(Note: The texts are taken from Wikipedia articles on Lisp ;)
---
cells-gtk/test-gtk/test-display.lisp | 163 ++++++++++++++++++++++------------
1 files changed, 106 insertions(+), 57 deletions(-)
diff --git a/cells-gtk/test-gtk/test-display.lisp b/cells-gtk/test-gtk/test-display.lisp
index e7a2f57..a95f685 100644
--- a/cells-gtk/test-gtk/test-display.lisp
+++ b/cells-gtk/test-gtk/test-display.lisp
@@ -1,66 +1,115 @@
(in-package :test-gtk)
-
(defmodel test-display (vbox)
- ()
- (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false.
+ ()
+ (:default-initargs
+
+ ;; g_timeout_add: Calles a function after a certain amount of time (timeout).
+ ;; Does not block here (call comes from gtk event loop).
+ ;;
+ ;; The follow will move the progressbar until pulse(a toggle button) is false.
:value (c? (with-widget-value (val :pulse)
- (with-widget-value (timeout :timeout)
- (trc "ADDING TIMEOUT")
- (timeout-add timeout
- (lambda ()
- (with-widget (pbar :pbar2)
- (pulse pbar))
- (widget-value :pulse))))))
- :expand t :fill t
+ (with-widget-value (timeout :timeout)
+ (trc "ADDING TIMEOUT")
+ (timeout-add timeout
+ (lambda ()
+ (with-widget (pbar :pbar2)
+ (pulse pbar))
+ (widget-value :pulse))))))
+
+ :expand t :fill t :spacing 10
:kids (kids-list?
+
+ ;; --- Icons ---------------------------------------------------
(mk-hbox
- :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog)
- collect (mk-image :stock :harddisk :icon-size icon-size)
- collect (mk-image :stock :my-g :icon-size icon-size)))
- (mk-hseparator)
- (mk-aspect-frame
- :ratio 1
- :kids (kids-list?
- (mk-image :width 200 :height 250
- :filename (namestring *tst-image*))))
+ :homogeneous t
+ :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar
+ :button :dnd :dialog)
+ collect (mk-image :stock :harddisk :icon-size icon-size)
+ collect (mk-image :stock :my-g :icon-size icon-size)))
+
(mk-hseparator)
- (mk-hbox
- :kids (kids-list?
- (mk-progress-bar :md-name :pbar
- :fraction (c? (widget-value :fraction-value 1)))
- (mk-hscale :md-name :fraction-value
- :value-type 'single-float
- :min 0 :max 1
- :step 0.01
- :init 0.5)
- (mk-button :label "Show in status bar"
- :on-clicked
- (callback (widget event data)
- (with-widget (w :statusbar)
- (with-widget (pbar :pbar)
- (push-message w (format nil "~a" (fraction pbar)))))))))
+
+ ;; --- Controls ------------------------------------------------
(mk-hbox
:kids (kids-list?
- (mk-progress-bar :md-name :pbar2
- :pulse-step (c? (widget-value :step .1))
- :fraction (c-in .1))
- (mk-toggle-button :md-name :pulse :label "Pulse")
- (mk-label :text "Interval")
- (mk-spin-button :md-name :timeout
- :sensitive (c? (not (widget-value :pulse)))
- :min 10 :max 1000
- :init 100)
- (mk-label :text "Pulse step")
- (mk-spin-button :md-name :step
- :value-type 'single-float
- :min 0.01 :max 1 :step 0.01
- :init 0.1)
- (mk-image :md-name :pulse-image
- :stock (c? (if (widget-value :pulse) :yes :no)))))
- (mk-alignment
- :expand t :fill t
- :xalign 0 :yalign 1
- :xscale 1
- :kids (c? (the-kids
- (mk-statusbar :md-name :statusbar)))))))
+
+ (mk-progress-bar
+ :md-name :pbar
+ :fraction (c? (widget-value :fraction-value 1)))
+
+ (mk-hscale
+ :md-name :fraction-value
+ :value-type 'single-float
+ :min 0 :max 1
+ :step 0.01
+ :init 0.5)
+
+ (mk-button
+ :label "Show in status bar"
+ :on-clicked (callback (widget event data)
+ (with-widget (sbar :statusbar)
+ (with-widget (pbar :pbar)
+ (push-message sbar
+ (format nil
+ "Fraction: ~a"
+ (fraction pbar)))))))))
+ (mk-hbox
+ :kids (kids-list?
+
+ (mk-progress-bar
+ :md-name :pbar2
+ :pulse-step (c? (widget-value :step .1))
+ :fraction (c-in .1))
+
+ (mk-toggle-button
+ :md-name :pulse :label "Pulse")
+
+ (mk-label
+ :text "Interval")
+
+ (mk-spin-button
+ :md-name :timeout
+ :sensitive (c? (not (widget-value :pulse)))
+ :min 10 :max 1000
+ :init 100)
+
+ (mk-label
+ :text "Pulse step")
+
+ (mk-spin-button
+ :md-name :step
+ :value-type 'single-float
+ :min 0.01 :max 1 :step 0.01
+ :init 0.1)
+
+ (mk-image
+ :md-name :pulse-image
+ :stock (c? (if (widget-value :pulse) :yes :no)))))
+
+ ;; --- Image ---------------------------------------------------
+ (mk-scrolled-window
+ :fill t :expand t
+ :kids (list
+ (mk-image :filename (namestring *tst-image*))))
+
+ ;; --- Special Characters --------------------------------------
+ (mk-hbox
+ :homogeneous t
+ :kids (list
+
+ (mk-label
+ :text "à à à á à â à ã à ä Ã
Ã¥ à æ Ä Ä Ä Ä Ä Ä
à ç Ä Ä Ä Ä Ä Ä Ä Ä Æ· Ê Ç® ǯ Ä Ã° Ä Ä Ä Ä Ã Ã¨ à é à ê à ë Ä Ä Ä Ä Ä Ä Ä Ä Æ É Ä Ä Ä Ä Ä Ä¡ Ä¢ Ä£ Ǥ Ç¥ Ǧ ǧ Ĥ Ä¥ Ħ ħ à ì à à à î à ï Ī Ä« Ä® į Ä° i I ı IJ ijǩ Ä» ļ ŠŠà ñ Å Å Å
ŠŠŠŠŠà ò à ó à ô à õ à ö ŠŠà ø Å Å Å Å Æ Æ¡ Å Å Å Å Ã Å Å Å Å Å Å È È Å Å¡ à þ Å¢ Å£ È È Å¤ Å¥ Ŧ ŧ à ù à ú à û à ü Ū Å« Ŭ Å Å® ů Å° ű Ų ų Ư Æ° Å´ ŵ Ÿ ÿ à ý Ŷ Å· Ź ź Å» ż Ž ž"
+ :fill t :expand t :line-wrap t)
+
+ (mk-label
+ :text "ÙÙسب ÙÙ Ùغة برÙ
جة ÙظÙÙÙØ© ÙÙ٠اختصار ÙÙ
صطÙØ Ù
عاÙجة اÙÙÙائÙ
ÙتÙÙÙ
عÙÙ Øساب ÙاÙ
بدا ÙÙÙ Ù
٠أÙÙ
Ùغات اÙØ°Ùاء اÙإصطÙاعÙØ ÙتستخدÙ
ÙØ°ÙÙ Ù٠تطبÙÙات أخر٠تتطÙب تÙÙÙد تÙÙائ٠ÙÙبراÙ
ج. ÙÙد اخترعÙا جÙÙ Ù
Ùارث٠عاÙ
1958 أثÙاء تÙاجد٠ÙÙ Ù
عÙد Ù
اساتشÙستس ÙÙتÙÙÙÙÙجÙØ§Ø ÙبذÙ٠تعد ثاÙ٠أÙدÙ
Ùغة برÙ
جة عاÙÙØ© اÙÙ
ستÙÙ."
+ :fill t :expand t :line-wrap t)
+
+ (mk-label
+ :text "ã¯è©ä¾¡ããã¦ãªã¹ã(1 2 \"foo\")ãè¿ãã ããå¼ æ°ã®ã©ãããå¼ã§ããã°ããããå«ãå¼ãè©ä¾¡ãã ãåã«ãããå帰çã«è©ä¾¡ãããããã¨ãã°ã"
+ :fill t :expand t :line-wrap t)))
+
+ ;; --- Statusbar -----------------------------------------------
+ (mk-statusbar
+ :md-name :statusbar))))
--
1.5.5.4
>From f661859ed7d90c813733e038d3615757f78232bb Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 11:38:57 +0200
Subject: [PATCH] Remainder of obsolete clisp hack.
Should have been included on June 2, 2008.
---
cells-gtk/widgets.lisp | 3 +--
1 files changed, 1 insertions(+), 2 deletions(-)
diff --git a/cells-gtk/widgets.lisp b/cells-gtk/widgets.lisp
index 9764bcc..5c1540b 100644
--- a/cells-gtk/widgets.lisp
+++ b/cells-gtk/widgets.lisp
@@ -492,8 +492,7 @@
(defobserver .kids ((self event-box))
(assert-bin self)
(when new-value
- (gtk-container-add (id self) (id (first new-value))))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id (first new-value)))))
(declaim (inline widget-id))
(defun widget-id (widget)
--
1.5.5.4
>From 52e5a9f89c4189f28450ba72aacb019c56057b64 Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 12:08:08 +0200
Subject: [PATCH] Always call #'load-gtk-libs in gtk-ffi.lisp.
Minor fix: export only once.
---
gtk-ffi/gtk-ffi.lisp | 31 ++++++++++++++++++-------------
gtk-ffi/package.lisp | 1 -
2 files changed, 18 insertions(+), 14 deletions(-)
diff --git a/gtk-ffi/gtk-ffi.lisp b/gtk-ffi/gtk-ffi.lisp
index 2f279ec..860bb46 100644
--- a/gtk-ffi/gtk-ffi.lisp
+++ b/gtk-ffi/gtk-ffi.lisp
@@ -135,32 +135,37 @@
(cffi-features:darwin #.(merge-pathnames "libcellsgtk.dylib" *compile-file-pathname*)))
) ;eval-when
-;;; After doing this, should be able to do (g-thread-init c-null)
+;;; After doing this, should be able to do (g-thread-init +c-null+)
;;; LW Win32 is hanging on POD's machine only:
;;; (fli:register-module "libgdk-win32-2.0-0.dll" :connection-style :immediate)
;;; (fli:register-module "c:\\Program Files\\Common Files\\GTK\\2.0\\bin\\libgdk-win32-2.0-0.dll"
;;; :connection-style :immediate)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun load-gtk-libs ()
- (handler-bind ((style-warning #'muffle-warning))
- (cffi:load-foreign-library :gobject)
- (cffi:load-foreign-library :glib)
- (cffi:load-foreign-library :gthread)
- (cffi:load-foreign-library :gdk)
- (cffi:load-foreign-library :gtk)
- #+libcellsgtk
- (cffi:load-foreign-library :cgtk)))
+ (let ((gtk-libs-loaded nil))
+ (defun load-gtk-libs ()
+ (unless gtk-libs-loaded ; FIXME: Why do we need that check at all? (ibormuth)
+ ; CLisp/Linux didn't complain when calling the followin multiple times.
+ (setf gtk-libs-loaded t)
+ (handler-bind ((style-warning #'muffle-warning))
+ (cffi:load-foreign-library :gobject)
+ (cffi:load-foreign-library :glib)
+ (cffi:load-foreign-library :gthread)
+ (cffi:load-foreign-library :gdk)
+ (cffi:load-foreign-library :gtk)
+ #+libcellsgtk (cffi:load-foreign-library :cgtk)))))
+ ;; load all libs immediately:
+ ;; FIXME: Wouldn't it be nice to load libcellsgtk on demand ? (ibormuth)
+ (load-gtk-libs)
) ; eval
(eval-when (:compile-toplevel :load-toplevel :execute)
+
(defun gtk-function-name (lisp-name)
(substitute #\_ #\- lisp-name))
- #+(or cmu clisp)(load-gtk-libs)
-
(defun ffi-to-uffi-type (clisp-type)
-
(if (consp clisp-type)
(mapcar 'ffi-to-uffi-type clisp-type)
(case clisp-type
diff --git a/gtk-ffi/package.lisp b/gtk-ffi/package.lisp
index 22a8205..f9e63a9 100644
--- a/gtk-ffi/package.lisp
+++ b/gtk-ffi/package.lisp
@@ -42,7 +42,6 @@
#:gtk-boolean
#:otherwise
#:*gtk-debug*
- #:load-gtk-libs
#:col-type-to-ffi-type
#:deref-pointer-runtime-typed
#:gtk-tree-iter
--
1.5.5.4
>From 09c64489be1c1cb0575ef877e4db05202e65680b Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 12:29:43 +0200
Subject: [PATCH] Gtk_init is not needed.
>From the gtk manual:
--------------------
Note that there are some alternative ways to initialize GTK+:
if you are calling gtk_parse_args(), gtk_init_check(), gtk_init_with_args()
or g_option_context_parse() with the option group returned by
gtk_get_option_group(), you don't have to call gtk_init().
---
gtk-ffi/gtk-other.lisp | 4 +---
1 files changed, 1 insertions(+), 3 deletions(-)
diff --git a/gtk-ffi/gtk-other.lisp b/gtk-ffi/gtk-other.lisp
index 5e274e4..c954245 100644
--- a/gtk-ffi/gtk-other.lisp
+++ b/gtk-ffi/gtk-other.lisp
@@ -20,9 +20,7 @@
(def-gtk-lib-functions :gtk
- ;; main-loop
- (gtk-init :void
- ((argc :pointer) (argv :pointer)))
+ ;; main-loop
(gtk-init-check gtk-boolean
((argc :pointer)
(argv :pointer)))
--
1.5.5.4
>From edf4af4d22d02954929b4f6e0f864c15dba79b1c Mon Sep 17 00:00:00 2001
From: Ingo Bormuth <[EMAIL PROTECTED]>
Date: Mon, 23 Jun 2008 12:27:57 +0200
Subject: [PATCH] Make startup code a bit saner (in my rather subjective opinion).
- New function #'threads-p returns true if we really can use threads
- Remove *gtk-loaded* because #'load-gtk-libs performs its own check
- Rename 'threading-initialized to 'g-thread-already-initialized
---
cells-gtk/gtk-app.lisp | 41 +++++++++++++++++++----------------------
cells-gtk/packages.lisp | 2 ++
2 files changed, 21 insertions(+), 22 deletions(-)
diff --git a/cells-gtk/gtk-app.lisp b/cells-gtk/gtk-app.lisp
index 47ffd7e..341901d 100644
--- a/cells-gtk/gtk-app.lisp
+++ b/cells-gtk/gtk-app.lisp
@@ -131,43 +131,40 @@
;;; Helper functions convering the life cycle of an application
;;;
-(defvar *using-thread* 'undecided)
+(defvar *using-thread* 'undecided "Remember whether start-win or start-app is used in this lisp session.")
+
+(defun threads-p ()
+ "True if threads are available.
+ That means bordeaux-threads are available AND your lisp system actually supports threads."
+ #+cells-gtk-threads bordeaux-threads:*supports-threads-p*
+ #-cells-gtk-threads nil)
;;; Initialize GDK
;;; When we have libcellsgtk, we can use a glib function to check whether
;;; is initialized. Otherwise we need a variable
-(defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own
-
(defun cells-gtk-init ()
"initialize cells-gtk. DO NOT USE WITH THREADING"
- #-cmu
- (unless *gtk-loaded*
- (gtk-ffi:load-gtk-libs)
- (setf *gtk-loaded* t))
+ (gtk-ffi:load-gtk-libs)
(gtk-reset))
-(let (#-libcellsgtk (threading-initialized nil))
+(let (#-libcellsgtk (g-thread-already-initialized nil))
(defun init-gtk (&key close-all-windows)
"Replacement for cells-gtk-init. Threadsafe. Use to reset cells-gtk to a defined state."
- (unless *gtk-loaded* ; make sure gtk is loaded
- (gtk-ffi:load-gtk-libs)
- (setf *gtk-loaded* t))
+ (gtk-ffi:load-gtk-libs)
(when close-all-windows
(gtk-main-quit))
(when #+libcellsgtk (= 0 (gtk-adds-g-thread-supported)) ; init only once
- #-libcellsgtk (not threading-initialized)
- (with-trcs
- #+cells-gtk-threads
- (progn
- (g-thread-init +c-null+) ; init threading
- (gdk-threads-init))
- (assert (gtk-init-check +c-null+ +c-null+))
- (gtk-init +c-null+ +c-null+)
- #+cells-gtk-opengl (gl-init)
- (gtk-reset)
- #-libcellsgtk (setf threading-initialized t)))))
+ #-libcellsgtk (not g-thread-already-initialized)
+ #-libcellsgtk (setf g-thread-already-initialized t)
+ (with-trcs
+ (when (threads-p)
+ (g-thread-init +c-null+) ; init threading
+ (gdk-threads-init))
+ (assert (gtk-init-check +c-null+ +c-null+))
+ #+cells-gtk-opengl (gl-init)
+ (gtk-reset)))))
;;; Instantiate and show app (show splash)
diff --git a/cells-gtk/packages.lisp b/cells-gtk/packages.lisp
index 6e6613b..408c636 100644
--- a/cells-gtk/packages.lisp
+++ b/cells-gtk/packages.lisp
@@ -53,6 +53,7 @@
#:allocated-width
#:allocated-height
+ #:threads-p
#:start-app
#:start-win
#:stop-gtk-main
@@ -79,6 +80,7 @@
#:gtk-text-view-set-editable
#:gtk-text-buffer-move-mark
#:gtk-text-view-scroll-mark-onscreen
+ #:listbox
#:mk-listbox
#:mk-treebox
#:def-columns
--
1.5.5.4
_______________________________________________
cells-gtk-devel site list
cells-gtk-devel@common-lisp.net
http://common-lisp.net/mailman/listinfo/cells-gtk-devel
