From a8a4d8d22f496a01e595d783284c3d3d80085268 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 12 Dec 2010 16:34:18 -0700 Subject: [PATCH] Added SWAT emulation, just sufficient to run Pole Zero. Changed scm-layout from an integer-based layout to a fixnum-based layout called fix-layout. Added a "fix-" prefix to everything that should be using fixnums. Thus there are many name changes: scm-layout -> fix-layout drawing -> fix-drawing rect -> fix-rect drawn-item -> fix-ink I could not resist the brevity of "ink". "Item" is rather vague. Changes not otherwise mentioned below: Took care not to define-integrable when parameters are referenced multiple times. Used integrate-operator instead. Used guarantee-TYPE procedures rather than check-TYPE converters. Punted :: for combining type and method names. A hyphen will do. Used the new ignore declaration. Punted package initialization declarations in gtk.pkg. Added `(initialize-package!)' forms at the ends of files as necessary. Followed the MAKE- convention to name procedures that create demos or examples. Signal callbacks now rely on their first parameter, the weakly held instance, rather than capture it in their closures. The first argument used to be the toolkit object's address. * doc/gtk/gtk.texinfo: Incremented the minor VERSION. Moved many implementation notes to a new Implementation Notes node. Condensed the chapters about each example into subsections of the Introduction. Added a subsection about the SWAT emulation. Added an Installation chapter/node. Generally, re-wrote to the luser perspective. Used the packaging in gtk.pkg, esp. the lists of names exported to (gtk), to form a complete, if terse, API Reference. Pulled some luser documentation out of the Scheme code. * src/Makefile.in: Added ffi to the LIARC_BOOT_BUNDLES so that gtk can be compiled during LiarC's bootstrap. * src/README.txt: Moved gtk to the "miscellaneous extras". * src/Setup.sh: Added sos to lib/. * src/configure.ac: Made $with_gtk tri-valued: yes, no, auto. It defaults to "auto". Moved pkg-config check to src/microcode/ achost.ac. Added gtk to FFIS. * src/cref/: object.scm, redpkg.scm: Added support for declare forms at top-level in .pkg files, and depends-on forms in package descriptions. Added corresponding slots to the package, package- description, and pmodel structures. A depends-on form lists files (by default: .ext files) that should be generated before the package is syntaxed. The top-level declare(s) are applied to all files. * src/etc/compile.scm: Worked on LiarC support, moving the ffi to the list of boot dirs. Added a compile-ffi procedure for the build target of FFI Makefiles like src/gtk/Makefile-fragment. * src/etc/functions.sh (maybe_rm): Do not skip symlinks. src/config.sub and src/config.guess were not getting cleaned up. Add them to FILES so they will be removed. * src/gtk/: .gitignore, Clean.sh, Makefile-fragment: Added the swat-pole-zero.scm symlink. * src/gtk/Makefile-fragment: Use the compile-ffi procedure from src/etc/compile.scm to compile the Gtk system. Use the host MIT_SCHEME_EXE to generate the shim. Added a new liarc-build target that compiles the gtk bundle. * src/gtk/Includes/: Many useful declarations. * src/gtk/demo.scm: Renamed "fix-demo.scm". * src/gtk/ed-ffi.scm: Catch up changes to file packaging. * src/gtk/fix-demo.scm: Was "demo.scm". Added a spinning arc-ink. * src/gtk/fix-layout.scm: Was "scm-layout.scm". Many drawn-items were re-implemented as draw-inks. * src/gtk/gobject.scm: Added gobject-live?, gobject-unref!, gdk-window-process-updates guarantee-gdk-window. Arrange for signal callbacks to hold their instances weakly. Add-gc-cleanup now returns the weak-pair it is using, so it can be reused by g-signal-connect. Banish ferror; error will do. * src/gtk/gtk-ev.scm: Init a ScmWidget's requisition member; it no longer has a size-request method to do it. Use the new bit? procedure to test bits in bit masks. Punted the second trace level. Moved initialization out of make- procedure and into an initialize-instance method. * src/gtk/gtk-new.pkg: A temporary copy of gtk.pkg with the new declare and depends-on expressions. * src/gtk/gtk-object.scm: Added many new procedures and classes: gtk-widget-realized?, gtk-widget-get-colormap, gtk-widget-show, gtk-widget-connect-realize, gtk-bin-child, gtk-container-remove, gtk-label-set-width-chars, , , gtk-window-set-opacity. Use the new bit? predicate. Added a set-gtk-object-destroy-callback! procedure for the convenience of gtk-object initialize-instance methods, for lack of "after" method combination. Take care when setting a style's font: copy the new PangoFontDescription and free the old one. Made gtk-widget-get-colormap and set-gtk-widget-bg-color! generic procedures so that fix-layout can override them. Noted that a gtk-container keeps its children in reverse order. Centralized maintenance of the list. Operate on it atomically -- without-interrupts for now. Moved gtk-object initialization from make- procedures to initialize-instance methods for many widget types, so they can be subclassed. * src/gtk/gtk-shim.h: Punted the only method and all of the method callback ids. The ScmWidget methods are now implemented by signal callbacks. * src/gtk/gtk.cdecl: Punted the widget method callbacks and added the corresponding signal callbacks. Added several other new C function and callback declarations. Moved some to a new Includes/gtklabel.cdecl. * src/gtk/gtk.pkg: Moved package (gtk pango) to earlier in the build. Eliminated initialization declarations. Added new packages (gtk swat), (swat) and (swat pole-zero), and many new bindings. * src/gtk/gtk.scm: Gathered new syntax and fix: definitions for system-wide use, expecting this file to be loaded at syntax as well as load time. Added new bit-mask operators: bit-mask, bit-mask-indices, and bit?. Moved the rect- procedures to fix-layout.scm. Replaced check-!null with error-if-null. Punted ferror and fwarn. Moved Pango hacks to pango.scm. * src/gtk/gtk.sf: Use the new sf-package-set procedure, eliminating 60+ lines largely redundant to the info in gtk.pkg. * src/gtk/hello.scm: Added an instance parameter to each callback. * src/gtk/keys.scm: Use the new bit? predicate. Moved documentation to gtk.texinfo. * src/gtk/main.scm: Appended call to initialize-package!. * src/gtk/make.scm: Incremented the Gtk subsystem's minor version number. * src/gtk/pango-cairo.scm: Punted until real Cairo support is added. * src/gtk/pango.scm: Added more argument checking, and a pango-layout-set-font-description procedure. Collected other Pango-related procedures, e.g. from gtk.scm. Moved luser documentation to gtk.texinfo. * src/gtk/scm-layout.scm: Renamed "fix-layout.scm". * src/gtk/scm-widget.scm: Use g_object_ref_sink on a new ScmWidget. Added set-scm-widget-set-scroll-adjustments-callback!. Punt method callbacks. All methods are now implemented by signal callbacks. * src/gtk/scmwidget.c.stay: Override the realize method, which assumes the widget has no window. Add a set_scroll_adjustments signal. * src/gtk/swat.scm: The new SWAT emulator. * src/gtk/thread.scm: Just signal an error if there are no runnable threads and no next-scheduled-timeout. * src/microcode/achost.ac: Added the pkg-config check. Conditionally add prgtkio.so to MODULE_TARGETS. * src/microcode/configure.ac: Removed redundant pkg-config check -- redundant now that it is in achost.ac. * src/microcode/prgtkio.c: The "uxselect.h" header no longer exists. * src/runtime/ffi.scm: Added guarantee-alien-function and error:not-alien-function. Fixed guarantee-alien to follow suit. Added tracing to free-malloced-aliens. * src/runtime/runtime.pkg: Added package (runtime thread-queue) and guarantee-alien-function. * src/runtime/thread-queue.scm: A queue that blocks threads. * src/sf/: butils.scm, make.scm, sf.pkg: Added the sf-package-set procedure, which uses CREF. --- doc/gtk/gtk.texinfo | 1996 ++++++++++++++++++++++++--- src/Makefile.in | 4 +- src/README.txt | 6 +- src/Setup.sh | 1 + src/configure.ac | 36 +- src/cref/object.scm | 7 +- src/cref/redpkg.scm | 54 +- src/etc/compile.scm | 10 +- src/etc/functions.sh | 12 +- src/gtk/.gitignore | 1 + src/gtk/Clean.sh | 2 +- src/gtk/Includes/gdk.cdecl | 4 +- src/gtk/Includes/gdkcairo.cdecl | 34 + src/gtk/Includes/gdkdrawable.cdecl | 35 +- src/gtk/Includes/gdkgc.cdecl | 18 +- src/gtk/Includes/gdkrgb.cdecl | 6 +- src/gtk/Includes/gdktypes.cdecl | 9 +- src/gtk/Includes/gdkvisual.cdecl | 34 + src/gtk/Includes/gdkwindow.cdecl | 6 +- src/gtk/Includes/gtk.cdecl | 8 +- src/gtk/Includes/gtkframe.cdecl | 15 + src/gtk/Includes/gtkgc.cdecl | 12 + src/gtk/Includes/gtkhbox.cdecl | 8 + src/gtk/Includes/gtklabel.cdecl | 23 + src/gtk/Includes/gtkobject.cdecl | 1 + src/gtk/Includes/gtkstyle.cdecl | 4 +- src/gtk/Includes/gtkwidget.cdecl | 59 +- src/gtk/Includes/gtkwindow.cdecl | 9 + src/gtk/Includes/pango-font.cdecl | 4 + src/gtk/Includes/pango-layout.cdecl | 3 + src/gtk/Makefile-fragment | 15 +- src/gtk/demo.scm | 197 --- src/gtk/ed-ffi.scm | 9 +- src/gtk/fix-demo.scm | 245 ++++ src/gtk/fix-layout.scm | 1907 +++++++++++++++++++++++++ src/gtk/gobject.scm | 370 +++-- src/gtk/gtk-ev.scm | 440 +++--- src/gtk/gtk-new.pkg | 360 +++++ src/gtk/gtk-object.scm | 1050 ++++++++------ src/gtk/gtk-shim.h | 12 - src/gtk/gtk.cdecl | 91 +- src/gtk/gtk.pkg | 295 ++-- src/gtk/gtk.scm | 344 +---- src/gtk/gtk.sf | 91 +- src/gtk/hello.scm | 4 +- src/gtk/keys.scm | 14 +- src/gtk/main.scm | 5 +- src/gtk/make.scm | 2 +- src/gtk/pango-cairo.scm | 59 - src/gtk/pango.scm | 282 ++-- src/gtk/scm-layout.scm | 1062 -------------- src/gtk/scm-widget.scm | 95 +- src/gtk/scmwidget.c.stay | 181 +-- src/gtk/swat.scm | 1233 +++++++++++++++++ src/gtk/thread.scm | 21 +- src/microcode/achost.ac | 25 + src/microcode/configure.ac | 15 - src/microcode/prgtkio.c | 1 - src/runtime/ffi.scm | 53 +- src/runtime/runtime.pkg | 18 + src/runtime/thread-queue.scm | 268 ++++ src/sf/butils.scm | 71 +- src/sf/make.scm | 1 + src/sf/sf.pkg | 13 +- 64 files changed, 7853 insertions(+), 3417 deletions(-) create mode 100644 src/gtk/Includes/gdkcairo.cdecl create mode 100644 src/gtk/Includes/gdkvisual.cdecl create mode 100644 src/gtk/Includes/gtkframe.cdecl create mode 100644 src/gtk/Includes/gtkgc.cdecl create mode 100644 src/gtk/Includes/gtkhbox.cdecl create mode 100644 src/gtk/Includes/gtklabel.cdecl delete mode 100644 src/gtk/demo.scm create mode 100644 src/gtk/fix-demo.scm create mode 100644 src/gtk/fix-layout.scm create mode 100644 src/gtk/gtk-new.pkg delete mode 100644 src/gtk/pango-cairo.scm delete mode 100644 src/gtk/scm-layout.scm create mode 100644 src/gtk/swat.scm create mode 100644 src/runtime/thread-queue.scm diff --git a/doc/gtk/gtk.texinfo b/doc/gtk/gtk.texinfo index 9dfefa14d..0bb19ff3c 100644 --- a/doc/gtk/gtk.texinfo +++ b/doc/gtk/gtk.texinfo @@ -1,10 +1,14 @@ \input texinfo @c -*-Texinfo-*- @comment %**start of header @setfilename mit-scheme-gtk -@set VERSION 0.1 +@set VERSION 0.2 @settitle Gtk @value{VERSION} @comment %**end of header +@macro bref {name} +@ref{\name\,,@code{\name\}} +@end macro + @copying This manual documents @acronym{Gtk} @value{VERSION}. @@ -48,275 +52,1879 @@ Software Foundation raise funds for GNU development.'' @end ifnottex @menu -* Introduction:: Emphasizing how @emph{little} of GNOME is wrapped. -* Hello World:: Not your primitive ``Hello, world!'' example. -* Gtk-Event-Viewer:: A simple Scheme widget. GtkEv translated into Scheme/FFI. -* Scm-Layout:: A Scheme canvas widget. +* Introduction:: +* API Reference:: +* Installation:: +* Implementation Notes:: This is for Scheme widget developers. * GNU Free Documentation License:: @end menu - -@node Introduction, Hello World, Top, Top +@node Introduction, API Reference, Top, Top @chapter Introduction The Gtk system is a collection of Scheme data types and procedures -that provide a simple, Schemely interface to the GNOME toolkit(s). -Toolkit objects are represented in Scheme by instances of the -@code{} class. Toolkit functions are wrapped by Scheme -procedures that translate to and from Scheme data types. - -When the Gtk system loads it starts a toolkit main loop with Scheme -attached as an custom idle task. The main loop then re-starts Scheme, -which creates a thread to ``run'' the toolkit (actually, return to -it). Thus Scheme threads multitask with the toolkit. Scheme runs as -an idle task in the toolkit, and the toolkit runs in a Scheme thread. -A program using the Gtk system does not call @code{gtk_init} nor -@code{gtk_main}. It need only create toolkit objects and attach -signal handlers to them. The hello program is a simple example. -(@xref{Hello World}.) - -Very little of the GNOME toolkit API has been wrapped. -The @file{gtk-shim.so} -is intended to stay small and focused, and @emph{not} include -every convenience function fancied by a C programmer. It does not -wrap nor intern nor register a gc cleanup for every GObject pointer -accessed by Scheme. To see what is available, refer to the -@file{gtk.pkg} description. - -It is likely the user will want to extend this system with additional -wrappings. The existing wrappers are the best examples of -what needs to be done. They are written in Scheme/FFI --- Scheme -extended with the accompanying FFI. +providing a Schemely interface to the GNOME toolkit(s), not entirely +unlike Perl's Gtk2 ``binding'' +(@uref{http://gtk2-perl.sourceforge.net}) though by no means as +extensive. Very little of the GNOME API has been wrapped --- just +what is listed herein. As one might expect of a ``Schemely'' +interface, all toolkit resources are protected from ``leaking'' by the +garbage collector. When Scheme's representative of a toolkit resource +is dropped and collected, the toolkit resource is freed, just as the +C/Unix FFI's malloced aliens are automatically freed. + +This manual assumes you are familiar with MIT Scheme's @code{src/} +tree @emph{and} the GNOME toolkits. Thus a few examples, a terse API +Reference, and The Code itself are all you have. + +@unnumberedsec Hello, World! + +Here is the ``Hello, World!'' program from the C/Unix FFI @ifnothtml -@xref{Top,, Introduction, mit-scheme-ffi, The FFI Reference Manual}. +(@pxref{Top,, Hello World, mit-scheme-ffi, The FFI Reference Manual}) @end ifnothtml @ifhtml -See the @uref{../FFI/mit-scheme-ffi.html,, The FFI Reference Manual}. +(@uref{mit-scheme-ffi.html#Hello%20World,, here}) @end ifhtml +re-written to use the Gtk system. Notice that the program does not +need the FFI; it uses no FFI syntax. There is no need to +@code{(load-option 'FFI)}. -@unnumberedsec Procedures +@verbatiminclude ../../src/gtk/hello.scm -The procedure wrappers are often trivial convenience functions that do -type checking and conversion, and hide the details of the C API. For -example, a GtkLabel's text is retrieved in two steps: a toolkit -function returns an alien address, and the C string at that address is -copied into the heap. +To run this program, enter the following command lines in the +@file{src/gtk} directory of your build tree. @smallexample - (let ((retval (make-alien '|gchar|))) - (C-call "gtk_label_get_text" retval (gobject-alien label)) - (c-peek-cstring retval)) -@result{} "!dlrow ,olleH" + ../microcode/scheme --library ../lib + (load-option 'Gtk) + (ge '(gtk)) + (load "hello") + (hello) @end smallexample -The @code{gtk-label-get-text} wrapper procedure hides these details. +@unnumberedsec Gtk Event Viewer -@smallexample - (gtk-label-get-text label) -@result{} "!dlrow ,olleH" -@end smallexample - -Using such wrappings, the primitive ``Hello, world!'' example in the -FFI system -@ifnothtml -(@pxref{Top,, Hello World, mit-scheme-ffi, The FFI Reference Manual}) -@end ifnothtml -@ifhtml -(@uref{mit-scheme-ffi.html#Hello%20World,, here}) -@end ifhtml -can be re-written in a more pleasantly Scheme-like way -@ifnothtml -(@pxref{Hello World}). -@end ifnothtml -@ifhtml -(@uref{#Hello%20World,, here}). -@end ifhtml - -Note that the @code{C-call} syntax above cannot be expanded without -first @code{C-include}ing a declaration of @code{gtk_label_get_text} ---- something like the following. +The Gtk Event Viewer is a simple Scheme widget --- a GtkWidget +whose methods are implemented by calls back into Scheme --- and a +straightforward translation of Havoc Pennington's GtkEv (from +@uref{http://developer.gnome.org/doc/GGAD/,, GGAD}). To see this +widget, enter the following command lines in the @file{src/gtk} +directory of your build tree. @smallexample - (extern (* (const gchar)) gtk_label_get_text (label (* GtkLabel))) + ../microcode/scheme --library ../lib + (load-option 'GTK) + (make-gtk-event-viewer-demo) @end smallexample -@unnumberedsec GObjects - -In the example call to @code{gtk-label-get-text} above, a Scheme -object represents the GtkLabel. It is a -@code{} instance, whose class is a specialization of the -abstract @code{} class. Here is the class hierarchy -for @code{}, a GtkContainer widget. - -@table @code - -@item -Wraps a GtkButton widget. - -@item -Adds a list of ``children'' to be implicitly destroyed along with -their parent. +The code can be found in @file{gtk-ev.scm}. -@item -Adds a ``parent'' slot. +@unnumberedsec Fix Demo -@item -Adds a ``destroyed?'' flag and the generic function -@code{gtk-object-destroy} in support of the GtkObject notion of -``destruction''. +The Gtk system provides a fixnum-centric canvas abstraction based on +the ancient X Window draw requests: XDrawLine, XDrawRectangle, +XDrawArc, etc. The canvas is a fix-drawing composed of fix-inks, each +rendered on fix-layout widgets according to ancient custom. -@item -Instances of this class have two slots. ``Alien'' is the address of -the toolkit GObject. ``Signals'' is an alist of signal handlers to be -disconnected when the gobject is finalized. +A demo of two fix-layout widgets displaying one drawing is provided. +The drawing contains a sample of each type of fix-ink with animation +and mouse tracking (highlighting the character under the pointer, and +reporting the inks under a click). To see these widgets in action, +enter the following command lines in the @file{src/gtk} directory of +your build tree. -@end table +@smallexample + ../microcode/scheme --library ../lib + (load-option 'Gtk) + (make-fix-layout-demo) +@end smallexample -@unnumberedsec GObject Properties +The code can be found in @file{fix-demo.scm}. -The @code{gobject-get-property} and @code{gobject-set-properties} -procedures are an attempt to use Glib's introspection facilities to -automatically determine the type of a property's value and construct -an appropriate reflection of its value in Scheme. They have not been -tested @emph{at all}. +@unnumberedsec SWAT -@unnumberedsec Scheme Widgets +The Gtk system contains a proof-of-concept emulation of the old Tk3.2 +interface --- SWAT, The Scheme Widget Application Toolkit, as +described in @cite{Introduction to SWAT}, by Hal Abelson, Natalya +Cohen and Jim Miller. The emulation lacks many widget types and +options, and is @emph{just} sufficient to run Pole Zero. -A Scheme widget is a @code{GtkWidget} that calls back to Scheme to -implement many of its methods. It is represented in Scheme by a -@code{}. As with other gtk-widgets, its signal -and method callbacks are tracked and de-registered when it is -destroyed (finalized). It is represented in the toolkit by a -@code{ScmWidget}, a direct subtype of @code{GtkWidget} (not a -@code{GtkContainer}, yet), which functions mainly as a big bag of -widget method callback hooks. The hooks are set via calls to -procedures like @code{set-scm-widget-expose!}. @code{} -(@pxref{Gtk-Event-Viewer}) is a simple example --- a straightforward -translation of Havoc Pennington's GtkEv (from -@uref{http://developer.gnome.org/doc/GGAD/,, GGAD}). +To see the Pole Zero application, enter the following command lines in +the @file{src/gtk} directory of your build tree. -@code{} (@pxref{Scm-Layout}) is a more sophisticated -Scheme widget that displays a view of a Scheme canvas. +@smallexample + ../microcode/scheme --library ../lib + (load-option 'Gtk) + (make-pole-zero) +@end smallexample -@unnumberedsec The @code{(gtk)} Package +@unnumberedsec The Gtk Package All of the Gtk system's public bindings are in the @code{(gtk)} package --- not exported to the global environment. It is assumed -that modules mucking about with the toolkit will be loaded in a -@code{(gtk)} subpackage where they will define Gtk-specific -procedures, such as methods for generics imported from a more abstract -interface package. +that modules mucking about with the toolkit(s) will be loaded in a +subpackage where they will define Gtk-specific procedures, such as +methods for generics imported from a more abstract interface. @unnumberedsec Debugging -The Scheme machine is currently built with some debugging facilities, -including a time slice counter. To see the counter, evaluate the -following expression: +The Scheme machine can be configured (via the +@code{--enable-debugging} option) to include some debugging +facilities, like a time slice counter. Evaluating the following +expression should cause a small window to pop up. @smallexample (gtk-time-slice-window! #t) - (gtk-time-slice-window! #f) - (gtk-time-slice-window?) @end smallexample -The second and third expressions take down the small window, and -programmatically tell you whether one is active, respectively. -The window shows a running count of the number of times the toolkit has -yielded to Scheme (or vice versa), and the channels currently being -polled by Scheme. This counter can be slowed or stopped by evaluating -the first or second expression below. +The window is created and updated on the toolkit side of the +interface, and shows a running count of the number of times the +toolkit has yielded to Scheme (or vice versa), and the channels +currently being polled by Scheme. The count can be slowed and stopped +by evaluating the first and second expressions below, respectively. @smallexample (set-thread-timer-interval! 1000) (set-thread-timer-interval! #f) @end smallexample +@xref{Debugging Facilities}. -@node Hello World, Gtk-Event-Viewer, Introduction, Top -@chapter Hello World +@node API Reference, Installation, Introduction, Top +@appendix API Reference -To run the example ``Hello, World!'' program, execute the following -command lines in the @file{src/gtk} directory of your build tree. +This appendix lists all of the procedures and data types that make up +the Gtk interface. + +@menu +* GObject:: +* Pixbuf Loader:: +* Pango Layout:: +* Gtk Object:: +* Gtk Adjustment:: +* Gtk Widget:: +* Gtk Container:: +* Gtk Window:: +* Gtk Label:: +* Gtk Button:: +* Gtk Check Button:: +* Gtk Box:: +* Gtk Frame:: +* Gtk Scrolled Window:: +* Scheme Widget:: +* Fix Layout:: +* Gdk Functions:: +* Debugging Facilities:: +@end menu + +@node GObject, Pixbuf Loader, API Reference, API Reference +@section GObject + +An instance of @bref{} represents a reference to a toolkit +object, typically one created by Scheme. The instance is ``live'' +while Scheme holds the reference. @bref{gobject-unref!} kills it, +releasing Scheme's reference. Once dead to Scheme, the toolkit may +dispose and finalize the GObject. + +Callbacks can be "connected" to gobjects --- one callback per signal +name. The procedures run without-interrupts (or at least +without-preemption). Connecting a second callback disconnects the +first. All connected callbacks are ``pinned'' by the +@code{registered-callbacks} vector; they cannot be GCed until they are +explicitly de-registered. The callback @emph{and} its closure are +pinned. If the closure references the instance, the instance is +pinned and the garbage collector cannot help free the corresponding +toolkit resources. Thus a callback might want to avoid closing over +its instance, use its first parameter to reference the instance, and +have no other visible binding to the instance. + +@anchor{} +@deffn Class +The base class for all toolkit objects. +@end deffn + +@deffn Procedure gobject-alien gobject +The alien address of the toolkit object. This address may be null if +the object has not yet been allocated, or if it is no longer alive. +@end deffn + +@deffn Procedure gobject-live? gobject +#t while @var{gobject} is alive, #f after it has been killed. +@end deffn + +@anchor{gobject-unref!} +@deffn Procedure gobject-unref! gobject +Kills @var{gobject}. Disconnects all signal callbacks and releases +Scheme's reference to the toolkit object. This procedure may be +called multiple times; the reference will only be released once. +@end deffn + +@anchor{g-signal-connect} +@deffn Procedure g-signal-connect gobject alien-function callback +Arrange for @var{callback} to be applied to @var{gobject} and other +arguments whenever @var{gobject} emits the signal with the same name +as @var{alien-function}. @var{alien-function} should be a callback +trampoline, as in this example: @smallexample - ../microcode/scheme --library ../lib - (load-option 'Gtk) - (ge '(gtk)) - (load "hello") - (hello) + (g-signal-connect window (C-callback "delete_event") delete-callback) @end smallexample -Here is the code. +Note that @var{delete-callback} should reference @var{window} via +parameter @emph{only} (per discussion above). +@end deffn -@verbatiminclude ../../src/gtk/hello.scm +@deffn Procedure g-signal-disconnect gobject name +@var{name} should be a string, e.g.: +@smallexample + (g-signal-disconnect window "delete_event") +@end smallexample +@end deffn +The @bref{gobject-get-property} and @bref{gobject-set-properties} +procedures are an attempt to use Glib's introspection facilities to +automatically determine the type of a property's value and construct +an appropriate reflection of its value in Scheme. They have not been +tested @emph{at all}. -@node Gtk-Event-Viewer, Scm-Layout, Hello World, Top -@chapter Gtk-Event-Viewer +@anchor{gobject-get-property} +@deffn Procedure gobject-get-property gobject property +The (default) value of @var{gobject}'s @var{property}. @var{Property} +may be a string or symbol. If there is no such property, an error is +signaled. +@end deffn + +@anchor{gobject-set-properties} +@deffn Procedure gobject-set-properties gobject . property-list +@var{Property-list} should be an even-length list of alternating names +(symbols or strings) and values. +@end deffn + +@anchor{gquark-from-string} +@deffn Procedure gquark-from-string string +The GQuark (integer) associated with @var{string}. +@end deffn + +@deffn Procedure gquark-to-string gquark +The string associated with @var{gquark} (an integer). If @var{gquark} +has not been interned by @bref{gquark-from-string}, an error is +signaled. +@end deffn + +@node Pixbuf Loader, Pango Layout, GObject, API Reference +@section Pixbuf Loader + +A pixbuf loader encapsulates the loading of a pixbuf. The +@bref{load-pixbuf-from-port} procedure can feed data directly from a +Scheme input port into a pixbuf loader, and the loaders various hooks +will notify the user when the pixbuf size is determined, when the +pixbuf is allocated, when areas of the pixbuf have been updated, and +when the pixbuf is complete. + +@deffn Class +A direct subclass of gobject representing a reference to a GdkPixbufLoader. +@end deffn + +@anchor{} +@deffn Class +A direct subclass of gobject representing a reference to a GdkPixbuf. +@end deffn + +@deffn Procedure make-pixbuf-loader +A new pixbuf-loader instance. +@end deffn + +@anchor{load-pixbuf-from-port} +@deffn Procedure load-pixbuf-from-port loader input-port +Initializes @var{loader} and starts a new thread loading from +@var{input-port}. +@end deffn + +@deffn Procedure load-pixbuf-from-file loader filename +Initializes @var{loader} and starts a new thread loading from +@var{filename}. +@end deffn + +@deffn Procedure pixbuf-loader-size-hook loader +#f or the procedure that will be applied to the pixbuf size (two +integers, width and height). +@end deffn + +@deffn Procedure set-pixbuf-loader-size-hook! loader receiver +Arrange for @var{receiver} to be applied to @var{loader}'s pixbuf's +size (two integers, width and height) as soon as it can be determined. +If the size has already been determined, @var{receiver} is applied +immediately. +@end deffn + +@deffn Procedure pixbuf-loader-pixbuf-hook loader +#f or the procedure that will be applied to the pixbuf as soon as it +is allocated. +@end deffn + +@deffn Procedure set-pixbuf-loader-pixbuf-hook! loader receiver +Arrange for @var{receiver} to be applied to @var{loader}'s pixbuf (an +instance of @bref{}) as soon as it is allocated. If the +pixbuf has already been created, @var{receiver} is applied +immediately. +@end deffn + +@deffn Procedure pixbuf-loader-update-hook loader +#f or the procedure that will be applied to areas of the pixbuf +recently updated. +@end deffn + +@deffn Procedure set-pixbuf-loader-update-hook! loader receiver +Arrange for @var{receiver} to be applied to areas of the pixbuf as +they are updated. @var{Receiver} will be applied to four integers --- +the x and y coordinates of the upper-left corner, and width and height +of the updated area. If the pixbuf is complete before @var{receiver} +is set, it will never be called. +@end deffn + +@deffn Procedure pixbuf-loader-close-hook loader +#f or the thunk that will be invoked when loading is complete. +@end deffn + +@deffn Procedure set-pixbuf-loader-close-hook! loader thunk +Arrange for @var{thunk} to be invoked when loading is complete. If +loading is complete before @var{thunk} is set, it will be invoked +immediately. +@end deffn + +@deffn Procedure pixbuf-loader-pixbuf loader +#f or the pixbuf that is loading (or was loaded). +@end deffn + +@deffn Procedure pixbuf-loader-error-message loader +#f or a string describing any error encountered during the loading. +@end deffn + +@node Pango Layout, Gtk Object, Pixbuf Loader, API Reference +@section Pango Layout + +A simple wrapper for PangoLayout objects that ensures the toolkit +object is de-referenced when the instance is garbage collected. + +@deffn Class +A direct subclass of gobject representing a reference to a PangoLayout. +@end deffn + +@deffn Procedure pango-layout-get-context layout +The layout's context, a PangoContext alien. +@end deffn + +@anchor{pango-layout-context-changed} +@deffn Procedure pango-layout-context-changed layout +Re-lays-out @var{layout} according to the (new) state of its context. +@end deffn + +@deffn Procedure pango-layout-get-font-description layout +@var{Layout}'s font description, a PangoFontDescription alien, or a +null alien if the font description from @var{layout}'s context is in +use. The description is owned by the layout and must not be modified +nor freed. +@end deffn + +@deffn Procedure pango-layout-set-font-description layout font +Sets @var{layout}'s default font to @var{font}, a PangoFontDescription +alien. +@end deffn + +@deffn Procedure pango-layout-set-text layout string +Sets @var{layout}'s text to @var{string}. The new text will be laid +out, possibly changing @var{layout}'s dimensions. +@end deffn + +@deffn Procedure pango-layout-get-pixel-extents layout receiver +Applies @var{receiver} to @var{layout}'s width and height. +@end deffn + +@deffn Procedure pango-layout-index-to-pos layout index receiver +Applies @var{receiver} to the x and y coordinates (relative to the +upper-left corner of @var{layout}) and the width and height of the +character at @var{index}. +@end deffn + +@anchor{pango-font-description-from-string} +@deffn Procedure pango-font-description-from-string string +A new PangoFontDescription alien. If it is garbage collected, the +toolkit object will be freed with @bref{pango-font-description-free}. +@end deffn + +@deffn Procedure pango-font-description-to-string font +A string that would parse as @var{font}, a PangoFontDescription alien. +@end deffn + +@anchor{pango-font-description-free} +@deffn Procedure pango-font-description-free font +Frees @var{font}, an alien PangoFontDescription. +@end deffn + +@deffn Procedure pango-context-get-font-description context +The PangoFontDescription alien owned by @var{context}, an alien +PangoContext. +@end deffn + +@deffn Procedure pango-context-set-font-description context font +Sets @var{context}'s PangoFontDescription to a copy of @var{font}. +@end deffn + +@deffn Procedure pango-context-get-metrics context font +A new PangoFontMetrics alien to which Scheme holds a reference. If +the alien is garbage collected, the reference will be released with +@code{pango_font_metric_unref}. +@end deffn + +@deffn Procedure pango-context-spacing context +The space between lines in any up-to-date pango layout using +@var{context}. +@end deffn + +@deffn Procedure pango-font-metrics-get-ascent metrics +The ascent of @var{metrics}, a PangoFontMetrics alien. This is the +distance from the baseline to the highest point of the glyphs of the +font. This is positive in practically all fonts. +@end deffn + +@deffn Procedure pango-font-metrics-get-descent metrics +The descent of @var{metrics}, a PangoFontMetrics alien. This is the +distance from the baseline to the lowest point of the glyphs of the +font. This is positive in practically all fonts. +@end deffn + +@deffn Procedure pango-font-metrics-get-approximate-char-width metrics +The approximate character width of @var{metrics}, a PangoFontMetrics +alien. This is merely a representative value useful, for example, for +determining the initial size for a window. The actual glyphs will be +wider and narrower than this. +@end deffn + +@anchor{pango-font-metrics-unref} +@deffn Procedure pango-font-metrics-unref metrics +Releases Scheme's reference to @var{metrics} with +@code{pango_font_metric_unref}. All operations on @var{metrics} will +thereafter signal an error. +@end deffn + +@node Gtk Object, Gtk Adjustment, Pango Layout, API Reference +@section Gtk Object + +A gtk-object is a gobject that can be "destroyed". Each instance is +connected to the "destroy" signal of its GtkObject. The callback +@bref{gobject-unref!}'s the instance, allowing the toolkit to finalize +and dispose of the GtkObject. + +If a Gtk object is "dropped", never destroyed, eventually GCed, the +usual gobject cleanup will effect a @bref{gobject-unref!} and +(potentially) release the toolkit resources. + +@deffn Class +An abstract, direct subclass of gobject. +@end deffn + +@deffn Procedure gtk-object? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-object object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-object-destroyed? object +#f if @var{object} has not been destroyed. +@end deffn + +@deffn Procedure gtk-object-destroy object +Destroys @var{object}. +@end deffn + +@node Gtk Adjustment, Gtk Widget, Gtk Object, API Reference +@section Gtk Adjustment + +@deffn Class +A direct subclass of gtk-object representing a reference to a GtkAdjustment. +@end deffn + +@deffn Procedure gtk-adjustment? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-adjustment object operator +Type guarantor. +@end deffn + +@deffn Procedure make-gtk-adjustment +A new gtk-adjustment instance. +@end deffn + +@deffn Procedure set-gtk-adjustment! adjustment value lower upper page-size step-incr page-incr +Set the members of a GtkAdjustment and emit the @code{changed} and/or +@code{value_changed} signals. +@table @code +@item value +A real magnitude. +@item lower +The minimum value. +@item upper +The maximum value. +@item step_increment +The increment to use to make minor changes to the value. In a +GtkScrollbar this increment is used when the mouse is clicked on the +arrows at the top and bottom. +@item page_increment +The increment to use to make major changes to the value. In a +GtkScrollbar this increment is used when the mouse is clicked in the +trough. +@item page_size +The page size. In a GtkScrollbar this is the size of the area which +is currently visible. +@end table +@end deffn + +@node Gtk Widget, Gtk Container, Gtk Adjustment, API Reference +@section Gtk Widget + +A Gtk object with a ``parent'' slot. + +@deffn Class +An abstract, direct subclass of gtk-object. +@end deffn + +@deffn Procedure gtk-widget? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-widget object operator +Type guarantor. +@end deffn + +@deffn {Generic Procedure} gtk-widget-parent widget +The parent gtk-container, or #f. +@end deffn + +@subsection Gtk Widget Callbacks + +@deffn Procedure set-gtk-widget-size-allocate-callback! widget callback +Arrange for @var{callback} to be applied to @var{widget} and an alien +GtkAllocation whenever the widget's size changes. Do @emph{not} +capture @var{widget} in @var{callback}'s closure, else it cannot be +GCed. +@end deffn + +@deffn Procedure set-gtk-widget-realize-callback! widget callback +Arrange for @var{callback} to be applied to @var{widget} when it is +realized. Do @emph{not} capture @var{widget} in @var{callback}'s +closure, else it cannot be GCed. +@end deffn + +@deffn Procedure set-gtk-widget-unrealize-callback! widget callback +Arrange for @var{callback} to be applied to @var{widget} when it is +unrealized. Do @emph{not} capture @var{widget} in @var{callback}'s +closure, else it cannot be GCed. +@end deffn + +@deffn Procedure set-gtk-widget-event-callback! widget callback +Arrange for @var{callback} to be applied to @var{widget} and an alien +GdkEvent whenever the widget receives an event. Do @emph{not} capture +@var{widget} in @var{callback}'s closure, else it cannot be GCed. +@end deffn + +@subsection Gtk Widget Operators + +@deffn Procedure gtk-widget-realized? widget +#t if @var{widget} has been realized. +@end deffn + +@deffn Procedure gtk-widget-drawable? widget +#t if @var{widget} can be drawn, i.e. it is mapped and visible. +@end deffn + +@deffn Procedure gtk-widget-grab-focus widget +Causes @var{widget} to have the keyboard focus for the GtkWindow it's +inside. @var{Widget} must be a focusable widget, such as a GtkEntry; +something like a GtkFrame will not work. The widget also needs to be +realized and mapped. Grabbing the focus immediately after creating +the widget will likely fail and cause critical warnings. +@end deffn + +@deffn Procedure gtk-widget-has-focus? widget +#t if @var{widget} has the keyboard. +@end deffn + +@anchor{gtk-widget-is-composited?} +@deffn Procedure gtk-widget-is-composited? widget +#t if @var{widget} has an alpha channel. +@end deffn + +@deffn Procedure gtk-widget-show widget +Indicates @var{widget} is ready to be displayed. If you want to show +all widgets in a container, it is easier to call +@bref{gtk-widget-show-all} on the container. Note that the containers +containing @var{widget} must also be ``shown'' else @var{widget} +cannot be displayed. When a toplevel container is shown, it is +immediately realized and mapped, as well as any descendents that are +``showing''. +@end deffn + +@anchor{gtk-widget-show-all} +@deffn Procedure gtk-widget-show-all widget +Recursively shows @var{widget} all of its children (if any). +@end deffn + +@deffn Procedure gtk-widget-error-bell widget +Notifies the user about an input-related error on @var{widget}. This +may sound a short beep, flash a visual cue associated with +@var{widget}'s toplevel window, or do nothing at all, per user +preference and window manager support. +@end deffn + +@deffn Procedure gtk-widget-queue-draw widget +Schedules a complete re-draw of @var{widget}. (An expose event will be +delivered when the toolkit is idle.) +@end deffn + +@deffn Procedure gtk-widget-get-colormap widget +An alien GdkColormap owned by the toolkit. It should not be freed. +@end deffn + +@deffn Procedure gtk-widget-get-pango-context widget +A PangoContext with the appropriate font map, font description, and +base direction for @var{widget}. This context is owned by +@var{widget} but it can be used until @var{widget}'s screen or +toplevel changes. It will be updated to match changes to +@var{widget}'s attributes. @var{Widget}'s @code{style-set} and +@code{direction-changed} signals indicate when the context has +changed. If you keep a PangoLayout using this default context, the +signal callbacks should apply @bref{pango-layout-context-changed}. +@end deffn + +@deffn Procedure gtk-widget-create-pango-layout widget #!optional text +Creates a new pango-layout with the appropriate font map, font +description, and base direction for drawing text for @var{widget}. +The layout will be empty unless @var{text}, a string, is provided. If +@var{widget}'s base direction or font changes, apply +@bref{pango-layout-context-changed} to re-lay-out the text. +@end deffn + +@anchor{gtk-widget-set-size-request} +@deffn Procedure gtk-widget-set-size-request widget width height +Notify the toolkit of @var{widget}'s natural size. @var{Width} and +@var{height} should be positive. This is just a request. +@var{Widget}'s size-allocate callback will be applied when its size is +initialized or changed. +@end deffn + +@subsection Gtk Widget Colors & Fonts + +@anchor{gtk-widget-parse-color} +@deffn Procedure gtk-widget-parse-color widget spec +The color named by @var{spec} --- a (new!) vector: @code{"#(red green +blue)"}. The elements will be reals and can vary from 0.0 to 1.0 +(inclusive). @var{Spec} should be a string: a standard color name +(e.g. @code{"magenta"}), a hex format number (e.g. @code{"#F0F"}, +@code{"#FF00FF"}, @code{"#FFF000FFF"}, and @code{"#FFFF0000FFFF"}), or +one of @var{widget}'s symbolic color names. A ``standard'' color name +is found in the venerable X11 @file{rgb.txt} file. +@end deffn + +@anchor{gtk-widget-fg-color} +@deffn Procedure gtk-widget-fg-color widget #!optional state +The color used to draw @var{widget} when it is in @var{state} --- a +(new!) vector: #(red green blue). The color components are reals and +can vary from 0.0 to 1.0 inclusive. @var{State} may be one of the +symbols @code{normal}, @code{active}, @code{prelight}, @code{selected} +or @code{insensitive}, and defaults to @code{normal}. +@end deffn + +@deffn Procedure gtk-widget-bg-color widget #!optional state +@var{Widget}'s background color. Similar to +@bref{gtk-widget-fg-color}. +@end deffn + +@deffn Procedure gtk-widget-text-color widget #!optional state +@var{Widget}'s text color --- the foreground color for drawing text. +Similar to @bref{gtk-widget-fg-color}. +@end deffn + +@deffn Procedure gtk-widget-base-color #!optional state +@var{Widget}'s base color --- the background color for drawing text. +Similar to @bref{gtk-widget-fg-color}. +@end deffn + +@anchor{set-gtk-widget-fg-color!} +@deffn Procedure set-gtk-widget-fg-color! widget color #!optional state +Sets the foreground color used to draw @var{widget} when it is in +@var{state}. @var{State} may be one of the symbols @code{normal}, +@code{active}, @code{prelight}, @code{selected} or @code{insensitive}. +It defaults to @code{normal}. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color}. @emph{Note} that the +effect of this procedure on widgets that have @emph{not} been realized +is undefined at best. +@end deffn + +@deffn Procedure set-gtk-widget-bg-color! widget color #!optional state +Sets the background color of @var{widget}. See +@bref{set-gtk-widget-fg-color!}. +@end deffn + +@deffn Procedure set-gtk-widget-text-color! widget color #!optional state +Sets the foreground color used when drawing text in @var{widget}. See +@bref{set-gtk-widget-fg-color!}. +@end deffn + +@deffn Procedure set-gtk-widget-base-color! widget color #!optional state +Sets the background color used when drawing text in @var{widget}. See +@bref{set-gtk-widget-fg-color!}. +@end deffn + +@deffn Procedure gtk-widget-font widget +A PangoFontDescription alien --- a toolkit object owned by +@var{widget}'s style. +@end deffn + +@deffn Procedure set-gtk-widget-font! widget font +Set @var{widget}'s style to use @var{font}, a PangoFontDescription. +@var{Widget} will ref @var{desc}. +@end deffn + +@node Gtk Container, Gtk Window, Gtk Widget, API Reference +@section Gtk Container + +A Gtk widget with a list of ``children''. The list records only the +children that were created and added via this interface. Other +toolkit code may add, remove or re-order children and this list will +not be updated. This should probably be fixed with @code{add} and +@code{remove} signal callbacks. + +@deffn Class +An abstract, direct subclass of gtk-widget. +@end deffn + +@deffn Procedure gtk-container? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-container object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-container-children container +A fresh list of @var{container}'s known children --- those created and +added via this interface. +@end deffn + +@deffn Procedure gtk-bin-child container +The first known child in a container, e.g. the only child of a GtkBin +created via this interface. +@end deffn + +@deffn Procedure gtk-container-add container child +Adds @var{child} to @var{container}. @var{Child} should not already +be in a container. Typically used for GtkBins, where positioning the +child in the container is trivial. When applied to a more complex +container, the results may be unexpected. Consider a more specialized +procedure like @bref{gtk-box-pack-start}. +@end deffn + +@deffn Procedure gtk-container-remove container child +Removes @var{child} from @var{container}. If @var{child} is not in +@var{container}, an error is signaled. If you intend to destroy +@var{child}, you do not need to remove it. +@end deffn + +@deffn Procedure gtk-container-set-border-width container width +Sets the border width of @var{container} to @var{width}. The border +width of a container is the amount of space to leave around the +outside of the container. The only exception to this is Gtk window; +because toplevel windows can't leave space outside, they leave the +space inside. +@end deffn + +@node Gtk Window, Gtk Label, Gtk Container, API Reference +@section Gtk Window + +These objects are not GCed, but held strongly by the +@code{toplevel-windows} list in the @code{(gtk gtk-object)} package. +The toolkit object is a GtkBin, and should have no more than one +child, though this is not enforced, on the Scheme side, yet. + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkWindow. +@end deffn + +@deffn Procedure gtk-window? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-window object operator +Type guarantor. +@end deffn + +@anchor{gtk-window-new} +@deffn Procedure gtk-window-new type +A new gtk-window instance. @var{Type} should be the symbol +@code{toplevel}. It can also be @code{popup}, but the window will not +be managed by the window manager, like a tooltip or popup menu window. +@end deffn + +@deffn Procedure gtk-window-type window +The symbol @code{toplevel}, unless @var{window} is a popup. See +@bref{gtk-window-new}. +@end deffn + +@anchor{gtk-window-set-geometry-hints} +@deffn Procedure gtk-window-set-geometry-hints window widget . hints +Sets @var{window}'s geometry hints. @var{Widget} can be #f or any +widget that is ``showing'' in @var{window} (not just @var{window}'s +immediate child). When specified, the geometry hints are applied to +@var{widget}'s size, sizing @var{window} to account for decorations, +scrollbars, etc. @var{Hints} should be an alist. Values associated +with names (symbols) in the following table will specify certain +resizing constraints. +@table @code +@item min-width min-height +The minimum fixnum dimensions of @var{widget} or @var{window}. -1 +specifies their natural size. Both width @emph{and} height should be +specified. +@item max-width max-height +The maximum dimensions of @var{widget} or @var{window}. +@item base-width base-height width-increment height-increment +Allow dimensions that are N increments greater than a base value, for +non-negative integers N. Both width @emph{and} height, for base and +increment, should be specified --- four fixnums. +@item min-aspect max-aspect +The minimum and maximum aspect ratios (reals). +@item gravity +Keep the specified reference point of each child a constant distance +from the corresponding reference point of the window when it is +resized. The value of this property should be one of these symbols: +@code{north}, @code{northeast}, @code{east}, @code{southeast}, +@code{south}, @code{southwest}, @code{west}, @code{northwest}, or +@code{center}. +@end table +@end deffn + +@deffn Procedure gtk-window-set-title window string +Sets the title of @var{window} to @var{string}. The title of a window +is displayed in its title bar. It should help a user distinguish this +window from other windows they may have open. A good title might +include the application name and current document. +@end deffn + +@deffn Procedure gtk-window-set-opacity window opacity +Request a partially transparent @var{window}. @var{Opacity} can vary +from 0.0 (fully transparent) to 1.0 (fully opaque). On X11 the +request has no effect without a compositing manager. See +@bref{gtk-widget-is-composited?}. Note that setting a window's +opacity after the window has been shown causes it to flicker once on +Windows. +@end deffn + +@anchor{gtk-window-set-default-size} +@deffn Procedure gtk-window-set-default-size window width height +Sets @var{window}'s default size to @var{width} x @var{height}. If +either dimension is -1, the default for that dimension is unset. If a +dimension is 0, it is treated like 1, which means ``as small as +possible'' (which is effectively ``unset''?). With a default size +set, @var{window} may still request a larger size. The final size +will be clamped according to @var{window}'s geometry hints. If +@var{window} has already been shown, this procedure has no effect; it +will not resize @var{window}. +@end deffn + +@deffn Procedure gtk-window-get-default-size window receiver +Applies @var{receiver} to @var{window}'s default width and height. +@end deffn + +@deffn Procedure gtk-window-parse-geometry window string +Returns #f if not on X or @var{string} is not a standard X geometry +string. Otherwise returns #t and sets @var{window}'s user-requested +size and position. An X geometry string is something like +@code{"-0+0"}, meaning ``upper right hand corner''. The X manpage +contains the full details. Note that for this procedure to work +correctly (so that @var{window} is created at its final size and +position --- no moving, resizing, etc.) the window should have any +geometry hints already set, and a "final" size already determined, +i.e. by previously setting any default size(?), and ``showing'' the +toplevel widget. See @bref{gtk-window-set-geometry-hints}. +@end deffn + +@deffn Procedure gtk-window-resize window width height +Resizes @var{window} as if the user had done so, obeying geometry +constraints. @var{width} and @var{height} should be positive fixnums. +When applied before @var{window} is shown for the first time, this +procedure overrides @var{window}'s default size. See +@bref{gtk-window-set-default-size}. + +These come from geometry hints, and a default constraint that windows +not be sized smaller than their natural size. To force @var{window}'s +``natural'' size, apply @bref{gtk-widget-set-size-request}. +@end deffn + +@deffn Procedure gtk-window-present window +Presents @var{window} to the user. This may mean raising the window +in the stacking order, deiconifying it, moving it to the current +desktop, and/or giving it the keyboard focus, possibly dependent on +the user's platform, window manager, and preferences. If window is +hidden, it is shown. +@end deffn + +@deffn Procedure set-gtk-window-delete-event-callback! window callback +Connect @var{callback} to @var{window}'s @code{delete_event} signal. +The signal will apply @var{callback} to @var{window}. Do @emph{not} +capture @var{window} in @var{callback}'s closure, else it cannot be +GCed. +@end deffn + +@node Gtk Label, Gtk Button, Gtk Window, API Reference +@section Gtk Label + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkLabel. +@end deffn + +@deffn Procedure gtk-label? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-label object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-label-new text +A new gtk-label instance. @var{Text}, a string, will be displayed in +the new label. +@end deffn + +@deffn Procedure gtk-label-get-text label +The text of @var{label}. +@end deffn + +@deffn Procedure gtk-label-set-text label string +Sets @var{label}'s text to @var{string}. +@end deffn + +@deffn Procedure gtk-label-set-width-chars label n-chars +Sets @var{label}'s natural size to @var{n-chars}. +@end deffn + +@node Gtk Button, Gtk Check Button, Gtk Label, API Reference +@section Gtk Button + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkButton. +@end deffn + +@deffn Procedure gtk-button? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-button object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-button-new +A new gtk-button instance. +@end deffn + +@deffn Procedure set-gtk-button-clicked-callback! button callback +Connect @var{callback} to @var{button}'s "clicked" signal. The signal +will apply @var{callback} to @var{button}. Do @emph{not} capture +@var{button} in @var{callback}'s closure, else it cannot be GCed. +@end deffn + +@node Gtk Check Button, Gtk Box, Gtk Button, API Reference +@section Gtk Check Button + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkCheckButton. +@end deffn + +@deffn Procedure gtk-check-button? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-check-button object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-check-button-new +A new gtk check button. +@end deffn + +@deffn Procedure gtk-check-button-get-active button +#t if @var{button} is ``on'', #f if it is ``off''. +@end deffn + +@deffn Procedure gtk-check-button-set-active button active? +If @var{active?}, turns @var{button} ``on'', else ``off''. +@end deffn + +@deffn Procedure set-gtk-check-button-toggled-callback! button callback +Connect @var{callback} to @var{button}'s "toggled" signal. The signal +will apply @var{callback} to @var{button}. Do @emph{not} capture +@var{button} in @var{callback}'s closure, else it cannot be GCed. +@end deffn + +@node Gtk Box, Gtk Frame, Gtk Check Button, API Reference +@section Gtk Box + +Gtk boxes can be vboxes or hboxes arranging their children vertically +or horizontally, respectively. + +@anchor{gtk-box-pack-start} +@deffn Procedure gtk-box-pack-start box child expand? fill? padding +Adds @var{child} to @var{box}, packed with reference to the start of +@var{box}, which can be a gtk-vbox or gtk-hbox. If @var{expand?}, the +new child is positioned within a share of any extra space. If +@var{fill?} (and @var{expand?}), the child is allocated the share of +extra space. @var{Padding} is the space around the child, +e.g. between it and its neighbors @emph{and} the edge of the box. +@end deffn + +@deffn Procedure gtk-box-pack-end box child expand? fill? padding +Just like @bref{gtk-box-pack-start}, except @var{child} is packed with +reference to the end of @var{box}. +@end deffn + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkVBox. +@end deffn + +@deffn Procedure gtk-vbox? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-vbox object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-vbox-new homogeneous? spacing +A new gtk-vbox. If @var{homogeneous?} is not #f, all children are +given equal space allocations. @var{Spacing} is the distance between +children. +@end deffn + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkHBox. +@end deffn + +@deffn Procedure gtk-hbox? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-hbox object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-hbox-new homogeneous? spacing +A new gtk-hbox. If @var{homogeneous?} is not #f, all children are +given equal space allocations. @var{Spacing} is the distance between +children. +@end deffn + +@node Gtk Frame, Gtk Scrolled Window, Gtk Box, API Reference +@section Gtk Frame + +A bin with a decorative frame and optional label. + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkFrame. +@end deffn + +@deffn Procedure gtk-frame? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-frame object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-frame-new label +A new gtk frame. @var{Label} should be a string. A null string punts +the label. +@end deffn + +@deffn Procedure gtk-frame-set-shadow-type frame type +@var{Type} should be one of the symbols @code{none}, @code{in}, +@code{out}, @code{etched-in}, or @code{etched-out}. +@end deffn + +@node Gtk Scrolled Window, Scheme Widget, Gtk Frame, API Reference +@section Gtk Scrolled Window + +@deffn Class +A direct subclass of gtk-container representing a reference to a GtkScrolledWindow. +@end deffn + +@deffn Procedure gtk-scrolled-window? object +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-scrolled-window object operator +Type guarantor. +@end deffn + +@deffn Procedure gtk-scrolled-window-new +A new gtk scrolled window. +@end deffn + +@deffn Procedure gtk-scrolled-window-set-policy window horizontal vertical +@var{Horizontal} and @var{vertical} should be one of the symbols +@code{always}, @code{auto} or @code{never}. +@end deffn + +@deffn Procedure gtk-scrolled-window-set-placement window placement +@var{Placement} should be one of the symbols @code{top-left}, +@code{bottom-left}, @code{top-right} or @code{bottom-right}. +@end deffn + +@node Scheme Widget, Fix Layout, Gtk Scrolled Window, API Reference +@section Scheme Widget + +A Scheme widget is a GtkWidget implemented by Scheme. Scheme creates +a ScmWidget toolkit object and connects to its various gsignals, like +@code{size_allocate} and @code{realize}. Its representative in +Scheme, a scm-widget instance, arranges to clean these up if it is +garbage collected, like any other gobject instance. Scheme widgets +have a @code{set_scroll_adjustments} signal, like GtkLayout, allowing +them to be placed in Gtk scrolled windows. + +@deffn Class +A direct subclass of gtk-widget representing a reference to a ScmWidget. +@end deffn + +@deffn Procedure set-scm-widget-set-scroll-adjustments-callback! widget callback +Arranges for @var{callback} to be applied to @var{widget} and the +horizontal and vertical GtkAdjustments (aliens). These need to be +informed of any change to the widget's scroll position. The aliens +will be NULL when the widget's scrollbars are removed. +@end deffn + +@node Fix Layout, Gdk Functions, Scheme Widget, API Reference +@section Fix Layout + +The Gtk system provides a fixnum-centric canvas abstraction based on +the ancient X Window draw requests: XDrawLine, XDrawRectangle, +XDrawArc, etc. A fix-layout is a Scheme widget that uses these +requests to paint (and repaint) a view of a canvas on its GdkWindow. +The canvas is a logical device space; all positions and dimensions are +in fixnum pixels. Thus flonums are rarely needed, and actually +avoided. For a flonum-oriented canvas (with scale, rotate, splines, +etc.), a cairo-layout seems inevitable. + +Just a few types of fix-ink been implemented: line-ink, +rectangle-ink, arc-ink, simple-text-ink, image-ink and +box-ink. The last three are rendered by more modern toolkit +functions, from libraries like Pango and GdkPixbuf. + +Each fix-ink has a position on the canvas and a position in the +drawing's display list. The display list determines the order in +which the inks are (re)drawn. An ink can be drawn in all views or +conditionally, such that it only appears in specific widgets. +Multiple fix-layout widgets can display different views of the same +fix-drawing. -The Gtk system includes a simple Scheme widget, a translation of Havoc -Pennington's GtkEv (from @uref{http://developer.gnome.org/doc/GGAD/, -GGAD}. The widget demonstrates callouts running within callbacks -running within callouts. For example, while calling out to -@code{gdk_window_show_all}, the toolkit calls the Scheme widget's -realize method, which calls out again to @code{gdk_window_new}. +Animation (editing) is supported through the standard Gtk mechanism. +Each change to a drawing ``invalidates'' areas of affected widgets. +The toolkit batches up the damaged areas, repairing them via the +expose event handlers. -To see this widget, execute the following command lines in the -@file{src/gtk} directory of your build tree. +@deffn Class +A direct subclass of scm-widget representing a reference to a ScmWidget. +@end deffn + +@deffn Procedure fix-layout? object +Type predicate. +@end deffn + +@deffn Procedure make-fix-layout width height +A new fix-layout with natural size @var{width} x @var{height}. +@end deffn + +@deffn {Generic Procedure} fix-layout-drawing layout +The fix-drawing displayed in @var{layout}, or #f. +@end deffn + +@anchor{set-fix-layout-drawing!} +@deffn Procedure set-fix-layout-drawing! layout drawing x y +@var{Drawing} must be a fix-drawing. @var{X} and @var{y} are the +integer coordinates of the upper-left corner of the view. They are +required so that the drawing, and the position from which to view it, +are all set in one fell swoop. If @var{layout} is already viewing +@var{drawing}, but at a different position, "move" to that position +--- snap, not scroll. Note that a drawing may only be viewed by +multiple layouts that are on compatible screens. +@end deffn + +@deffn Procedure set-fix-layout-size! layout width height +Sets @var{layout} to the given @var{width} and @var{height}. If +either dimension is -1, that dimension is unset, allowing @var{layout} +to choose a "natural" size --- large enough to lay out the entire +text. If a dimension is 0, it is treated like 1, which means ``as +small as possible'', e.g. one line or one column. +@end deffn + +@deffn Procedure fix-layout-scroll-step layout +A pair: the horizontal and vertical scroll increments. It is shared +with @var{layout}; do not modify it. +@end deffn + +@deffn Procedure set-fix-layout-scroll-step! layout width height +Sets the horizontal and vertical ``step-increments'' to be used by +@var{layout}'s scrollbars. +@end deffn + +@deffn Procedure fix-layout-scroll-to! layout x y +@var{X} and @var{y} are the integer coordinates of the upper-left +corner of @var{layout}'s view of the drawing. If @var{layout} is +already displaying the view at that position, this procedure does +nothing. Else it scrolls @var{layout} to the new position. +@end deffn + +@deffn {Generic Procedure} fix-layout-new-geometry-callback layout +This procedure is called when @var{layout} is resized. +@end deffn + +@deffn {Generic Procedure} fix-layout-realize-callback layout +This procedure is called when @var{layout} is being realized. +@end deffn + +@deffn Procedure set-fix-layout-map-handler! layout handler +Arranges to apply @var{handler} to @var{layout} when it is mapped. +@end deffn + +@deffn Procedure set-fix-layout-unmap-handler! layout handler +Arranges to apply @var{handler} to @var{layout} when it is unmapped. +@end deffn + +@deffn Procedure set-fix-layout-focus-change-handler! layout handler +Arranges to apply @var{handler} to @var{layout} and a boolean value +when it receives a focus change event. The boolean is #t if +@var{layout} is now in focus. +@end deffn + +@deffn Procedure set-fix-layout-visibility-notify-handler! layout handler +Arranges to apply @var{handler} to @var{layout} and a symbol: one of +@code{visible}, @code{partially-obscured} or @code{obscured}. +@end deffn + +@deffn Procedure set-fix-layout-key-press-handler! layout handler +Arranges to apply @var{handler} every time @var{layout} gets a key +press event. @var{Handler} is applied to @var{layout}, a key name, +and a bitmap of char-bits. See @bref{gdk-keyval->name} and +@bref{gdk-key-state->char-bits} for the range of the last two +arguments. +@end deffn + +@anchor{set-fix-layout-motion-handler!} +@deffn Procedure set-fix-layout-motion-handler! layout handler +Arranges to apply @var{handler} every time the mouse moves. +@var{Handler} is applied to @var{layout}, a list of modifiers, and the +x and y coordinates of the pointer in the layout's window (not in the +drawing's coordinates). The modifiers include zero or more of the +symbols +@code{shift}, +@code{lock}, +@code{control}, +@code{mod1}, +@code{mod2}, +@code{mod3}, +@code{mod4}, +@code{mod5}, +@code{button1}, +@code{button2}, +@code{button3}, +@code{button4}, +@code{button5}, +@code{super}, +@code{hyper}, +@code{meta} and +@code{release}. +@end deffn + +@deffn Procedure set-fix-layout-button-handler! layout type handler +Arranges to apply @var{handler} whenever @var{layout} receives a +button event of the specified @var{type} --- one of the symbols +@code{press}, @code{release}, @code{double-press} or +@code{triple-press}. @var{Handler} is applied to @var{layout}, +@var{type}, the button number (a fixnum), the modifiers, and the +coordinates of the pointer. See +@bref{set-fix-layout-motion-handler!}. +@end deffn + +@subsection Fix Drawing + +Fixnum-centric canvas, to which you can affix fix-ink spots. + +@deffn Class +A direct subclass of instance. +@end deffn + +@deffn Procedure make-fix-drawing +A new fix-drawing. +@end deffn + +@deffn Procedure fix-drawing-widgets drawing +A list of fix-layout widgets displaying views of @var{drawing}. This +is shared with @var{drawing}; do not modify it. +@end deffn + +@deffn Procedure set-fix-drawing-size! drawing width height +This is just the scrollable area, used mostly by scrollbars to scale +their thumbs(?). +@end deffn + +@deffn Procedure fix-drawing-pick-list drawing widget x y +A list of fix-inks in @var{drawing}, displayed in @var{widget}, whose +bounding boxes include the point (@var{x}, @var{y}). +@end deffn + +@deffn Procedure fix-drawing-add-ink! drawing ink #!optional where +Adds @var{ink} to the top of the display list for @var{drawing}. If +@var{where} is specified, it should be the symbol @var{top} (or #f), +the symbol @var{bottom}, or an ink already in the display list. When +@var{where} is an ink, @var{ink} is spliced in just under (before) it. +@end deffn + +@subsection Fix Ink + +Abstract class for all inks that can be found in fix-drawings and +rendered on fix-layouts. + +@deffn Class +A direct subclass of instance. +@end deffn + +@deffn Procedure fix-ink? object +Type predicate. +@end deffn + +@deffn {Generic Procedure} fix-ink-drawing ink +@var{Ink}'s fix-drawing, or #f. +@end deffn + +@deffn Procedure fix-ink-widgets ink +The widgets in which @var{ink} should be drawn, #t if it is drawn in +all views. +@end deffn + +@deffn Procedure set-fix-ink-widgets! ink widgets +Draw @var{ink} only in the @var{widgets}. If @var{widgets} is #t, +@var{ink} will appear in all views of the drawing. +@end deffn + +@deffn {Generic Procedure} fix-ink-move! ink dx dy +Moves @var{ink} by the specified x and y offsets. +@end deffn + +@deffn Procedure fix-ink-remove! ink +Removes @var{ink} from its drawing. +@end deffn + +@subsection Draw Ink + +This type of fix-ink is rendered with a @code{gdk_draw_} toolkit +function. + +@deffn Class +A direct subclass of fix-ink. +@end deffn + +@subsection Line Ink + +A draw-ink rendered with @code{gdk_draw_line}. + +@deffn Class +A direct subclass of draw-ink. +@end deffn + +@deffn Procedure line-ink? object +Type predicate. +@end deffn + +@deffn Procedure make-line-ink +A new line-ink. +@end deffn + +@deffn Procedure set-line-ink! line x1 y1 x2 y2 +Set @var{line} to start at (@var{x1},@var{y1}) and end at +(@var{x2},@var{y2}). +@end deffn + +@deffn Procedure line-ink-width line +The width of @var{line}. @code{()} if not set. +@end deffn + +@deffn Procedure set-line-ink-width! line width +@var{Width} should be a small positive integer (fixnum). @var{Line} +will be redrawn unless it is already drawn at the specified width. +@end deffn + +@deffn Procedure line-ink-color line +@code{()} if @var{line}'s color is not set, else the color last +provided to @bref{set-line-ink-color!}. +@end deffn + +@anchor{set-line-ink-color!} +@deffn Procedure set-line-ink-color! line color +Sets @var{line}'s foreground color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{line} might appear. +@end deffn + +@deffn Procedure line-ink-dash-color line +@code{()} if @var{line}'s dash color is not set, else the color last +provided to @bref{set-line-ink-dash-color!}. +@end deffn + +@anchor{set-line-ink-dash-color!} +@deffn Procedure set-line-ink-dash-color! line color +Sets @var{line}'s dash color. @var{Color} can be any string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{line} might appear. This color will appear between the +foreground colored dashes along the line. @var{Color} may also be #t +if the space between dashes should not be drawn, or #f if @var{line} +should be solid. +@end deffn + +@subsection Rectangle Ink + +A draw-ink rendered with @code{gdk_draw_rectangle}. + +@deffn Class +A direct subclass of draw-ink. +@end deffn + +@deffn Procedure rectangle-ink? object +Type predicate. +@end deffn + +@deffn Procedure make-rectangle-ink +A new rectangle-ink. +@end deffn + +@deffn Procedure set-rectangle-ink! rectangle x y width height +Sets the size and position of @var{rectangle}. +@end deffn + +@deffn Procedure rectangle-ink-color rectangle +@code{()} if @var{rectangle}'s line color is not set, else the color +last provided to @bref{set-rectangle-ink-color!}. +@end deffn + +@anchor{set-rectangle-ink-color!} +@deffn Procedure set-rectangle-ink-color! rectangle color +Sets @var{rectangle}'s line color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{rectangle} might appear. This is not the fill color. +@end deffn + +@deffn Procedure rectangle-ink-width rectangle +@code{()} if @var{rectangle}'s line width is not set, else the +width last provided to @bref{set-rectangle-ink-width!}. +@end deffn + +@anchor{set-rectangle-ink-width!} +@deffn Procedure set-rectangle-ink-width! rectangle width +Sets the width of the line used to draw @var{rectangle}'s outline. +@end deffn + +@deffn Procedure rectangle-ink-fill-color rectangle +@code{()} if @var{rectangle}'s fill color is not set, else the +color last provided to @bref{set-rectangle-ink-fill-color!}. +@end deffn + +@anchor{set-rectangle-ink-fill-color!} +@deffn Procedure set-rectangle-ink-fill-color! rectangle color +Sets @var{rectangle}'s fill color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{rectangle} might appear. If @var{color} is #f, @var{rectangle} +is outlined, not filled. +@end deffn + +@subsection Arc Ink + +A draw-ink rendered with @code{gdk_draw_arc}. Its width and height +are the dimensions of the bounding box for the entire ellipse, though +only a portion may be drawn. The portion drawn starts with a +start-angle and ends after a certain amount of sweep-angle. + +@deffn Class +A direct subclass of draw-ink. +@end deffn + +@deffn Procedure arc-ink? object +Type predicate. +@end deffn + +@deffn Procedure make-arc-ink +A new arc-ink. +@end deffn + +@deffn Procedure set-arc-ink! arc x y width height +Sets the position and size of @var{arc}'s entire ellipse. +@end deffn + +@deffn Procedure arc-ink-start-angle arc +@var{Arc}'s start-angle. +@end deffn + +@deffn Procedure set-arc-ink-start-angle! arc degrees +Sets @var{arc}'s start-angle. +@end deffn + +@deffn Procedure arc-ink-sweep-angle arc +@var{Arc}'s sweep-angle. +@end deffn + +@deffn Procedure set-arc-ink-sweep-angle! arc degrees +Sets @var{arc}'s sweep-angle. +@end deffn + +@deffn Procedure arc-ink-color arc +@code{()} if @var{arc}'s line color is not set, else the color last +provided to @bref{set-arc-ink-color!}. +@end deffn + +@anchor{set-arc-ink-color!} +@deffn Procedure set-arc-ink-color! arc color +Sets @var{arc}'s line color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{rectangle} might appear. This is not the fill color. +@end deffn + +@deffn Procedure arc-ink-width arc +@code{()} if @var{arc}'s line width not set, else the width last +provided to @bref{set-arc-ink-width!}. +@end deffn + +@anchor{set-arc-ink-width!} +@deffn Procedure set-arc-ink-width! arc width +Sets the width of the line used to draw @var{arc}. +@end deffn + +@deffn Procedure arc-ink-fill-color arc +@code{()} if @var{arc}'s fill color is not set, else the color last +provided to @bref{set-arc-ink-fill-color!}. +@end deffn + +@anchor{set-arc-ink-fill-color!} +@deffn Procedure set-arc-ink-fill-color! arc color +Sets @var{arc}'s fill color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{arc} might appear. If @var{color} is #f, @var{arc} is not +filled. +@end deffn + +@subsection Text Ink + +A draw-ink rendered with @code{gdk_draw_layout} applied to a +PangoLayout from an abstract ``pango-layout'' slot. + +@deffn Class +An abstract, direct subclass of draw-ink. +@end deffn + +@deffn Procedure text-ink? object +Type predicate. +@end deffn + +@deffn Procedure set-text-ink-position! text x y +Sets the position of the upper left corner of @var{text}, a text-ink. +@end deffn + +@deffn Procedure text-ink-xy-to-index text x y +If (@var{x}, @var{y}) is in @var{text}'s extent, return the index of +the character at that point, else #f. +@end deffn + +@deffn Procedure with-text-ink-grapheme-rect text index receiver +Applies @var{receiver} to the position and size (four fixnums) of the +@var{index}th character in @var{text}'s text. If @var{text} has no +text, this procedure just returns #f; it does not apply +@var{receiver}. It normally returns @var{receiver}'s return value. +@end deffn + +@deffn Procedure text-ink-color text +@code{()} if @var{text}'s color is not set, else the color last +provided to @bref{set-text-ink-color!}. +@end deffn + +@anchor{set-text-ink-color!} +@deffn Procedure set-text-ink-color! text color +Sets @var{text}'s default color. @var{Color} should be a string +acceptable to @bref{gtk-widget-parse-color} for every widget in which +@var{text} might appear. +@end deffn + +@subsection Simple Text Ink + +A text-ink whose abstract pango-layout slot is implemented by an +actual instance slot. + +@deffn Class +A direct subclass of text-ink. +@end deffn + +@deffn Procedure simple-text-ink? object +Type predicate. +@end deffn + +@deffn Procedure make-simple-text-ink +A new simple-text-ink. +@end deffn + +@deffn Procedure simple-text-ink-text ink +@var{Ink}'s text --- a string. +@end deffn + +@deffn Procedure set-simple-text-ink-text! ink widget string +Sets @var{ink}'s text to @var{string}, using @var{widget}'s font and +direction. It is assumed @var{widget} is compatible with all widgets +displaying @var{ink}. See @bref{set-fix-layout-drawing!}. +@end deffn + +@deffn Procedure simple-text-ink-font text +#f or a PangoFontDescription alien. +@end deffn + +@deffn Procedure set-simple-text-ink-font! text font +Sets @var{text}'s pango layout's font to @var{font}. @var{Font} +should be a PangoFontDescription, or a string acceptable to +@bref{pango-font-description-from-string} (e.g. @code{"courier 12"}). +@end deffn + +@subsection Image Ink + +A draw-ink rendered by @code{gdk_draw_pixbuf}. It uses a +pixbuf-loader so that it can render the pixbuf as it loads. + +@deffn Class +A direct subclass of fix-ink. +@end deffn + +@deffn Procedure make-image-ink-from-file filename +A new image-ink whose pixbuf-loader is loading from @var{filename}. +@end deffn + +@deffn Procedure set-image-ink! image x y +Set the position of @var{image} to (@var{x}, @var{y}). +@end deffn + +@subsection Box Ink + +A fix-ink rendered by @code{gtk_paint_box}. + +@deffn Class +A direct subclass of fix-ink. +@end deffn + +@deffn Procedure box-ink? object +Type predicate. +@end deffn + +@deffn Procedure make-box-ink +A new box-ink. +@end deffn + +@deffn Procedure set-box-ink! box x y width height +Resizes @var{box} to @var{width} and @var{height}, and moves it +to (@var{x}, @var{y}). If @var{box} is already at the specified +position and size, this procedure does nothing. +@end deffn + +@deffn Procedure set-box-ink-position! box x y +Moves @var{box} to place its upper-left corner at point (@var{x}, +@var{y}). If @var{box} is already at the specified position, this +procedure does nothing. +@end deffn + +@deffn Procedure box-ink-shadow box +The type of shadow with which @var{box} will be drawn --- one of the +symbols @code{none}, @code{in}, @code{out}, @code{etched-in}, or +@code{etched-out}. +@end deffn + +@deffn Procedure set-box-ink-shadow! box type +Sets @var{box}'s shadow to @var{type}, which should be one of the +symbols @code{none}, @code{in}, @code{out}, @code{etched-in}, or +@code{etched-out}. +@end deffn + +@node Gdk Functions, Debugging Facilities, Fix Layout, API Reference +@section Gdk Functions + +@deffn Procedure gdk-window-process-updates window children-too? +Force expose events to be delivered immediately and synchronously to +@var{window}. This is occasionally useful, e.g. to produce nicer +scrolling behavior. @var{Children-too?} should be #f to avoid +sending expose events to child windows. +@end deffn + +@anchor{gdk-key-state->char-bits} +@deffn Procedure gdk-key-state->char-bits modifier-state +A bitmap of char-bits (char-bit:control, char-bit:meta, +char-bit:super, and char-bit:hyper) corresponding to the bits set in +@var{modifier-state}, a GdkModifierType bitmap from a key or button +event. +@end deffn + +@anchor{gdk-keyval->name} +@deffn Procedure gdk-keyval->name keyval +The key name (character or symbol) associated with the Gdk +@var{keyval}. +@end deffn + +@node Debugging Facilities, , Gdk Functions, API Reference +@section Debugging Facilities + +@deffn Procedure kill-gtk-thread +A convenient procedure to call in an emergency. +@end deffn + +@deffn Procedure gtk-time-slice-window? +#t if the time slice window is open, else #f. +@end deffn + +@deffn Procedure gtk-time-slice-window! open? +If @var{open?} is #f, the time slice window is closed, else it is opened. +@end deffn + +@deffn Procedure gtk-select-trace? +#t if Scheme's GSource is being traced, else #f. +@end deffn + +@deffn Procedure gtk-select-trace! trace? +If @var{trace?} is #t, turns on tracing of Scheme's GSource. +@end deffn + +@node Installation, Implementation Notes, API Reference, Top +@chapter Installation + +If you have a recent version of MIT-Scheme (with C/Unix FFI) +installed, you can build the snapshot with @smallexample - ../microcode/scheme --library ../lib - (load-option 'GTK) - (gtk-event-viewer) + ./configure; make @end smallexample -The code can be found in @file{gtk-ev.scm}. +If your MIT-Scheme does not include the FFI, you will need to install +a version that does, like this: + +@smallexample +./configure --without-gtk +make +make install +@end smallexample +Depending on configuration options and file-system permissions, you +may need super-user privileges to do the installation step. -@node Scm-Layout, GNU Free Documentation License, Gtk-Event-Viewer, Top -@chapter Scm-Layout +To verify your install, check that your @code{mit-scheme} command +invokes a Scheme with the FFI. Execute the following command line. -The Gtk system provides a canvas abstraction --- a logical space in -which items like text or boxes are drawn. This is a logical device -canvas; all positions and dimensions are in integral pixels. The -items are Scheme objects, and are ``drawn'' or ``undrawn'' by adding -or removing them from a @code{}. Each @code{} -has a position on the canvas and a position in the drawing's display -list. That latter determines the order in which the drawn item is -(re)drawn. An item can be drawn in all views or conditionally, such -that it only appears in specific views. +@smallexample + echo "(load-option 'FFI)" | mit-scheme --batch-mode +@end smallexample -A view of a drawing is displayed by a @code{} widget. -Multiple widgets can display different views of a shared drawing. -A @code{} widget is more of a GtkDrawingArea with -scrollbar support than a full-blown GtkLayout at the moment, mainly -because ScmWidget is not a GtkContainer. +If that command completes without complaint, you are ready to -Animation (editing) is supported through the standard Gtk mechanism. -Each change to a drawing ``invalidates'' areas of affected widgets. -The toolkit batches up the damaged areas, repairing them via the -expose event handlers. +@smallexample + make clean; ./configure; make +@end smallexample -There are just a few specializations of @code{} so far: -@code{}, @code{}, @code{}, -@code{} and @code{}. +If this process falters, please feel free to contact the author. -A demo of two @code{} widgets displaying one canvas is -provided. The canvas contains text, horizontal and vertical lines, -and an image. It also contains animated boxes that blink and follow -the mouse. To see these widgets in action, execute the following -command lines in the @file{src/gtk} directory of your build tree. +@node Implementation Notes, GNU Free Documentation License, Installation, Top +@chapter Implementation Notes + +This chapter is for the hapless debugger, or potential widget +developer. It provides an overview of the mechanisms behind the +scenes, like gtk-thread. + +The procedures implementing the API are thin wrappers, trivial +convenience functions that do type checking and conversion, and hide +the details of the C API. For example, a GtkLabel's text is retrieved +in two steps: a toolkit function returns an alien address, and the C +string at that address is copied into the heap. @smallexample - ../microcode/scheme --library ../lib - (load-option 'Gtk) - (scm-layout-demo) + (let ((retval (make-alien '|gchar|))) + (C-call "gtk_label_get_text" retval (gobject-alien label)) + (c-peek-cstring retval)) +@result{} "!dlrow ,olleH" @end smallexample -The code can be found in @file{demo.scm}. +The @code{gtk-label-get-text} wrapper procedure hides these details. + +@smallexample + (gtk-label-get-text label) +@result{} "!dlrow ,olleH" +@end smallexample + +In the example call to @code{gtk-label-get-text} above, a Scheme +object represents the GtkLabel. It is a gtk-label instance, whose +class is a specialization of the abstract gtk-object class. +@unnumberedsec Gtk Thread -@node GNU Free Documentation License, , Scm-Layout, Top +When the Gtk system loads it starts a toolkit main loop with Scheme +attached as an custom idle task. The main loop then re-starts Scheme, +which creates a thread to ``run'' the toolkit (actually, return to +it). Thus Scheme threads multitask with the toolkit. Scheme runs as +an idle task in the toolkit, and the toolkit runs in a Scheme thread. +A program using the Gtk system does not call @code{gtk_init} nor +@code{gtk_main}. It need only create toolkit objects and attach +signal handlers to them. + +@unnumberedsec Toolkit Resource Usage + +Each gobject instance is tracked by the weak alist @code{gc-cleanups}, +so that the toolkit object can be @code{g_object_unref}'ed when the +instance is GCed. + +The initialize-instance method for subclasses of gobject should chain +up early, adding the instance's alien to gc-cleanups @emph{before} +calling out to the toolkit. This ensures that an allocated toolkit +object will not be dropped; its alien address is on the list of GC +cleanups before it is even allocated. @emph{After} the callout, the +method should also @code{g_object_ref_sink} any floating refs it +receives. + +The following scenarios are typical of Gtk resource management. + +Temporary alien: The (alien) address of a PangoFontDescription +is read from a PangoLayout member. The layout ``owns'' the +font description. Scheme does not. The address should only be used +while without-toolkit (or without-interrupts), else the +toolkit may "dispose" of it while Scheme is using it. + +Schemely: A toolkit object is created and reflected in Scheme by a +gobject instance. Scheme owns the toolkit object, holds a reference, +and should eventually @code{g_object_unref} it. The instance may be +shared among any number of Scheme widgets or other data structures +(e.g a file->pixbuf cache) and @emph{never} explicitly ``killed''. +When there are no more Scheme objects sharing the toolkit object, it +will be GCed and its GC cleanup procedure will ``kill'' +(@code{g_object_unref}) the toolkit object. This may release toolkit +resources or not, depending on references elsewhere in the toolkit +data structures. In any case, the instance was GCed so the toolkit +object is dead to Scheme. + +Signals: The @bref{g-signal-connect} procedure takes pains not to hold +a strong reference to a gobject instance. These instances can be GCed +even while signal handlers are connected. The registered callbacks +hold only a weak reference to the instance. It is assumed a callback +will not be invoked after an instance is GCed, else an error should be +signaled. + +TODO: A world save hook might warn of gobject instances still on the +gc-cleanups list. A world restore hook could kill them. + +@node GNU Free Documentation License, , Implementation Notes, Top @appendix GNU Free Documentation License @center Version 1.2, November 2002 diff --git a/src/Makefile.in b/src/Makefile.in index ce3aba870..8b98d676a 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -60,8 +60,8 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs # **** END BOILERPLATE **** -LIARC_BOOT_BUNDLES = compiler cref sf star-parser -LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml $(FFIS) +LIARC_BOOT_BUNDLES = compiler cref sf star-parser ffi +LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin imail sos ssp xml $(FFIS) FFIS = @FFIS@ SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc diff --git a/src/README.txt b/src/README.txt index f6c193233..a1caddc41 100644 --- a/src/README.txt +++ b/src/README.txt @@ -53,9 +53,6 @@ The core subsystem consists of these directories: * "ffi" provides syntax for calling foreign (C) functions and manipulating alien (C) data. -* "gtk" uses the FFI to provide a nice interface to GNOME. Features a - Scheme canvas widget. - The compiler subsystem consists of these three directories: * "sf" contains a program that translates Scheme source code to an @@ -87,6 +84,9 @@ These are miscellaneous extras: * "etc" contains miscellaneous files for building the program. +* "gtk" provides a Schemely interface to GNOME. It features a Scheme + canvas widget and limited SWAT emulation. + * "rcs" is a parser for RCS files. It also contains a program for generating merged log files, in RCS or ChangeLog format, for directory trees under RCS or CVS control. diff --git a/src/Setup.sh b/src/Setup.sh index 16143a8c9..f799a27ae 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -84,6 +84,7 @@ maybe_link lib/edwin ../edwin maybe_link lib/include ../microcode maybe_link lib/optiondb.scm ../etc/optiondb.scm maybe_link lib/runtime ../runtime +maybe_link lib/sos ../sos maybe_link lib/mit-scheme.h ../microcode/pruxffi.h maybe_link lib/ffi ../ffi maybe_link lib/gtk ../gtk diff --git a/src/configure.ac b/src/configure.ac index 77b168cfd..3e8fb8a9e 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -44,9 +44,10 @@ AC_ARG_ENABLE([debugging], : ${enable_debugging='no'} AC_ARG_WITH([gtk], - AS_HELP_STRING([--with-gtk], - [Support the GNOME Toolkits if available [[yes]]])) -: ${with_gtk='yes'} + [AS_HELP_STRING([--with-gtk], + [Support the GNOME Toolkits [[auto]]])], + [], + [with_gtk=auto]) AC_CANONICAL_HOST @@ -102,26 +103,6 @@ directory, which is usually \`/usr/local/lib/mit-scheme-${mit_scheme_native_code AC_MSG_RESULT([yes]) fi -AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) -if test "${with_gtk}" = yes; then - AC_MSG_CHECKING([for gtk]) - if test "${PKG_CONFIG}" != yes; then - AC_MSG_RESULT([no, no pkg-config]) - with_gtk=no - elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \ - --batch-mode /dev/null 2>&1; then - AC_MSG_RESULT([no, no FFI]) - with_gtk=no - else - if pkg-config --exists gtk+-2.0; then - AC_MSG_RESULT([yes]) - FFIS=gtk - else - AC_MSG_RESULT([no, ! pkg-config --exists gtk+2.0]) - fi - fi -fi - AC_SUBST([ALL_TARGET]) AC_SUBST([FFIS]) AC_SUBST([INSTALL_COM]) @@ -145,6 +126,10 @@ AC_CONFIG_SUBDIRS([microcode]) m4_include(microcode/achost.ac) +if test "${with_gtk}" = "yes"; then :; +elif test "${with_gtk}" = "no"; then :; +else echo "Warning: with_gtk is not yes|no: ${with_gtk}"; fi + AC_SUBST([CCLD]) AC_SUBST([DEFS]) AC_SUBST([CFLAGS]) @@ -170,8 +155,9 @@ win32/Makefile xdoc/Makefile xml/Makefile ]) -if test "${with_gtk}" = yes; then +if test "${with_gtk}" = "yes"; then AC_CONFIG_FILES([gtk/Makefile]) + FFIS="${FFIS} gtk" fi AC_OUTPUT @@ -184,7 +170,7 @@ if test x"${mit_scheme_native_code}" = xc; then (cd lib; rm -f ${BN}; ${LN_S} ../${BN} .) done BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml" - if test x"${with_gtk}" = xyes; then BUNDLES="$BUNDLES gtk"; fi + if test "${with_gtk}" = yes; then BUNDLES="$BUNDLES gtk"; fi for BUNDLE in $BUNDLES; do SO=${BUNDLE}.so (cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .) diff --git a/src/cref/object.scm b/src/cref/object.scm index 77829b06f..92e5eb31e 100644 --- a/src/cref/object.scm +++ b/src/cref/object.scm @@ -36,7 +36,8 @@ USA. (initializations '()) (finalizations '()) (exports '()) - (imports '())) + (imports '()) + (depends-on '())) (define-structure (pmodel (conc-name pmodel/)) (root-package #f read-only #t) @@ -44,6 +45,7 @@ USA. (packages #f read-only #t) (extra-packages #f read-only #t) (loads #f read-only #t) + (declarations #f read-only #t) (pathname #f read-only #t)) (define-structure (package @@ -60,7 +62,8 @@ USA. (children '()) (bindings (make-rb-tree eq? symbolpmodel packages @@ -55,12 +55,13 @@ USA. (warn "Can't find package-description file:" pathname) #f))))) globals) + declares model-pathname)))) (define (sort-descriptions descriptions) (letrec ((loop - (lambda (descriptions packages extensions loads globals) + (lambda (descriptions packages extensions loads globals declares) (if (pair? descriptions) (let ((description (car descriptions)) (descriptions (cdr descriptions))) @@ -72,7 +73,8 @@ USA. (if (interesting-package-to-load? (cdr description)) (cons (cdr description) loads) loads) - globals)) + globals + declares)) ((EXTEND-PACKAGE) (loop descriptions packages @@ -80,30 +82,42 @@ USA. (if (interesting-package-to-load? (cdr description)) (cons (cdr description) loads) loads) - globals)) + globals + declares)) ((GLOBAL-DEFINITIONS) (loop descriptions packages extensions loads - (append! (reverse (cdr description)) globals))) + (append! (reverse (cdr description)) globals) + declares)) + ((DECLARE) + (loop descriptions + packages + extensions + loads + globals + (append! (reverse (cdr description)) declares))) ((NESTED-DESCRIPTIONS) - (receive (packages extensions loads globals) + (receive (packages extensions loads globals declares) (loop (cdr description) packages extensions loads - globals) - (loop descriptions packages extensions loads globals))) + globals + declares) + (loop descriptions packages extensions loads + globals declares))) (else (error "Unknown description keyword:" (car description))))) - (values packages extensions loads globals))))) - (receive (packages extensions loads globals) - (loop descriptions '() '() '() '()) + (values packages extensions loads globals declares))))) + (receive (packages extensions loads globals declares) + (loop descriptions '() '() '() '() '()) (values (reverse! packages) (reverse! extensions) (reverse! loads) - (reverse! globals))))) + (reverse! globals) + (reverse! declares))))) (define (interesting-package-to-load? description) (or (pair? (package-description/file-cases description)) @@ -296,6 +310,7 @@ USA. (merge-pathnames filename pathname) os-type)) filenames)))) + ((DECLARE) expression) (else (lose))))) @@ -372,6 +387,13 @@ USA. package (append! (package-description/finalizations package) (list finalization)))))) + ((DEPENDS-ON) + (if (not (check-list (cdr option) string?)) + (error "illegal dependencies" option)) + (set-package-description/depends-on! + package + (append! (package-description/depends-on package) + (map parse-filename (cdr option))))) (else (error "Unrecognized option keyword:" (car option))))) options)) @@ -436,7 +458,8 @@ USA. ;;;; Packages -(define (descriptions->pmodel descriptions extensions loads globals pathname) +(define (descriptions->pmodel descriptions extensions loads + globals declares pathname) (let ((packages (map (lambda (description) (make-package (package-description/name description) 'UNKNOWN)) @@ -496,6 +519,7 @@ USA. #f) package)) loads) + declares pathname))))) (define (process-globals-info file namestring get-package) @@ -581,6 +605,10 @@ USA. (append-map! (lambda (file-case) (append-map cdr (cdr file-case))) file-cases)))) + (let ((dependencies (package-description/depends-on description))) + (set-package/depends-on! + package + (append! (package/depends-on package) (list-copy dependencies)))) (for-each (lambda (export) (let ((destination (get-package (car export) #t))) (for-each (lambda (names) diff --git a/src/etc/compile.scm b/src/etc/compile.scm index e185f69bb..d357af6f0 100644 --- a/src/etc/compile.scm +++ b/src/etc/compile.scm @@ -37,11 +37,17 @@ USA. (with-working-directory-pathname "sos" (lambda () (load "load"))) - (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi"))) + (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp"))) + +(define (compile-ffi dir) + (if (eq? microcode-id/compiled-code-type 'C) + (c-compile-dir dir) + (compile-dir dir))) (define (compile-boot-dirs compile-dir) (compile-cref compile-dir) - (for-each compile-dir '("runtime" "cref" "sf" "compiler" "star-parser"))) + (for-each compile-dir + '("runtime" "cref" "sf" "compiler" "star-parser" "ffi"))) (define (compile-cref compile-dir) (compile-dir "cref") diff --git a/src/etc/functions.sh b/src/etc/functions.sh index 1cb0d19ae..ccfca4751 100644 --- a/src/etc/functions.sh +++ b/src/etc/functions.sh @@ -103,12 +103,12 @@ maybe_rm () FILES= DIRS= for FN in "${@}"; do - if [ ! -L "${FN}" ]; then - if [ -f "${FN}" ]; then - FILES="${FILES} ${FN}" - elif [ -d "${FN}" ]; then - DIRS="${DIRS} ${FN}" - fi + if [ -L "${FN}" ]; then + FILES="${FILES} ${FN}" + elif [ -f "${FN}" ]; then + FILES="${FILES} ${FN}" + elif [ -d "${FN}" ]; then + DIRS="${DIRS} ${FN}" fi done if [ "${FILES}" ]; then diff --git a/src/gtk/.gitignore b/src/gtk/.gitignore index 88d07585f..83b7298da 100644 --- a/src/gtk/.gitignore +++ b/src/gtk/.gitignore @@ -4,3 +4,4 @@ gtk-const.scm gtk-shim.c gtk-shim.so scmwidget.c +swat-pole-zero.scm diff --git a/src/gtk/Clean.sh b/src/gtk/Clean.sh index 12cb27e30..2775a1d74 100755 --- a/src/gtk/Clean.sh +++ b/src/gtk/Clean.sh @@ -10,7 +10,7 @@ fi ../etc/Clean.sh "${1}" . ../etc/functions.sh -maybe_rm gtk-shim.c gtk-const* gtk-types* +maybe_rm gtk-shim.c gtk-const* gtk-types* swat-pole-zero* maybe_rm ../lib/conses.png maybe_rm ../lib/gtk-* ../lib/prgtkio.so # And, just because the maintainer- and c-clean targets nail this one anyway: diff --git a/src/gtk/Includes/gdk.cdecl b/src/gtk/Includes/gdk.cdecl index 18e1e62f5..7bc7cbd4d 100644 --- a/src/gtk/Includes/gdk.cdecl +++ b/src/gtk/Includes/gdk.cdecl @@ -14,7 +14,7 @@ gtk-2.0/gdk/gdk.h |# (include "gparamspecs") (include "gsignal") -;(include "gdkcairo") +(include "gdkcairo") (include "gdkcolor") (include "gdkcursor") ;(include "gdkdisplay") @@ -38,7 +38,7 @@ gtk-2.0/gdk/gdk.h |# ;(include "gdkselection") ;(include "gdkspawn") (include "gdktypes") -;(include "gdkvisual") +(include "gdkvisual") (include "gdkwindow") (extern gboolean gdk_rectangle_intersect diff --git a/src/gtk/Includes/gdkcairo.cdecl b/src/gtk/Includes/gdkcairo.cdecl new file mode 100644 index 000000000..1b61ecb89 --- /dev/null +++ b/src/gtk/Includes/gdkcairo.cdecl @@ -0,0 +1,34 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkcairo.h |# + +(include "gdkcolor") +;(include "gdkpixbuf") +(include "pangocairo") + +(extern (* cairo_t) gdk_cairo_create + (drawable (* GdkDrawable))) +#;(extern void gdk_cairo_reset_clip + (cr (* cairo_t)) + (drawable (* GdkDrawable))) + +#;(extern void gdk_cairo_set_source_color + (cr (* cairo_t)) + (color (const (* GdkColor)))) +#;(extern void gdk_cairo_set_source_pixbuf + (cr (* cairo_t)) + (pixbuf (const (* GdkPixbuf))) + (pixbuf_x double) + (pixbuf_y double)) +#;(extern void gdk_cairo_set_source_pixmap + (cr (* cairo_t)) + (pixmap (* GdkPixmap)) + (pixmap_x double) + (pixmap_y double)) + +#;(extern void gdk_cairo_rectangle + (cr (* cairo_t)) + (rectangle (const (* GdkRectangle)))) +#;(extern void gdk_cairo_region + (cr (* cairo_t)) + (region (const (* GdkRegion)))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkdrawable.cdecl b/src/gtk/Includes/gdkdrawable.cdecl index 60777c2df..934379505 100644 --- a/src/gtk/Includes/gdkdrawable.cdecl +++ b/src/gtk/Includes/gdkdrawable.cdecl @@ -2,11 +2,11 @@ gtk-2.0/gdk/gdkdrawable.h |# -;(include "gdktypes") -;(include "gdkgc") -;(include "gdkrgb") -;(include "gdk-pixbuf") -;(include "cairo") +(include "gdktypes") +(include "gdkgc") +(include "gdkrgb") +(include "gdk-pixbuf") +(include "cairo") (typedef GdkDrawableClass (struct _GdkDrawableClass)) (typedef GdkTrapezoid (struct _GdkTrapezoid)) @@ -57,7 +57,13 @@ gtk-2.0/gdk/gdkdrawable.h |# (x12 double) (x22 double)) -(extern void gdk_draw_rectangle +(extern void gdk_draw_line ;gtk-2.20.1 + (drawable (* GdkDrawable)) + (gc (* GdkGC)) + (x1 gint) (y1 gint) + (x2 gint) (y2 gint)) + +(extern void gdk_draw_rectangle ;gtk-2.20.1 (drawable (* GdkDrawable)) (gc (* GdkGC)) (filled gboolean) @@ -66,6 +72,23 @@ gtk-2.0/gdk/gdkdrawable.h |# (width gint) (height gint)) +(extern void gdk_draw_arc ;gtk-2.20.1 + (drawable (* GdkDrawable)) + (gc (* GdkGC)) + (filled gboolean) + (x gint) + (y gint) + (width gint) + (height gint) + (angle1 gint) + (angle2 gint)) + +(extern void gdk_draw_layout + (drawable (* GdkDrawable)) + (gc (* GdkGC)) + (x gint) (y gint) + (layout (* PangoLayout))) + (extern void gdk_draw_pixbuf (drawable (* GdkDrawable)) (gc (* GdkGC)) diff --git a/src/gtk/Includes/gdkgc.cdecl b/src/gtk/Includes/gdkgc.cdecl index 1aa8f0876..308ae31af 100644 --- a/src/gtk/Includes/gdkgc.cdecl +++ b/src/gtk/Includes/gdkgc.cdecl @@ -2,8 +2,8 @@ gtk-2.0/gdk/gdkgc.h |# -;(include "gdkcolor") -;(include "gdktypes") +(include "gdkcolor") +(include "gdktypes") (typedef GdkGCValues (struct _GdkGCValues)) (typedef GdkGCClass (struct _GdkGCClass)) @@ -110,12 +110,12 @@ gtk-2.0/gdk/gdkgc.h |# (struct _GdkGCClass (parent_class GObjectClass) (get_values (* (function void - (gc (* GdkGC)) + (gc (* GdkGC)) (values (* GdkGCValues))))) (set_values (* (function void - (GdkGC *gc) - (GdkGCValues *values) - (GdkGCValuesMask mask)))) + (gc (* GdkGC)) + (values (* GdkGCValues)) + (mask GdkGCValuesMask)))) (set_dashes (* (function void (gc (* GdkGC)) (dash_offset gint) @@ -135,9 +135,9 @@ gtk-2.0/gdk/gdkgc.h |# ; (drawable (* GdkDrawable)) ; (values (* GdkGCValues)) ; (values_mask GdkGCValuesMask)) -;(extern void gdk_gc_get_values -; (gc (* GdkGC)) -; (values (* GdkGCValues))) +(extern void gdk_gc_get_values + (gc (* GdkGC)) + (values (* GdkGCValues))) ;(extern void gdk_gc_set_values ; (gc (* GdkGC)) ; (values (* GdkGCValues)) diff --git a/src/gtk/Includes/gdkrgb.cdecl b/src/gtk/Includes/gdkrgb.cdecl index 70cf9516c..1fd29f421 100644 --- a/src/gtk/Includes/gdkrgb.cdecl +++ b/src/gtk/Includes/gdkrgb.cdecl @@ -6,4 +6,8 @@ gtk-2.0/gdk/gdkrgb.h |# (enum (GDK_RGB_DITHER_NONE) (GDK_RGB_DITHER_NORMAL) - (GDK_RGB_DITHER_MAX))) \ No newline at end of file + (GDK_RGB_DITHER_MAX))) + +(extern void gdk_rgb_find_color ;gtk+-2.8.20 + (colormap (* GdkColormap)) + (color (* GdkColor))) \ No newline at end of file diff --git a/src/gtk/Includes/gdktypes.cdecl b/src/gtk/Includes/gdktypes.cdecl index 58ef7c44c..f54a9799c 100644 --- a/src/gtk/Includes/gdktypes.cdecl +++ b/src/gtk/Includes/gdktypes.cdecl @@ -25,10 +25,10 @@ gtk-2.0/gdk/gdktypes.h |# (typedef GdkColormap (struct _GdkColormap)) (typedef GdkCursor (struct _GdkCursor)) ;(typedef GdkFont (struct _GdkFont)) -;(typedef GdkGC (struct _GdkGC)) +(typedef GdkGC (struct _GdkGC)) ;(typedef GdkImage (struct _GdkImage)) ;(typedef GdkRegion (struct _GdkRegion)) -;(typedef GdkVisual (struct _GdkVisual)) +(typedef GdkVisual (struct _GdkVisual)) (typedef GdkDrawable (struct _GdkDrawable)) (typedef GdkBitmap (struct _GdkDrawable)) @@ -37,6 +37,11 @@ gtk-2.0/gdk/gdktypes.h |# ;(typedef GdkDisplay (struct _GdkDisplay)) ;(typedef GdkScreen (struct _GdkScreen)) +(typedef GdkByteOrder + (enum + (GDK_LSB_FIRST) + (GDK_MSB_FIRST))) + (typedef GdkModifierType (enum (GDK_SHIFT_MASK) diff --git a/src/gtk/Includes/gdkvisual.cdecl b/src/gtk/Includes/gdkvisual.cdecl new file mode 100644 index 000000000..569d4c610 --- /dev/null +++ b/src/gtk/Includes/gdkvisual.cdecl @@ -0,0 +1,34 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkvisual.h |# + +(include "gdktypes") + +(typedef GdkVisualType + (enum + (GDK_VISUAL_STATIC_GRAY) + (GDK_VISUAL_GRAYSCALE) + (GDK_VISUAL_STATIC_COLOR) + (GDK_VISUAL_PSEUDO_COLOR) + (GDK_VISUAL_TRUE_COLOR) + (GDK_VISUAL_DIRECT_COLOR))) + +(struct _GdkVisual + (parent_instance GObject) + (type GdkVisualType) + (depth gint) + (byte_order GdkByteOrder) + (colormap_size gint) + (bits_per_rgb gint) + + (red_mask guint32) + (red_shift gint) + (red_prec gint) + + (green_mask guint32) + (green_shift gint) + (green_prec gint) + + (blue_mask guint32) + (blue_shift gint) + (blue_prec gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl index de51593bf..79be93b02 100644 --- a/src/gtk/Includes/gdkwindow.cdecl +++ b/src/gtk/Includes/gdkwindow.cdecl @@ -2,9 +2,9 @@ gtk-2.0/gdk/gdkwindow.h |# -;(include "gdkdrawable") -;(include "gdktypes") -;(include "gdkevents") +(include "gdkdrawable") +(include "gdktypes") +(include "gdkevents") (typedef GdkGeometry (struct _GdkGeometry)) (typedef GdkWindowAttr (struct _GdkWindowAttr)) diff --git a/src/gtk/Includes/gtk.cdecl b/src/gtk/Includes/gtk.cdecl index 15b2b06de..3821478a6 100644 --- a/src/gtk/Includes/gtk.cdecl +++ b/src/gtk/Includes/gtk.cdecl @@ -57,12 +57,12 @@ gtk-2.0/gtk/gtk.h |# ;(include "gtkfilechooserwidget") ;(include "gtkfontbutton") ;(include "gtkfontsel") -;(include "gtkframe") +(include "gtkframe") ;(include "gtkgamma") -;(include "gtkgc") +(include "gtkgc") ;(include "gtkhandlebox") ;(include "gtkhbbox") -;(include "gtkhbox") +(include "gtkhbox") ;(include "gtkhpaned") ;(include "gtkhruler") ;(include "gtkhscale") @@ -80,7 +80,7 @@ gtk-2.0/gtk/gtk.h |# ;(include "gtkinvisible") ;(include "gtkitem") ;(include "gtkitemfactory") -;(include "gtklabel") +(include "gtklabel") ;(include "gtklayout") ;(include "gtklist") ;(include "gtklistitem") diff --git a/src/gtk/Includes/gtkframe.cdecl b/src/gtk/Includes/gtkframe.cdecl new file mode 100644 index 000000000..a05063f90 --- /dev/null +++ b/src/gtk/Includes/gtkframe.cdecl @@ -0,0 +1,15 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkframe.h |# + +;(include "gtkbin") + + +(extern (* GtkWidget) + gtk_frame_new + (label (* (const gchar)))) + +(extern void + gtk_frame_set_shadow_type + (frame (* GtkFrame)) + (type GtkShadowType)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkgc.cdecl b/src/gtk/Includes/gtkgc.cdecl new file mode 100644 index 000000000..97140f22a --- /dev/null +++ b/src/gtk/Includes/gtkgc.cdecl @@ -0,0 +1,12 @@ +#| -*-Scheme-*- + +gtk+-2.20.1/gtk/gtkgc.h |# + +(extern (* GdkGC) gtk_gc_get + (depth gint) + (colormap (* GdkColormap)) + (values (* GdkGCValues)) + (values_mask GdkGCValuesMask)) + +(extern void gtk_gc_release + (gc (* GdkGC))) diff --git a/src/gtk/Includes/gtkhbox.cdecl b/src/gtk/Includes/gtkhbox.cdecl new file mode 100644 index 000000000..96b7e7c6e --- /dev/null +++ b/src/gtk/Includes/gtkhbox.cdecl @@ -0,0 +1,8 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkhbox.h |# + +(extern (* GtkWidget) + gtk_hbox_new + (homogeneous gboolean) + (spacing gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gtklabel.cdecl b/src/gtk/Includes/gtklabel.cdecl new file mode 100644 index 000000000..e77e135aa --- /dev/null +++ b/src/gtk/Includes/gtklabel.cdecl @@ -0,0 +1,23 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtklabel.h |# + +;(include "gtkmisc") +(include "gtkwindow") +;(include "gtkmenu") + +(extern (* GtkWidget) + gtk_label_new + (str (* (const char)))) + +(extern (* (const gchar)) + gtk_label_get_text + (label (* GtkLabel))) + +(extern void gtk_label_set_text + (label (* GtkLabel)) + (str (* (const char)))) + +(extern void gtk_label_set_width_chars + (label (* GtkLabel)) + (n_chars gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkobject.cdecl b/src/gtk/Includes/gtkobject.cdecl index a55788d19..7eb1df5fb 100644 --- a/src/gtk/Includes/gtkobject.cdecl +++ b/src/gtk/Includes/gtkobject.cdecl @@ -17,6 +17,7 @@ gtk-2.0/gtk/gtkobject.h |# (struct _GtkObject (parent_instance GObject) + ;; GtkWidgetFlags share these 32bits. (flags guint32)) (struct _GtkObjectClass diff --git a/src/gtk/Includes/gtkstyle.cdecl b/src/gtk/Includes/gtkstyle.cdecl index bb78ee4bf..214aa66e8 100644 --- a/src/gtk/Includes/gtkstyle.cdecl +++ b/src/gtk/Includes/gtkstyle.cdecl @@ -68,7 +68,7 @@ gtk-2.0/gtk/gtkstyle.h |# (color_name (const (* gchar))) (color (* GdkColor))) -(extern void gtk_paint_hline +#;(extern void gtk_paint_hline (style (* GtkStyle)) (window (* GdkWindow)) (state_type GtkStateType) @@ -79,7 +79,7 @@ gtk-2.0/gtk/gtkstyle.h |# (x2 gint) (y gint)) -(extern void gtk_paint_vline +#;(extern void gtk_paint_vline (style (* GtkStyle)) (window (* GdkWindow)) (state_type GtkStateType) diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl index d3ea4f3b8..e39b7fb14 100644 --- a/src/gtk/Includes/gtkwidget.cdecl +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -2,11 +2,11 @@ gtk-2.0/gtk/gtkwidget.h |# -;(include "gdk") +(include "gdk") ;(include "gtkaccelgroup") -;(include "gtkobject") -;(include "gtkadjustment") -;(include "gtkstyle") +(include "gtkobject") +(include "gtkadjustment") +(include "gtkstyle") ;(include "gtksettings") ;(include "atkobject") @@ -289,6 +289,9 @@ gtk-2.0/gtk/gtkwidget.h |# (extern void gtk_widget_destroy (widget (* GtkWidget))) +(extern void gtk_widget_show + (widget (* GtkWidget))) + (extern void gtk_widget_show_all (widget (* GtkWidget))) @@ -302,12 +305,31 @@ gtk-2.0/gtk/gtkwidget.h |# (width gint) (height gint)) +(extern void gtk_widget_queue_resize + (widget (* GtkWidget))) + +(extern void gtk_widget_set_can_focus + (widget (* GtkWidget)) + (can_focus gboolean)) + (extern void gtk_widget_grab_focus (widget (* GtkWidget))) +(extern void gtk_widget_set_has_window + (widget (* GtkWidget)) + (has_window gboolean)) + +(extern void gtk_widget_set_realized + (widget (* GtkWidget)) + (realized gboolean)) + (extern (* GdkWindow) gtk_widget_get_parent_window (widget (* GtkWidget))) +(extern void gtk_widget_set_window + (widget (* GtkWidget)) + (window (* GdkWindow))) + (extern void gtk_widget_error_bell (widget (* GtkWidget))) @@ -318,8 +340,13 @@ gtk-2.0/gtk/gtkwidget.h |# (extern (* GdkColormap) gtk_widget_get_colormap (widget (* GtkWidget))) -(extern (* GdkVisual) gtk_widget_get_visual - (widget (* GtkWidget))) + +;;(extern (* GdkVisual) gtk_widget_get_visual +;; (widget (* GtkWidget))) + +;;(extern void gtk_widget_set_colormap +;; (widget (* GtkWidget)) +;; (colormap (* GdkColormap))) (extern gint gtk_widget_get_events (widget (* GtkWidget))) @@ -337,26 +364,6 @@ gtk-2.0/gtk/gtkwidget.h |# gtk_widget_get_modifier_style (widget (* GtkWidget))) -(extern void gtk_widget_modify_fg - (widget (* GtkWidget)) - (state GtkStateType) - (color (* (const GdkColor)))) - -(extern void gtk_widget_modify_bg - (widget (* GtkWidget)) - (state GtkStateType) - (color (* (const GdkColor)))) - -(extern void gtk_widget_modify_text - (widget (* GtkWidget)) - (state GtkStateType) - (color (* (const GdkColor)))) - -(extern void gtk_widget_modify_base - (widget (* GtkWidget)) - (state GtkStateType) - (color (* (const GdkColor)))) - (extern (* PangoContext) gtk_widget_get_pango_context (widget (* GtkWidget))) diff --git a/src/gtk/Includes/gtkwindow.cdecl b/src/gtk/Includes/gtkwindow.cdecl index f5935d99a..7738691ac 100644 --- a/src/gtk/Includes/gtkwindow.cdecl +++ b/src/gtk/Includes/gtkwindow.cdecl @@ -20,6 +20,15 @@ gtk-2.0/gtk/gtkwindow.h |# (window (* GtkWindow)) (title (* (const gchar)))) +(extern void + gtk_window_set_opacity + (window (* GtkWindow)) + (opacity gdouble)) + +(extern gdouble + gtk_window_get_opacity + (window (* GtkWindow))) + (extern void gtk_window_set_geometry_hints (window (* GtkWindow)) diff --git a/src/gtk/Includes/pango-font.cdecl b/src/gtk/Includes/pango-font.cdecl index 9406818ec..597d8297a 100644 --- a/src/gtk/Includes/pango-font.cdecl +++ b/src/gtk/Includes/pango-font.cdecl @@ -63,6 +63,10 @@ pango-1.0/pango/pango-font.h |# (extern void pango_font_description_free (desc (* PangoFontDescription))) +(extern (* PangoFontDescription) + pango_font_description_copy + (desc (* (const PangoFontDescription)))) + (extern (* PangoFontDescription) pango_font_description_from_string (str (* (const char)))) diff --git a/src/gtk/Includes/pango-layout.cdecl b/src/gtk/Includes/pango-layout.cdecl index c98d2c026..7f4b404c9 100644 --- a/src/gtk/Includes/pango-layout.cdecl +++ b/src/gtk/Includes/pango-layout.cdecl @@ -39,6 +39,9 @@ pango-1.0/pango/pango-layout.h |# (ink_rect (* PangoRectangle)) (logical_rect (* PangoRectangle))) +(extern void pango_layout_context_changed + (layout (* PangoLayout))) + (extern void pango_layout_index_to_pos (layout (* PangoLayout)) (index int) diff --git a/src/gtk/Makefile-fragment b/src/gtk/Makefile-fragment index bba22b6b0..0d25bf679 100644 --- a/src/gtk/Makefile-fragment +++ b/src/gtk/Makefile-fragment @@ -3,6 +3,8 @@ TARGET_DIR = $(AUXDIR)/gtk +MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ + generate: ../lib/gtk-shim.so ../lib/gtk-types.bin ../lib/gtk-const.bin \ ../lib/conses.png @@ -19,8 +21,13 @@ generate: ../lib/gtk-shim.so ../lib/gtk-types.bin ../lib/gtk-const.bin \ $(INSTALL_DATA) conses.png $@ build: - echo '(load "gtk.sf")(load "gtk.cbf")' \ - | ../microcode/scheme --library ../lib --compiler --batch-mode + if [ ! -e swat-pole-zero.scm ]; then \ + ln -sf ../swat/scheme/other/pole-zero.scm swat-pole-zero.scm; fi + cd ../; echo '(load "etc/compile.scm")(compile-ffi "gtk")' \ + | microcode/scheme --library lib --batch-mode + +liarc-build: + $(MAKE) compile-liarc-bundle gtk install: rm -rf $(DESTDIR)$(TARGET_DIR) @@ -48,10 +55,10 @@ gtk-shim.o: gtk-shim.c gtk-shim.h ../lib/mit-scheme.h gtk-shim.c gtk-const.c gtk-types.bin: gtk.cdecl Includes/*.cdecl (echo "(load-option 'FFI)"; \ echo '(C-generate "gtk" "#include \"gtk-shim.h\"")') \ - | mit-scheme --batch-mode + | $(MIT_SCHEME_EXE) --batch-mode gtk-const.bin: gtk-const.scm - echo '(sf "gtk-const")' | mit-scheme --compiler --batch-mode + echo '(sf "gtk-const")' | $(MIT_SCHEME_EXE) --batch-mode gtk-const.scm: gtk-const ./gtk-const diff --git a/src/gtk/demo.scm b/src/gtk/demo.scm deleted file mode 100644 index c2fc847b8..000000000 --- a/src/gtk/demo.scm +++ /dev/null @@ -1,197 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; A small drawing in two scm-layout widgets. -;;; package: (gtk demo) - -(define (scm-layout-demo) - (let* ((window (gtk-window-new 'toplevel)) - (vbox (gtk-vbox-new #t 0)) - (scroller1 (gtk-scrolled-window-new)) - (scroller2 (gtk-scrolled-window-new)) - (layout1 (demo-layout-new 200 200)) - (layout2 (demo-layout-new 200 200))) - (gtk-window-set-title window "scm-layout-demo") - (gtk-window-set-default-size window 200 400) - (set-gtk-window-delete-event-callback! - window (lambda () (outf-console "; Closed "window".\n") 0)) - (gtk-container-set-border-width window 10) - (gtk-container-add scroller1 layout1) - (gtk-container-add vbox scroller1) - (gtk-container-add scroller2 layout2) - (gtk-container-add vbox scroller2) - (gtk-container-add window vbox) - (gtk-widget-show-all window) - - (let ((drawing (demo-drawing layout1))) - - (set-scm-layout-drawing! layout1 drawing) - (set-scm-layout-scroll-pos! layout1 175 150) - - (set-scm-layout-drawing! layout2 drawing) - (set-scm-layout-scroll-pos! layout2 175 150) - - (let ((cursor1 (add-box-item drawing 'BOTTOM)) - (cursor2 (add-box-item drawing 'BOTTOM))) - (set-demo-drawing-cursor-items! - drawing (list (list cursor1 layout1) (list cursor2 layout2))) - (let ((thread (start-blinking drawing))) - (outf-console "; Cursor blinking courtesy of "thread".\n")))) - (gtk-widget-grab-focus layout1) - (outf-console "; Created "layout1" and "layout2"\n")) - unspecific) - -(define (demo-layout-new width height) - (let ((layout (scm-layout-new width height))) - (set-scm-layout-motion-handler! layout demo-motion-handler) - (set-scm-layout-button-release-handler! layout demo-button-release-handler) - (set-scm-layout-key-press-handler! layout demo-key-press-handler) - layout)) - -(define (demo-drawing device) - ;; DEVICE can (must, at the moment) be a scm-layout. - (let ((drawing (make-demo-drawing device))) - (set-drawing-size! drawing 500 500) - (let ((hline (add-hline-item drawing #f)) - (vline (add-vline-item drawing #f)) - (text (add-text-item drawing #f)) - (box (add-box-item drawing #f)) - (image (add-image-item-from-file - drawing #f - (merge-pathnames - "conses.png" (system-library-directory-pathname ""))))) - (set-drawn-item-position! hline 240 250) - (set-hline-item-size! hline 50) - (set-drawn-item-position! vline 250 240) - (set-vline-item-size! vline 50) - (set-drawn-item-position! text 250 250) - (set-text-item-text! text "Hello, World!") - (set-drawn-item-position! box 220 220) - (set-box-item-size! box 20 20) - (set-box-item-shadow! box 'etched-in) - (set-drawn-item-position! image 270 200) - drawing))) - -(define-class ( (constructor () 1)) - () - ;; An alist of cursors and their widgets, for the blinking thread - ;; and mouse motion handler. - (cursor-items define standard initial-value '())) - -(define (demo-motion-handler layout window-x window-y) - (trace2 ";(demo-motion-handler "layout" "window-x" "window-y")\n") - (let* ((drawing (scm-layout-drawing layout)) - (scroll (scm-layout-on-screen-area layout)) - (x (int:+ window-x (rect-x scroll))) - (y (int:+ window-y (rect-y scroll)))) - (trace2 "; Pointer moved to ("x","y") in "layout".\n") - (for-each - (lambda (item) - (if (not (text-item? item)) - (trace "; Picked: "item"\n") - (let ((index (text-item-xy-to-index item x y)) - (text-area (drawn-item-area item))) - (trace "; Picked: "index" in "(text-item-text item)"\n") - (call-with-text-item-grapheme-rect - item index - (lambda (xG yG widthG heightG) - (for-each - (lambda (cursor.widgets) - (if (memq layout (cdr cursor.widgets)) - (begin - (set-box-item-pos-size! - (car cursor.widgets) - (int:+ xG (rect-x text-area)) - (int:+ yG (rect-y text-area)) - widthG heightG) - ;; Keep the cursor on while tracking the mouse. - (set-drawn-item-widgets! - (car cursor.widgets) - (cdr cursor.widgets))))) - (demo-drawing-cursor-items drawing))))))) - (drawing-pick-list drawing layout x y))) - 1 ;;Handled. - ) - -(define (demo-button-release-handler layout window-x window-y) - (trace2 ";(demo-button-release-handler "layout" "window-x" "window-y")\n") - (let* ((drawing (scm-layout-drawing layout)) - (scroll (scm-layout-on-screen-area layout)) - (x (int:+ window-x (rect-x scroll))) - (y (int:+ window-y (rect-y scroll)))) - (outf-console "; Pointer release at ("x","y").\n") - (for-each - (lambda (item) - (if (not (text-item? item)) - (outf-console "; Picked: "item"\n") - (let ((index (text-item-xy-to-index item x y))) - (outf-console "; Picked: "item" (char "index")\n")))) - (drawing-pick-list drawing layout x y))) - 1 ;;Handled. - ) - -(define (demo-key-press-handler layout keyval char-bits) - (trace2 ";(demo-key-press-handler "layout" "keyval" "char-bits")\n") - (if (and (char? keyval) (char=? keyval #\D)) - (bkpt 'Test) - 0 ;;NOT handled. - )) - -(define (start-blinking drawing) - (create-thread - #f - (lambda () - (trace2 ";blinking start\n") - (let loop () - ;; Off! - (for-each (lambda (cursor.widgets) - (set-drawn-item-widgets! (car cursor.widgets) '())) - (demo-drawing-cursor-items drawing)) - (trace2 ";blinked off\n") - (sleep-current-thread 500) - ;; On! - (for-each (lambda (cursor.widgets) - (set-drawn-item-widgets! (car cursor.widgets) - (cdr cursor.widgets))) - (demo-drawing-cursor-items drawing)) - (trace2 ";blinked on\n") - (sleep-current-thread 500) - (if (there-exists? - (demo-drawing-cursor-items drawing) - (lambda (cursor.widgets) - (there-exists? (cdr cursor.widgets) - (lambda (W) (not (gtk-object-destroyed? W)))))) - (loop) - (trace2 ";blinking ended\n")))))) - - -(define trace? #f) -(define trace2? #f) - -(define-syntax trace - (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) - -(define-syntax trace2 - (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/ed-ffi.scm b/src/gtk/ed-ffi.scm index 6fe4af646..f5944313e 100644 --- a/src/gtk/ed-ffi.scm +++ b/src/gtk/ed-ffi.scm @@ -6,11 +6,14 @@ GTK buffer packaging info |# '#( ("gtk" (gtk)) ("gobject" (gtk gobject)) + ("pango" (gtk pango)) ("gtk-object" (gtk gtk-object)) ("scm-widget" (gtk widget)) - ("scm-layout" (gtk layout)) + ("fix-layout" (gtk fix-layout)) + ("keys" (gtk keys)) ("thread" (gtk thread)) ("main" (gtk main)) - ("pango" (gtk pango)) ("gtk-ev" (gtk event-viewer)) - ("demo" (gtk demo)))) \ No newline at end of file + ("fix-demo" (gtk fix-layout demo)) + ("swat" (gtk swat)) + ("swat-pole-zero" (gtk swat)))) \ No newline at end of file diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm new file mode 100644 index 000000000..9a41b375b --- /dev/null +++ b/src/gtk/fix-demo.scm @@ -0,0 +1,245 @@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; A small drawing in two fix-layout widgets. +;;; package: (gtk demo) + +(define (make-fix-layout-demo) + (let* ((window (gtk-window-new 'toplevel)) + (vbox (gtk-vbox-new #t 0)) + (scroller1 (gtk-scrolled-window-new)) + (scroller2 (gtk-scrolled-window-new)) + (layout1 (make-demo-layout 200 200)) + (layout2 (make-demo-layout 200 200))) + (gtk-window-set-opacity window 0.90) + (gtk-window-set-title window "fix-layout-demo") + (gtk-window-set-default-size window 200 400) + (set-gtk-window-delete-event-callback! + window (lambda (w) (trace "; Closed "w".\n") 0)) + (gtk-container-set-border-width window 10) + (gtk-container-add scroller1 layout1) + (gtk-container-add vbox scroller1) + (gtk-container-add scroller2 layout2) + (gtk-container-add vbox scroller2) + (gtk-container-add window vbox) + (gtk-widget-show-all window) + + (let ((drawing (make-demo-drawing layout1))) + (let ((cursor1 (make-box-ink)) + (cursor2 (make-box-ink))) + (set-box-ink-shadow! cursor1 'out) + (fix-drawing-add-ink! drawing cursor1 'bottom) + (fix-drawing-add-ink! drawing cursor2 'bottom) + (set-demo-drawing-cursor-inks! + drawing (list (list cursor1 layout1) (list cursor2 layout2)))) + (let ((thread (start-blinking drawing))) + (trace "; Cursor blinking courtesy of "thread".\n")) + (let ((thread (start-spinning drawing))) + (trace "; Ring spinning courtesy of "thread".\n")) + (set-fix-layout-drawing! layout1 drawing 175 150) + (set-fix-layout-drawing! layout2 drawing 175 150)) + (gtk-widget-grab-focus layout1) + (trace "; Created "layout1" and "layout2"\n")) + unspecific) + +(define-class ( (constructor () (width height))) + ()) + +(define-method initialize-instance ((layout ) width height) + (call-next-method layout width height) + (set-fix-layout-motion-handler! layout demo-motion-handler) + (set-fix-layout-button-handler! layout 'release demo-button-release-handler) + (set-fix-layout-key-press-handler! layout demo-key-press-handler) + layout) + +(define-method fix-layout-realize-callback ((widget )) + (call-next-method widget) + (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))) + +(define (make-demo-drawing widget) + (let ((drawing (%make-demo-drawing))) + (trace ";make-demo-drawing: "drawing"\n") + (set-fix-drawing-size! drawing 500 500) + (let ((line1 (make-line-ink)) + (line2 (make-line-ink)) + (line3 (make-line-ink)) + (arc (make-arc-ink)) + (text (make-simple-text-ink)) + (box (make-box-ink)) + (image (make-image-ink-from-file + (merge-pathnames "conses.png" + (system-library-directory-pathname ""))))) + (set-line-ink! line1 240 250 300 250) + (fix-drawing-add-ink! drawing line1) + (set-line-ink! line2 250 240 250 300) + (fix-drawing-add-ink! drawing line2) + (set-line-ink! line3 235 250 300 185) + (set-line-ink-width! line3 3) + (set-line-ink-color! line3 "blue") + (set-line-ink-dash-color! line3 "green") + (fix-drawing-add-ink! drawing line3) + (set-text-ink-position! text 250 250) + (set-simple-text-ink-text! text widget "Hello, World!") + (fix-drawing-add-ink! drawing text) + (set-box-ink! box 220 220 20 20) + (set-box-ink-shadow! box 'etched-in) + (fix-drawing-add-ink! drawing box) + (set-image-ink! image 270 200) + (fix-drawing-add-ink! drawing image) + (set-arc-ink! arc 240 190 30 30) + (set-arc-ink-width! arc 5) + (set-arc-ink-color! arc "gold") + (fix-drawing-add-ink! drawing arc) + drawing))) + +(define-class ( (constructor %make-demo-drawing () no-init)) + () + ;; An alist of cursors and their widgets, for the blinking thread + ;; and mouse motion handler. + (cursor-inks define standard initial-value '())) + +(define (demo-motion-handler layout modifiers window-x window-y) + (trace2 ";motion-handler "layout" "modifiers" "window-x" "window-y"\n") + (let* ((drawing (fix-layout-drawing layout)) + (view (fix-layout-view layout)) + (x (+ window-x (fix-rect-x view))) + (y (+ window-y (fix-rect-y view)))) + (trace2 "; Pointer moved to ("x","y") in "layout".\n") + (for-each + (lambda (ink) + (if (not (text-ink? ink)) + (trace "; Picked: "ink"\n") + (let ((index (text-ink-xy-to-index ink x y)) + (text-extent (fix-ink-extent ink))) + (trace "; Picked: "index" in "(simple-text-ink-text ink)"\n") + (with-text-ink-grapheme-rect + ink index + (lambda (xG yG widthG heightG) + (for-each + (lambda (cursor.widgets) + (if (memq layout (cdr cursor.widgets)) + (begin + (set-box-ink! + (car cursor.widgets) + (+ xG (fix-rect-x text-extent)) + (+ yG (fix-rect-y text-extent)) + widthG heightG) + ;; Keep the cursor on while tracking the mouse. + (set-fix-ink-widgets! + (car cursor.widgets) + (cdr cursor.widgets))))) + (demo-drawing-cursor-inks drawing))))))) + (fix-drawing-pick-list drawing layout x y))) + #t) + +(define (demo-button-release-handler layout type button modifiers window-x window-y) + (trace2 ";button-release-handler "layout" "type" "button" "modifiers" "window-x" "window-y"\n") + (let* ((drawing (fix-layout-drawing layout)) + (view (fix-layout-view layout)) + (x (+ window-x (fix-rect-x view))) + (y (+ window-y (fix-rect-y view)))) + (outf-console "; Pointer release at ("x","y").\n") + (for-each + (lambda (ink) + (if (not (text-ink? ink)) + (trace "; Picked: "ink"\n") + (let ((index (text-ink-xy-to-index ink x y))) + (trace "; Picked: "ink" (char "index")\n")))) + (fix-drawing-pick-list drawing layout x y))) + #t) + +(define (demo-key-press-handler layout keyval char-bits) + (trace "; Key press on "layout"\n") + (outf-console "; Keyval: "keyval" "char-bits"\n") + (if (and (char? keyval) (char=? keyval #\D)) + (bkpt 'Test)) + ;;NOT handled. + #f) + +(define (start-spinning drawing) + (create-thread + #f + (lambda () + (trace ";spinning start\n") + (let* ((frames 10) + (x 270) (y 190) (height 30) (width 30) + (pi (* (atan 1 1) 4)) + (half-widths (make-vector frames)) + (arc (find arc-ink? (fix-drawing-display-list drawing)))) + (define-integrable (half-width angle) + (fix:1+ (truncate->exact (/ (* width (abs (cos angle))) 2)))) + (do ((frame 0 (fix:1+ frame))) + ((= frame frames)) + (vector-set! half-widths frame (half-width (* pi (/ frame frames))))) + (let loop ((frame 0)) + (sleep-current-thread 100) + (let ((half-width (vector-ref half-widths frame))) + (let ((x (fix:- x half-width)) + (width (fix:* 2 half-width))) + (trace2 ";spinning to "width"\n") + (set-arc-ink! arc x y width height))) + (let ((widgets (fix-drawing-widgets drawing))) + (if (and (not (null? widgets)) + (for-all? widgets gtk-object-destroyed?)) + (trace ";spinning ended\n") + (loop (modulo (fix:1+ frame) frames))))))))) + +(define (start-blinking drawing) + (create-thread + #f + (lambda () + (trace ";blinking start\n") + (let loop () + ;; Off! + (for-each (lambda (cursor.widgets) + (set-fix-ink-widgets! (car cursor.widgets) '())) + (demo-drawing-cursor-inks drawing)) + (trace2 ";blinked off\n") + (sleep-current-thread 500) + ;; On! + (for-each (lambda (cursor.widgets) + (set-fix-ink-widgets! (car cursor.widgets) + (cdr cursor.widgets))) + (demo-drawing-cursor-inks drawing)) + (trace2 ";blinked on\n") + (sleep-current-thread 500) + (if (there-exists? + (demo-drawing-cursor-inks drawing) + (lambda (cursor.widgets) + (there-exists? (cdr cursor.widgets) + (lambda (w) (not (gtk-object-destroyed? w)))))) + (loop) + (trace ";blinking ended\n")))))) + + +(define trace? #f) +(define trace2? #f) + +;; (trace...) syntax can avoid evaluating expensive expressions among +;; the argument forms when the corresponding trace? flag is off. +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm new file mode 100644 index 000000000..26ef23cae --- /dev/null +++ b/src/gtk/fix-layout.scm @@ -0,0 +1,1907 @@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; : A fixnum-centric canvas. +;;; package: (gtk fix-layout) + +(c-include "gtk") + +(define-class ( (constructor () (width height))) + () + + ;; Our window and colormap -- GdkWindow and GdkColormap aliens + ;; respectively. Until realized, these are NULL pointers. + (window define accessor + initializer (lambda () (make-alien '|GdkWindow|))) + (colormap define accessor + initializer (lambda () (make-alien '|GdkColormap|))) + + ;; Our allocated colors -- an alist of color specs x malloced + ;; GdkColor structs with .pixels courtesy of gdk_rgb_find_color. + (colors define standard initial-value '()) + + ;; Our window geometry (allocation) -- a rectangular extent in + ;; fixnum device coordinates (e.g. size in pixels, offset within + ;; parent window [ancestor widget]). + (geometry define accessor initializer (lambda () (make-fix-rect))) + + ;; Scrollbar widgets. + (vadjustment define standard initial-value #f) + (hadjustment define standard initial-value #f) + (scroll-step define accessor initializer (lambda () (cons 10 20))) + + ;; Scrollable extent (drawing size), in logical device coords. + (scrollable-extent define accessor + initializer (lambda () (make-fix-rect 0 0 100 100))) + + ;; Scroll offset (and window size) in logical device coordinates. + ;; (The size should match the window geometry.) + (view define accessor initializer (lambda () (make-fix-rect 0 0))) + + (drawing define standard + modifier %set-fix-layout-drawing! + initial-value #f) + + (event-handlers define accessor initializer + (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) + +(define-guarantee fix-layout "a ") + +(define-integrable (allocate-color! layout spec) + (let* ((colors (fix-layout-colors layout)) + (entry (assoc spec colors))) + (if entry + (cdr entry) + (let ((gdkcolor (parse-gdkcolor spec layout))) + (if (not gdkcolor) + (begin + (warn "Invalid color spec:" spec layout) + #f) + (let ((colormap (fix-layout-colormap layout))) + (C-call "gdk_rgb_find_color" colormap gdkcolor) + (set-fix-layout-colors! layout + (cons (cons spec gdkcolor) colors)) + gdkcolor)))))) + +(define-method gtk-widget-get-colormap ((widget )) + (fix-layout-colormap widget)) + +(define-method set-gtk-widget-bg-color! ((widget ) color + #!optional state) + ;; Set the window background (too). + (call-next-method widget color state) + (if (not (or (default-object? state) (eq? state 'normal))) + (warn "Fix-layout states are not (yet) supported:" widget color state)) + (if (not (fix-layout-realized? widget)) + (warn "Fix-layout not realized:" widget color state) + (let ((alien (make-alien '|GdkColor|))) + (C-> (gobject-alien widget) "GtkWidget style" alien) + (C-> alien "GtkStyle bg" alien) + (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL")) + ;; The GdkColor was allocated by the GtkStyle. + (C-call "gdk_window_set_background" (fix-layout-window widget) alien)))) + +(define-method initialize-instance ((widget ) width height) + + (define-integrable (->requisition-fixnum obj) + (if (and (fixnum? obj) (fix:> obj -2)) + obj + (error:wrong-type-argument obj "a positive fixnum, 0 or -1" + (list 'initialize-instance )))) + + (trace ";((initialize-instance ) "widget" "width" "height")...\n") + (call-next-method widget) + (let ((alien (gobject-alien widget))) + (let ((geometry (fix-layout-geometry widget)) + (w (->requisition-fixnum width)) + (h (->requisition-fixnum height))) + (C->= alien "GtkWidget requisition width" w) + (C->= alien "GtkWidget requisition height" h) + (set-fix-rect-size! geometry w h)) + + (C-call "gtk_widget_set_has_window" alien 1) + (C-call "gtk_widget_set_can_focus" alien 1)) + (set-gtk-object-destroy-callback! widget) + (set-gtk-widget-realize-callback! widget fix-layout-realize-callback) + (set-gtk-widget-size-allocate-callback! widget allocation-callback) + (set-gtk-widget-event-callback! widget event-callback) + (set-scm-widget-set-scroll-adjustments-callback! widget adjustments-callback) + widget) + +(define (fix-layout-realized? widget) + (not (alien-null? (fix-layout-window widget)))) + +(define (set-fix-layout-size! widget width height) + (guarantee-fix-layout widget 'set-fix-layout-size!) + (guarantee-non-negative-fixnum width 'set-fix-layout-size!) + (guarantee-non-negative-fixnum height 'set-fix-layout-size!) + (let ((alien (gobject-alien widget))) + (C-call "gtk_widget_set_size_request" alien width height))) + +(define (set-fix-layout-scroll-size! widget width height) + ;; Tells WIDGET to adjust its scrollable extent. Notifies any + ;; scrollbars. + (guarantee-fix-layout widget 'set-fix-layout-scroll-size!) + (guarantee-non-negative-fixnum width 'set-fix-layout-scroll-size!) + (guarantee-non-negative-fixnum height 'set-fix-layout-scroll-size!) + (let ((extent (fix-layout-scrollable-extent widget))) + (if (not (and (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (set-fix-rect-size! extent width height) + (if (fix-layout-realized? widget) + (adjust-adjustments widget)))))) + +(define (fix-layout-scroll-to! widget x y) + (guarantee-fix-layout widget 'fix-layout-scroll-to!) + (guarantee-fixnum x 'fix-layout-scroll-to!) + (guarantee-fixnum y 'fix-layout-scroll-to!) + (scroll widget x y)) + +(define (fix-layout-scroll-nw! widget extent) + ;; Scroll just enough to view the entire EXTENT (a fix-rect + ;; structure). If the view is too small to include the entire + ;; extent, the layout is scrolled so that its NW corner matches the + ;; NW corner of the extent. + (let ((view (fix-layout-view widget))) + (cond ((not (fix-rect-nominal? extent)) + (error "Undefined extent:" extent)) + ((not (fix-rect-nominal? view)) + (error "Undefined extent:" view)) + ((fix-rect-contains? view extent) + unspecific) + (else + (with-fix-rect-bounds + view + (lambda (min-x-view max-x-view min-y-view max-y-view) + (with-fix-rect-bounds + extent + (lambda (min-x-extent max-x-extent min-y-extent max-y-extent) + (let ((delta-y (cond ((fix:< min-y-extent min-y-view) + ;; extent is too low (N), go low + (fix:- min-y-extent min-y-view)) + ((fix:< max-y-view max-y-extent) + ;; extent is too high (S), go high + (fix:- max-y-extent max-y-view)) + (else 0))) + (delta-x (cond ((fix:< min-x-extent min-x-view) + ;; extent is too low (W), go low + (fix:- min-x-extent min-x-view)) + ((fix:< max-x-view max-x-extent) + ;; extent is too high (E), go high + (fix:- max-x-extent max-x-view)) + (else 0)))) + (fix-layout-scroll-to! + widget + (fix:+ min-x-view delta-x) + (fix:+ min-y-view delta-y))))))))))) + +(define (scroll widget new-x new-y) + ;; Scroll if more than 25% will remain in the window, else jump. + (if (fix-layout-realized? widget) + (let ((view (fix-layout-view widget))) + (let ((old-x (fix-rect-x view)) + (old-y (fix-rect-y view))) + (let ((dx (fix:- new-x old-x)) + (dy (fix:- new-y old-y))) + (if (not (and (fix:zero? dx) (fix:zero? dy))) + (let ((width (fix-rect-width view)) + (height (fix-rect-height view)) + (gdkwindow (fix-layout-window widget))) + (let ((remaining-width (fix:- width (fix:abs dy))) + (remaining-height (fix:- height (fix:abs dx)))) + (if (or (fix:negative? remaining-width) + (fix:negative? remaining-height) + (< 0.25 (/ (fix:* remaining-width remaining-height) + (fix:* width height)))) + (C-call "gdk_window_scroll" + gdkwindow (fix:negate dx) (fix:negate dy)) + (C-call "gtk_widget_queue_draw" + (gobject-alien widget))) + (set-fix-rect-position! view new-x new-y) + (adjust-adjustments widget)) + (C-call "gdk_window_process_updates" gdkwindow 0)))))))) + +(define (set-fix-layout-scroll-step! widget width height) + (guarantee-fix-layout widget 'set-fix-layout-scroll-step!) + (guarantee-positive-fixnum width 'set-fix-layout-scroll-step!) + (guarantee-positive-fixnum height 'set-fix-layout-scroll-step!) + (let ((width.height (fix-layout-scroll-step widget))) + (set-car! width.height width) + (set-cdr! width.height height)) + (if (fix-layout-realized? widget) + (adjust-adjustments widget))) + +(define (set-fix-layout-drawing! widget drawing x y) + ;; Need to add widget to drawing and drawing to widget. Either way, + ;; asynchronous exposures may be handled inconsistently. Rather + ;; than lock up the machine with without-interrupts, rely on the + ;; all-encompassing update queued at the end, AFTER the pair of + ;; links is in place. + ;; + ;; Setting the drawing first to cut off its flow of damage areas + ;; first. Expose handlers should have few chances to serve exposes + ;; from the old drawing before the widget sees the new one. + (guarantee-fix-layout widget 'set-fix-layout-drawing!) + (guarantee-fix-drawing drawing 'set-fix-layout-drawing!) + (guarantee-fixnum x 'set-fix-layout-drawing!) + (guarantee-fixnum y 'set-fix-layout-drawing!) + (let* ((old (fix-layout-drawing widget)) + (view (fix-layout-view widget))) + (if (and (eq? drawing old) (fix-rect-at-point? view x y)) + unspecific + (let ((extent (fix-drawing-extent drawing)) + (scrollable (fix-layout-scrollable-extent widget))) + (set-fix-rect-position! view x y) + (set-fix-rect-size! scrollable + (fix-rect-width extent) (fix-rect-height extent)) + (if old (fix-drawing-remove-widget! old widget)) + (if drawing (fix-drawing-add-widget! drawing widget)) + (%set-fix-layout-drawing! widget drawing) + (if (fix-layout-realized? widget) + (begin + (adjust-adjustments widget) + (C-call "gtk_widget_queue_draw" (gobject-alien widget)))))))) + +;;; Callbacks. + +(define (allocation-callback widget GtkAllocation) + (trace2 ";allocation "widget" "GtkAllocation"\n") + (let ((alien (gobject-alien widget)) + (x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (rect (fix-layout-geometry widget))) + (trace "; Allocation: "width"x"height" to "widget"\n") + (set-fix-rect! rect x y width height) + (set-fix-rect-size! (fix-layout-view widget) width height) + ;; For the random toolkit GtkWidget method too. + (C->= alien "GtkWidget allocation x" x) + (C->= alien "GtkWidget allocation y" y) + (C->= alien "GtkWidget allocation width" width) + (C->= alien "GtkWidget allocation height" height) + (if (fix-layout-realized? widget) + (begin + (C-call "gdk_window_move_resize" (fix-layout-window widget) + x y width height) + (adjust-adjustments widget))) + (fix-layout-new-geometry-callback widget))) + +(define-generic fix-layout-new-geometry-callback (widget)) + +(define-method fix-layout-new-geometry-callback ((widget )) + (declare (ignore widget)) + unspecific) + +(define-generic fix-layout-realize-callback (layout)) + +(define-method fix-layout-realize-callback ((widget )) + (trace ";fix-layout-realize- "widget"\n") + (let ((geometry (fix-layout-geometry widget)) + (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (fix-layout-window widget)) + (parent-GdkWindow (make-alien '|GdkWindow|)) + ;;(GdkVisual (make-alien '|GdkVisual|)) + (GdkColormap (fix-layout-colormap widget)) + (GtkWidget (gobject-alien widget))) + + ;; Create widget window. + ;;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget) + ;;(C-call "gdk_rgb_get_visual" GdkVisual) + ;;(error-if-null GdkVisual "Could not get GdkVisual:" widget) + (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) + (error-if-null GdkColormap "Could not get GdkColormap:" widget) + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (let ((x (fix-rect-x geometry)) + (y (fix-rect-y geometry)) + (width (fix-rect-width geometry)) + (height (fix-rect-height geometry))) + (if x (C->= attr "GdkWindowAttr x" x)) + (if y (C->= attr "GdkWindowAttr y" y)) + (C->= attr "GdkWindowAttr width" width) + (C->= attr "GdkWindowAttr height" height) + ;;(C->= attr "GdkWindowAttr visual" GdkVisual) + (C->= attr "GdkWindowAttr colormap" GdkColormap) + (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) + + (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) + (error-if-null parent-GdkWindow "Could not get parent:" widget) + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-or (if x (C-enum "GDK_WA_X") 0) + (if y (C-enum "GDK_WA_Y") 0) + ;;(C-enum "GDK_WA_VISUAL") + (C-enum "GDK_WA_COLORMAP"))) + (error-if-null main-GdkWindow "Could not create main window:" widget) + (C-call "gtk_widget_set_window" GtkWidget main-GdkWindow) + (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) + (set-fix-rect! (fix-layout-geometry widget) #f #f width height) + (set-fix-rect! (fix-layout-view widget) 0 0 width height) + (trace "; window: "main-GdkWindow"\n")) + + (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) + (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) + (C->= GtkWidget "GtkWidget style" GtkStyle)) + + (adjust-adjustments widget) + unspecific)) + +(define (adjustments-callback widget hGtkAdjustment vGtkAdjustment) + (trace2 ";set-scroll-adjustments "widget" "hGtkAdjustment" "vGtkAdjustment"\n") + (trace "; Adjustments:" + " 0x"(alien/address-string hGtkAdjustment) + " 0x"(alien/address-string vGtkAdjustment)"\n") + (connect-adjustment (fix-layout-hadjustment widget) hGtkAdjustment + widget set-fix-layout-hadjustment!) + (connect-adjustment (fix-layout-vadjustment widget) vGtkAdjustment + widget set-fix-layout-vadjustment!) + (if (fix-layout-realized? widget) + (adjust-adjustments widget)) + 0 ;; What does this mean? + ) + +(define (connect-adjustment old-adjustment new-alien widget setter) + ;; Disconnects OLD-ADJUSTMENT (if any) and applies SETTER to WIDGET + ;; and the new adjustment (if any). + + (let ((old-alien (and old-adjustment (gobject-alien old-adjustment)))) + ;; Disconnect. + (cond ((not old-adjustment)) + ((alien=? new-alien old-alien)) + (else + (gobject-unref! old-adjustment))) + ;; Connect. + (cond ((alien-null? new-alien)) + ((and old-alien (alien=? new-alien old-alien))) + (else + (let ((new-adjustment (make-gtk-adjustment))) + (copy-alien-address! (gobject-alien new-adjustment) new-alien) + (C-call "g_object_ref_sink" new-alien new-alien) + (set-gtk-object-destroy-callback! new-adjustment) + (setter widget new-adjustment) + (g-signal-connect + new-adjustment (C-callback "value_changed") + (make-adjustment-value-changed-callback widget))))))) + +(define (make-adjustment-value-changed-callback widget) + (named-lambda (fix-layout-adjustment-value-changed-callback adjustment) + (trace2 ";adjustment-value-changed "widget" "adjustment"\n") + + (let ((window-extent (fix-layout-view widget)) + (vadjustment (fix-layout-vadjustment widget)) + (hadjustment (fix-layout-hadjustment widget)) + (value (floor->exact + (C-> (gobject-alien adjustment) "GtkAdjustment value")))) + (cond ((eq? adjustment vadjustment) + (trace2 "; Vadjustment to "value"\n") + (scroll widget (fix-rect-x window-extent) value)) + ((eq? adjustment hadjustment) + (trace2 "; Hadjustment to "value"\n") + (scroll widget value (fix-rect-y window-extent))) + (else (warn "Unexpected adjustment:" adjustment)))))) + +(define (adjust-adjustments widget) + ;; Called after the widget gets new adjustment(s) or its size or + ;; scrollable extent changes. + + (let ((vadj (fix-layout-vadjustment widget))) + (if (and vadj (gobject-live? vadj)) + (let* ((view (fix-layout-view widget)) + (view-height (fix-rect-height view)) + (extent (fix-layout-scrollable-extent widget)) + (top (fix-rect-y extent)) + (bottom (fix:+ top (fix:max (fix-rect-height extent) view-height))) + (value (fix-rect-y view)) + (page-size view-height) + (step-incr (cdr (fix-layout-scroll-step widget))) + (page-incr (min page-size (- page-size step-incr)))) + (set-gtk-adjustment! vadj value top bottom + page-size step-incr page-incr)))) + + (let ((hadj (fix-layout-hadjustment widget))) + (if (and hadj (gobject-live? hadj)) + (let* ((view (fix-layout-view widget)) + (view-width (fix-rect-width view)) + (extent (fix-layout-scrollable-extent widget)) + (left (fix-rect-x extent)) + (right (fix:+ left (fix:max (fix-rect-width extent) view-width))) + (value (fix-rect-x view)) + (page-size view-width) + (step-incr (car (fix-layout-scroll-step widget))) + (page-incr (min page-size (- page-size step-incr)))) + (set-gtk-adjustment! hadj value left right + page-size step-incr page-incr))))) + +(define (event-callback layout GdkEvent) + (trace2 ";event "layout" "GdkEvent"\n") + + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (if (int:= type (C-enum "GDK_EXPOSE")) + (let ((window (C-> GdkEvent "GdkEvent any window")) + (x (C-> GdkEvent "GdkEventExpose area x")) + (y (C-> GdkEvent "GdkEventExpose area y")) + (width (C-> GdkEvent "GdkEventExpose area width")) + (height (C-> GdkEvent "GdkEventExpose area height")) + ;;(count (C-> GdkEvent "GdkEventExpose count")) + (drawing (fix-layout-drawing layout)) + (widget-window (fix-layout-window layout))) + (cond ((not (alien=? window widget-window)) + (trace "; Expose a strange window "window + " (not "widget-window").\n")) + (drawing + (let* ((view (fix-layout-view layout)) + (offx (fix-rect-x view)) + (offy (fix-rect-y view))) + (trace2 "; Expose area "width"x"height" "x","y + " of "layout".\n") + (drawing-expose drawing layout window + (make-fix-rect + (fix:+ x offx) (fix:+ y offy) + width height))))) + 1 ;;TRUE -- "handled" -- done. + ) + (let ((handler (vector-ref (fix-layout-event-handlers layout) type))) + (if handler + (if (handler layout GdkEvent) 1 0) + ;; Unhandled + 0))))) + +(define (set-fix-layout-map-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-map-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-layout-map-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_MAP") + (named-lambda (fix-layout-map-handler layout GdkEvent) + (declare (ignore GdkEvent)) + (handler layout)))) + +(define (set-fix-layout-unmap-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-unmap-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-layout-unmap-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_UNMAP") + (named-lambda (fix-layout-unmap-handler layout GdkEvent) + (declare (ignore GdkEvent)) + (handler layout)))) + +(define (set-fix-layout-focus-change-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-focus-change-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-layout-focus-change-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_FOCUS_CHANGE") + (named-lambda (fix-layout-focus-change-handler layout GdkEvent) + (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in"))))) + (handler layout in?))))) + +(define (set-fix-layout-visibility-notify-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-visibility-notify-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-layout-visibility-notify-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_VISIBILITY_NOTIFY") + (named-lambda (fix-layout-visibility-notify-handler layout GdkEvent) + (let ((state (C-> GdkEvent "GdkEventVisibility state"))) + (handler + layout + (cond + ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE) + ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED) + ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED) + (else (C-enum "GdkVisibilityState" state)))))))) + +(define (set-fix-layout-key-press-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-key-press-handler!) + (guarantee-procedure-of-arity handler 3 'set-fix-layout-key-press-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_KEY_PRESS") + (named-lambda (fix-layout-key-press-handler layout GdkEvent) + (let ((alien (C-> GdkEvent "GdkEvent key string")) + (length (C-> GdkEvent "GdkEvent key length")) + (state (C-> GdkEvent "GdkEvent key state")) + (keyval (C-> GdkEvent "GdkEvent key keyval"))) + (let ((string (c-peek-cstring alien)) + (char-bits (gdk-key-state->char-bits state))) + (if (zero? (string-length string)) + (cond ((fix:= length 1) + (handler layout #\NUL char-bits)) + ((fix:= length 0) + (handler layout (gdk-keyval->name keyval) char-bits)) + (else (error "Unexpected length in GdkEventKey."))) + (let ((l (string-length string))) + (let loop ((i 0)) + (if (fix:< i l) + (and (handler layout (string-ref string i) char-bits) + (loop (fix:1+ i))) + #t))))))))) + +(define (set-fix-layout-motion-handler! layout handler) + (guarantee-fix-layout layout 'set-fix-layout-motion-handler!) + (guarantee-procedure-of-arity handler 4 'set-fix-layout-motion-handler!) + (vector-set! + (fix-layout-event-handlers layout) (C-enum "GDK_MOTION_NOTIFY") + (named-lambda (fix-layout-motion-handler layout GdkEvent) + (let ((handled? + (handler layout + (->modifiers (C-> GdkEvent "GdkEventMotion state")) + (floor->exact (C-> GdkEvent "GdkEventMotion x")) + (floor->exact (C-> GdkEvent "GdkEventMotion y"))))) + (C-call "gdk_window_get_pointer" #f + (C-> GdkEvent "GdkEventMotion window") 0 0 0) + handled?)))) + +(define ->modifiers + (let ((names (make-vector 32 #f))) + (define-integrable (name mask symbol) + (vector-set! names (car (bit-mask-indices mask)) symbol)) + (name (C-enum "GDK_SHIFT_MASK") 'shift) + (name (C-enum "GDK_LOCK_MASK") 'lock) + (name (C-enum "GDK_CONTROL_MASK") 'control) + (name (C-enum "GDK_MOD1_MASK") 'mod1) + (name (C-enum "GDK_MOD2_MASK") 'mod2) + (name (C-enum "GDK_MOD3_MASK") 'mod3) + (name (C-enum "GDK_MOD4_MASK") 'mod4) + (name (C-enum "GDK_MOD5_MASK") 'mod5) + (name (C-enum "GDK_BUTTON1_MASK") 'button1) + (name (C-enum "GDK_BUTTON2_MASK") 'button2) + (name (C-enum "GDK_BUTTON3_MASK") 'button3) + (name (C-enum "GDK_BUTTON4_MASK") 'button4) + (name (C-enum "GDK_BUTTON5_MASK") 'button5) + (name (C-enum "GDK_SUPER_MASK") 'super) + (name (C-enum "GDK_HYPER_MASK") 'hyper) + (name (C-enum "GDK_META_MASK") 'meta) + (name (C-enum "GDK_RELEASE_MASK") 'release) + (named-lambda (->modifiers num) + (map (lambda (i) (vector-ref names i)) (bit-mask-indices num))))) + +(define (set-fix-layout-button-handler! layout type handler) + (guarantee-fix-layout layout 'set-fix-layout-button-handler!) + (guarantee-procedure-of-arity handler 6 'set-fix-layout-button-handler!) + (let ((index (->button-event-type type 'set-fix-layout-button-handler!)) + (handler (make-button-handler handler))) + (vector-set! (fix-layout-event-handlers layout) index handler))) + +(define (make-button-handler handler) + (named-lambda (fix-layout-button-handler layout GdkEvent) + (handler layout + (button-event-type->name (C-> GdkEvent "GdkEvent any type")) + (C-> GdkEvent "GdkEventButton button") + (->modifiers (C-> GdkEvent "GdkEventButton state")) + (floor->exact (C-> GdkEvent "GdkEventButton x")) + (floor->exact (C-> GdkEvent "GdkEventButton y"))))) + +(define (->button-event-type type operator) + (guarantee-symbol type operator) + (case type + ((PRESS) (C-enum "GDK_BUTTON_PRESS")) + ((RELEASE) (C-enum "GDK_BUTTON_RELEASE")) + ((DOUBLE-PRESS) (C-enum "GDK_2BUTTON_PRESS")) + ((TRIPLE-PRESS) (C-enum "GDK_3BUTTON_PRESS")) + (else (error:wrong-type-argument + type "a button event type (press, release, double-press or triple-press)" + operator)))) + +(define (button-event-type->name type) + (cond ((= type (C-enum "GDK_BUTTON_PRESS")) 'PRESS) + ((= type (C-enum "GDK_BUTTON_RELEASE")) 'RELEASE) + ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS) + ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) + (else 'BOGUS))) + +(define-class ( (constructor () no-init)) + () + (extent define accessor initializer (lambda () (make-fix-rect 0 0 0 0))) + (widgets define standard initial-value '()) + (display-list define standard initial-value '())) + +(define-guarantee fix-drawing "a ") + +(define (drawing-damage ink #!optional rect) + ;; Invalidates any widget extents affected by RECT in INK. By + ;; default, RECT is INK's entire extent. + (let ((extent (if (default-object? rect) + (fix-ink-extent ink) + rect)) + (drawing (fix-ink-drawing ink))) + (trace2 ";drawing-damage "ink" "(fix-rect-string extent)"\n") + + (cond ((not drawing)) + ((not (fix-rect-nominal? extent)) + (error "Cannot damage ill-defined extent:" ink)) + ((and (not (fix:zero? (fix-rect-width extent))) + (not (fix:zero? (fix-rect-height extent)))) + (for-each + (lambda (widget) + (let ((intersect (let ((v (fix-layout-view widget))) + (and (fix-rect-nominal? v) + (window-intersection v extent))))) + (if (and intersect (not (gtk-object-destroyed? widget))) + (C-call "gtk_widget_queue_draw_area" + (gobject-alien widget) + (fix-rect-x intersect) (fix-rect-y intersect) + (fix-rect-width intersect) (fix-rect-height intersect))))) + (let ((widgets (fix-ink-widgets ink))) + (if (eq? #t widgets) + (fix-drawing-widgets drawing) + widgets))))))) + +(define (fix-drawing-pick-list drawing widget x y) + (keep-matching-items (fix-drawing-display-list drawing) + (lambda (ink) + (and (fix-ink-in-widget? ink widget) + (point-in-fix-rect? x y (fix-ink-extent ink)))))) + +(define (drawing-expose drawing widget window area) + ;; AREA is in drawing coords. + (if (fix-rect-nominal? area) + (for-each + (lambda (ink) + (if (fix-ink-in? ink widget area) + (fix-ink-expose-callback ink widget window area))) + (fix-drawing-display-list drawing)))) + +(define (fix-ink-in? ink widget area) + (declare (integrate-operator fix-ink-in?)) + (and (fix-ink-in-widget? ink widget) + (let ((extent (fix-ink-extent ink))) + (and (fix-rect-nominal? extent) + (fix-rect-intersect? extent area))))) + +(define-integrable (fix-ink-in-widget? ink widget) + (let ((widgets (fix-ink-widgets ink))) + (or (eq? #t widgets) + (memq widget widgets)))) + +(define-generic fix-ink-expose-callback (ink widget window expose-area) + ;; Due to the checks in drawing-expose, methods of this generic can + ;; assume expose-area and the ink's extent are intersecting, and INK + ;; is visible in the WIDGET. Methods may also assume the widget is + ;; realized and its window's (gc's) clipping is already set. The + ;; widget's scroll offset (view extent) is also set. + ) + +(define (fix-drawing-add-widget! drawing widget) + (guarantee-fix-drawing drawing 'fix-drawing-add-widget!) + (guarantee-fix-layout widget 'fix-drawing-add-widget!) + (let ((widgets (fix-drawing-widgets drawing))) + (if (not (memq widget widgets)) + (set-fix-drawing-widgets! drawing (cons widget widgets))))) + +(define (fix-drawing-remove-widget! drawing widget) + (guarantee-fix-drawing drawing 'fix-drawing-remove-widget!) + (guarantee-fix-layout widget 'fix-drawing-remove-widget!) + (set-fix-drawing-widgets! drawing (delq! widget + (fix-drawing-widgets drawing)))) + +(define (fix-drawing-add-ink! drawing ink #!optional where) + (guarantee-fix-drawing drawing 'fix-drawing-add-ink!) + (guarantee-fix-ink ink 'fix-drawing-add-ink!) + + (let ((where (and (not (default-object? where)) where))) + (if (fix-ink-drawing ink) (error "Already in a drawing:" ink)) + (cond ((or (eq? #f where) + (eq? 'TOP where)) + (set-fix-drawing-display-list! + drawing (append! (fix-drawing-display-list drawing) (list ink)))) + ((eq? 'BOTTOM where) + (set-fix-drawing-display-list! + drawing (cons ink (fix-drawing-display-list drawing)))) + ((fix-ink? where) + (let loop ((inks (fix-drawing-display-list drawing)) + (prev #f)) + (if (null? inks) + (error "Ink not found in drawing:" ink drawing) + (let ((i (car inks))) + (if (eq? where i) + (if (pair? prev) + (set-cdr! prev (cons ink inks)) + (set-fix-drawing-display-list! drawing + (cons ink inks))) + (loop (cdr inks) inks)))))) + (else (error:wrong-type-argument + where + (string-append "display list location" + ", one of: #F, TOP, BOTTOM, or an " + " already in the drawing's display list") + 'fix-drawing-add-ink!)))) + (set-fix-ink-drawing! ink drawing) + (drawing-damage ink)) + +(define (set-fix-drawing-size! drawing width height) + (guarantee-fix-drawing drawing 'set-fix-drawing-size!) + (guarantee-non-negative-fixnum width 'set-drawing-size!) + (guarantee-non-negative-fixnum height 'set-drawing-size!) + (set-fix-rect-size! (fix-drawing-extent drawing) width height) + (for-each + (lambda (widget) (set-fix-layout-scroll-size! widget width height)) + (fix-drawing-widgets drawing))) + +(define (set-drawing-extent! drawing rectangle) + (let ((extent (fix-drawing-extent drawing))) + (set-fix-rect! extent + (fix-rect-x rectangle) + (fix-rect-y rectangle) + (fix-rect-width rectangle) + (fix-rect-height rectangle)))) + +(define-class + () + (extent define standard initializer (lambda () (make-fix-rect 0 0 0 0))) + (drawing define standard initial-value #f) + + ;; A list of widgets in which the ink should be drawn. #t if the + ;; ink should be visible in all views of the drawing. + (widgets define standard initial-value #t + modifier set-fix-ink-%widgets!)) + +(define-guarantee fix-ink "a ") + +(define (set-fix-ink-%position! ink x y) + (let ((extent (fix-ink-extent ink))) + (without-interrupts + (lambda () + (if (not (and (fix:= x (fix-rect-x extent)) + (fix:= y (fix-rect-y extent)))) + (begin + (drawing-damage ink) + (set-fix-rect-position! extent x y) + (drawing-damage ink))))))) + +(define (set-fix-ink-%size! ink width height) + (let ((extent (fix-ink-extent ink))) + (without-interrupts + (lambda () + (if (not (and (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (drawing-damage ink) + (set-fix-rect-size! extent width height) + (drawing-damage ink))))))) + +(define (set-fix-ink! ink x y width height) + (let ((extent (fix-ink-extent ink))) + (without-interrupts + (lambda () + (if (not (and (fix:= x (fix-rect-x extent)) + (fix:= y (fix-rect-y extent)) + (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (drawing-damage ink) + (set-fix-rect! extent x y width height) + (drawing-damage ink))))))) + +(define (set-fix-ink-widgets! ink widgets) + (without-interrupts + (lambda () + (if (not (equal? widgets (fix-ink-widgets ink))) + (begin + (drawing-damage ink) + (set-fix-ink-%widgets! ink widgets) + (drawing-damage ink)))))) + +(define (fix-ink-remove! ink) + (guarantee-fix-ink ink 'fix-ink-remove!) + (let ((drawing (fix-ink-drawing ink))) + (cond ((not drawing) unspecific) + ((not (memq ink (fix-drawing-display-list drawing))) + (warn "Could not remove ink:" ink drawing)) + (else + (set-fix-drawing-display-list! + drawing (delq! ink (fix-drawing-display-list drawing))) + (drawing-damage ink) + (set-fix-ink-drawing! ink #f))))) + +;; For the convenience of SWAT's canvas item group, mostly. +(define-generic fix-ink-move! (ink dx dy)) + +;; This kind of ink draws (outlines and/or fills) a shape using a +;; gdk_draw_* function with a GdkGC from gtk_gc_get (i.e. using the +;; toolkit's GdkGC pool). + +(define-class + () + + ;; An alist of logical GraphicsContext member names (e.g. 'dash) X + ;; color or font specs, widths, booleans, etc. The spec's are + ;; converted to toolkit objects LATE, e.g. on expose, when the + ;; drawing is found in a realized widget. The conversion of this + ;; alist produces the GCValues struct that is passed to gtk_gc_get. + (options define standard initial-value '())) + +(define-guarantee draw-ink "a ") + +;;; For draw-ink expose handlers (without-interrupts in gtk-thread). + +(define (with-gc options widget receiver) + (trace2 ";(with-gc "options" "widget")") + (if (pair? options) + (let* ((alien.mask (malloc-gcvalues options)) + (gc (gtk-gc-get widget alien.mask))) + (trace2 " => "alien.mask", "gc"\n") + (free (car alien.mask)) + (receiver gc) + (gtk-gc-release gc)) + (let ((gc (make-alien '|GdkGC|))) + (C-> (gobject-alien widget) "GtkWidget style" gc) + (C-> gc "GtkStyle fg_gc" gc) + (C-array-loc! gc "* GdkGC" (C-enum "GTK_STATE_NORMAL")) + (C-> gc "* GdkGC" gc) + (trace2 " => fg:"gc"\n") + (receiver gc)))) + +(define (gtk-gc-get widget gcvalues.mask) + (let* ((alien (make-alien '|GdkGC|)) + (copy (make-alien '|GdkGC|)) + (colormap (gtk-widget-get-colormap widget)) + (depth (C-> (C-> colormap "GdkColormap visual") "GdkVisual depth"))) + (add-gc-cleanup alien (gtk-gc-cleanup-thunk copy)) + (C-call "gtk_gc_get" copy depth colormap + (car gcvalues.mask) (cdr gcvalues.mask)) + (copy-alien-address! alien copy) + alien)) + +(define (gtk-gc-cleanup-thunk copy) + (named-lambda (gtk-gc-cleanup-handler) + (if (not (alien-null? copy)) + (begin + (C-call "gtk_gc_release" copy) + (alien-null! copy))))) + +(define (gtk-gc-release gc) + (without-interrupts + (lambda () + (if (not (alien-null? gc)) + (begin + (C-call "gtk_gc_release" gc) + (alien-null! gc) + (punt-gc-cleanup gc)))))) + +(define (malloc-gcvalues options) + (let ((gcvalues (malloc (C-sizeof "GdkGCValues") '|GdkGCValues|))) + (let loop ((options options) + (mask 0)) + (if (null? options) + (cons gcvalues mask) + (let ((name (caar options)) + (value (cdar options))) + (case name + + ((FOREGROUND) + (poke-color (C-> gcvalues "GdkGCValues foreground") value) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FOREGROUND")))) + + ((BACKGROUND) + (poke-color (C-> gcvalues "GdkGCValues background") value) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_BACKGROUND")))) + + ((FONT) + ;; Handled during creation of the PangoLayout. + (loop (cdr options) mask)) + + #;((FUNCTION) + (C->= gcvalues "GdkGCValues function" value) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FUNCTION")))) + + #;((FILL) + ;; This is useless without a pixmap or bitmap setting. + (case value + ((SOLID) + (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_SOLID"))) + ((TILED) + (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_TILED"))) + ((STIPPLED) + (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_STIPPLED"))) + ((OPAQUE-STIPPLED) + (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_OPAQUE_STIPPLED"))) + (else (error:datum-out-of-range value))) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FILL")))) + + ((LINE-WIDTH) + (C->= gcvalues "GdkGCValues line_width" value) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_LINE_WIDTH")))) + + ((LINE-STYLE) + (C->= gcvalues "GdkGCValues line_style" value) + (loop (cdr options) (int:+ mask (C-enum "GDK_GC_LINE_STYLE")))) + + (else (warn "Unsupported option name:" name value) + (loop (cdr options) mask)))))))) + +(define-integrable (poke-color target source) + (C->= target "GdkColor red" (C-> source "GdkColor red")) + (C->= target "GdkColor green" (C-> source "GdkColor green")) + (C->= target "GdkColor blue" (C-> source "GdkColor blue")) + (C->= target "GdkColor pixel" (C-> source "GdkColor pixel"))) + +(define-integrable (get-option ink name default) + (let ((entry (assq name (draw-ink-options ink)))) + (if entry (cdr entry) default))) + +(define-integrable (set-option!? ink name value) + ;; If VALUE is null, the option is unset. If the option value is + ;; already VALUE, returns #f (else #t). + (let* ((options (draw-ink-options ink)) + (entry (assq name options)) + (old-value (if entry (cdr entry) '()))) + (if (equal? value old-value) + #f + (begin + (if entry + (if (null? value) + (set-draw-ink-options! ink (delq! entry options)) + (set-cdr! entry value)) + (set-draw-ink-options! ink (cons (cons name value) options))) + #t)))) + +(define-class ( (constructor ())) + () + (vector define standard initializer (lambda () (make-fix-rect 0 0 0 0)))) + +(define-guarantee line-ink "a ") + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((view (fix-layout-view widget)) + (vector (line-ink-vector ink))) + (with-fix-rect + vector + (lambda (x y dx dy) + (let ((x (fix:- x (fix-rect-x view))) + (y (fix:- y (fix-rect-y view)))) + (with-line-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_line" window gc + x y (fix:+ x dx) (fix:+ y dy))))))))) + +(define (with-line-gc ink widget receiver) + ;; For drawing lines (with different defaults than the outline gc). + (with-gc (line-options ink widget) widget receiver)) + +(define (line-options ink widget) + (append-map! + (lambda (entry) + (case (car entry) + ((FOREGROUND) `((FOREGROUND . ,(allocate-color! widget (cdr entry))))) + ((LINE-WIDTH) `((LINE-WIDTH . ,(cdr entry)))) + ((DASH) (cond ((eq? #t (cdr entry)) + `((LINE-STYLE . ,(C-enum "GDK_LINE_ON_OFF_DASH")))) + ((eq? #f (cdr entry)) + `((LINE-STYLE . ,(C-enum "GDK_LINE_SOLID")))) + (else + `((LINE-STYLE . ,(C-enum "GDK_LINE_DOUBLE_DASH")) + (BACKGROUND . ,(allocate-color! widget (cdr entry))))))) + (else '()))) + (draw-ink-options ink))) + +(define-integrable (half-line-width ink) + (fix:max 1 (fix:1+ (quotient (get-option ink 'WIDTH 1) 2)))) + +(define (recache-line-extent! ink) + (with-fix-rect + (line-ink-vector ink) + (lambda (x1 y1 dx dy) + (let ((x2 (fix:+ x1 dx)) + (y2 (fix:+ y1 dy))) + (let ((min-x (fix:min x1 x2)) + (min-y (fix:min y1 y2)) + (max-x (fix:max x1 x2)) + (max-y (fix:max y1 y2)) + (lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink)))))) + +(define (set-line-ink! ink x1 y1 x2 y2) + (guarantee-fixnum x1 'set-line-ink!) + (guarantee-fixnum y1 'set-line-ink!) + (guarantee-fixnum x2 'set-line-ink!) + (guarantee-fixnum y2 'set-line-ink!) + (without-interrupts + (lambda () + (let ((vector (line-ink-vector ink)) + (dx (fix:- x2 x1)) + (dy (fix:- y2 y1))) + (if (not (and (fix:= x1 (fix-rect-x vector)) + (fix:= y1 (fix-rect-y vector)) + (fix:= dx (fix-rect-width vector)) + (fix:= dy (fix-rect-height vector)))) + (begin + (set-fix-rect! vector x1 y1 dx dy) + (recache-line-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (without-interrupts + (lambda () + (let ((vector (line-ink-vector ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! vector dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (line-ink-width ink) + (guarantee-line-ink ink 'line-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-line-ink-width! ink width) + (guarantee-line-ink ink 'set-line-ink-width!) + (guarantee-positive-fixnum width 'set-line-ink-width!) + (without-interrupts + (lambda () + (if (set-option!? ink 'LINE-WIDTH width) + (recache-line-extent! ink))))) + +(define-integrable (guarantee-color-spec spec operator) + (cond ((string? spec) spec) + ((and (vector? spec) (vector-length spec 3)) spec) + (else (error:wrong-type-argument spec "a color" operator)))) + +(define (line-ink-color ink) + (guarantee-line-ink ink 'line-ink-color) + (get-option ink 'FOREGROUND '())) + +(define (set-line-ink-color! ink color) + (guarantee-line-ink ink 'set-line-ink-color!) + (guarantee-color-spec color 'set-line-ink-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'FOREGROUND color) + (drawing-damage ink))))) + +(define (line-ink-dash-color ink) + (guarantee-line-ink ink 'line-ink-dash-color) + (get-option ink 'DASH '())) + +(define (set-line-ink-dash-color! ink color) + (guarantee-line-ink ink 'set-line-ink-dash-color!) + (if (not (or (eq? color #t) (eq? color #f))) + (guarantee-color-spec color 'set-line-ink-dash!)) + (without-interrupts + (lambda () + (if (set-option!? ink 'DASH color) + (drawing-damage ink))))) + +(define-class ( (constructor ())) + () + (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0)))) + +(define-guarantee rectangle-ink "a ") + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((view (fix-layout-view widget)) + (rect (rectangle-ink-rect ink))) + (with-fix-rect + rect + (lambda (x y width height) + (let ((x (fix:- x (fix-rect-x view))) + (y (fix:- y (fix-rect-y view)))) + (with-fill-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_rectangle" window gc 1 x y width height))) + (with-outline-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_rectangle" window gc 0 x y width height)))))))) + +(define (with-fill-gc ink widget receiver) + ;; For filling ovals, rectangles... + (let ((options (fill-options ink widget))) + (if (pair? options) + (with-gc options widget receiver)))) + +(define (fill-options ink widget) + (append-map! + (lambda (entry) + (case (car entry) + ((FILL) `((FOREGROUND . ,(allocate-color! widget (cdr entry))))) + ;;((STIPPLE) `((STIPPLE . ,(bitmap-cache! entry)))) + (else '()))) + (draw-ink-options ink))) + +(define (with-outline-gc ink widget receiver) + ;; For outlining arcs, rectangles... + (let ((options (outline-options ink widget))) + (if (pair? options) + (with-gc options widget receiver)))) + +(define (outline-options ink widget) + (append-map! + (lambda (entry) + (case (car entry) + ((OUTLINE) `((FOREGROUND . ,(allocate-color! widget (cdr entry))))) + ((WIDTH) `((LINE-WIDTH . ,(cdr entry)))) + ;;((STYLE) `((LINE-STYLE . ,(cdr entry)))) + ;;((OUTLINESTIPPLE) `((OUTLINESTIPPLE . ,(bitmap-cache! entry)))) + (else '()))) + (draw-ink-options ink))) + +(define (recache-rectangle-extent! ink) + (with-fix-rect-bounds + (rectangle-ink-rect ink) + (lambda (min-x max-x min-y max-y) + (let ((lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink))))) + +(define (set-rectangle-ink! ink x y width height) + (guarantee-fixnum x 'set-rectangle-ink!) + (guarantee-fixnum y 'set-rectangle-ink!) + (guarantee-non-negative-fixnum width 'set-rectangle-ink!) + (guarantee-non-negative-fixnum height 'set-rectangle-ink!) + (without-interrupts + (lambda () + (let ((rect (rectangle-ink-rect ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)) + (fix:= width (fix-rect-width rect)) + (fix:= height (fix-rect-height rect)))) + (begin + (set-fix-rect! rect x y width height) + (recache-rectangle-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (without-interrupts + (lambda () + (let ((rect (rectangle-ink-rect ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! rect dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (rectangle-ink-width ink) + (guarantee-rectangle-ink ink 'rectangle-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-rectangle-ink-width! ink width) + (guarantee-rectangle-ink ink 'set-rectangle-ink-width!) + (guarantee-positive-fixnum width 'set-rectangle-ink-width!) + (without-interrupts + (lambda () + (if (set-option!? ink 'LINE-WIDTH width) + (recache-rectangle-extent! ink))))) + +(define (rectangle-ink-color ink) + (guarantee-rectangle-ink ink 'rectangle-ink-color) + (get-option ink 'OUTLINE '())) + +(define (set-rectangle-ink-color! ink color) + (guarantee-rectangle-ink ink 'set-rectangle-ink-color!) + (guarantee-color-spec color 'set-rectangle-ink-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'OUTLINE color) + (drawing-damage ink))))) + +(define (rectangle-ink-fill-color ink) + (guarantee-rectangle-ink ink 'rectangle-ink-fill-color) + (get-option ink 'FILL '())) + +(define (set-rectangle-ink-fill-color! ink color) + (guarantee-rectangle-ink ink 'set-rectangle-ink-fill-color!) + (guarantee-color-spec color 'set-rectangle-ink-fill-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'FILL color) + (drawing-damage ink))))) + +(define-class ( (constructor ())) + () + (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0))) + (%start-angle define standard initial-value 0) + (%sweep-angle define standard initial-value (fix:* 64 360))) + +(define-guarantee arc-ink "an ") + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((view (fix-layout-view widget)) + (rect (arc-ink-rect ink))) + (with-fix-rect + rect + (lambda (x y width height) + (let ((x (fix:- x (fix-rect-x view))) + (y (fix:- y (fix-rect-y view)))) + (with-fill-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_arc" window gc 1 x y width height + (arc-ink-%start-angle ink) + (arc-ink-%sweep-angle ink)))) + (with-outline-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_arc" window gc 0 x y width height + (arc-ink-%start-angle ink) + (arc-ink-%sweep-angle ink))))))))) + +(define (recache-arc-extent! ink) + (with-fix-rect-bounds + (arc-ink-rect ink) + (lambda (min-x max-x min-y max-y) + (let ((lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink))))) + +(define (set-arc-ink! ink x y width height) + (guarantee-fixnum x 'set-arc-ink!) + (guarantee-fixnum y 'set-arc-ink!) + (guarantee-non-negative-fixnum width 'set-arc-ink!) + (guarantee-non-negative-fixnum height 'set-arc-ink!) + (without-interrupts + (lambda () + (let ((rect (arc-ink-rect ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)) + (fix:= width (fix-rect-width rect)) + (fix:= height (fix-rect-height rect)))) + (begin + (set-fix-rect! rect x y width height) + (recache-arc-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (without-interrupts + (lambda () + (let ((rect (arc-ink-rect ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! rect dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (arc-ink-start-angle arc) + (/ (arc-ink-%start-angle arc) 64)) + +(define (set-arc-ink-start-angle! arc degrees) + (let ((new (modulo (round (* 64 degrees)) (fix:* 64 360)))) + (if (not (fix:= new (arc-ink-%start-angle arc))) + (begin + (set-arc-ink-%start-angle! arc new) + (drawing-damage arc))))) + +(define-integrable (arc-ink-sweep-angle arc) + (/ (arc-ink-%sweep-angle arc) 64)) + +(define (set-arc-ink-sweep-angle! arc degrees) + (let ((new (fix:min (round (* 64 degrees)) (fix:* 64 360)))) + (if (not (fix:= new (arc-ink-%sweep-angle arc))) + (begin + (set-arc-ink-%sweep-angle! arc new) + (drawing-damage arc))))) + +(define (arc-ink-width ink) + (guarantee-arc-ink ink 'arc-ink-width) + (get-option ink 'WIDTH '())) + +(define (set-arc-ink-width! ink width) + (guarantee-arc-ink ink 'set-arc-ink-width!) + (guarantee-positive-fixnum width 'set-arc-ink-width!) + (without-interrupts + (lambda () + (if (set-option!? ink 'WIDTH width) + (recache-arc-extent! ink))))) + +(define (arc-ink-color ink) + (guarantee-arc-ink ink 'arc-ink-color) + (get-option ink 'OUTLINE '())) + +(define (set-arc-ink-color! ink color) + (guarantee-arc-ink ink 'set-arc-ink-color!) + (guarantee-color-spec color 'set-arc-ink-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'OUTLINE color) + (drawing-damage ink))))) + +(define (arc-ink-fill-color ink) + (guarantee-arc-ink ink 'arc-ink-fill-color) + (get-option ink 'FILL '())) + +(define (set-arc-ink-fill-color! ink color) + (guarantee-arc-ink ink 'set-arc-ink-fill-color!) + (guarantee-color-spec color 'set-arc-ink-fill-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'FILL color) + (drawing-damage ink))))) + +(define-class ( (constructor ())) + ()) + +(define-guarantee text-ink "a ") + +;; The PangoLayout for gdk_draw_layout in the expose handler. +(define-generic text-ink-pango-layout (ink)) + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((view (fix-layout-view widget)) + (rect (fix-ink-extent ink))) + (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view))) + (y (fix:- (fix-rect-y rect) (fix-rect-y view))) + (layout (text-ink-pango-layout ink))) + (if layout + (with-text-gc + ink widget + (lambda (gc) + (C-call "gdk_draw_layout" window gc x y + (gobject-alien layout)))))))) + +(define (with-text-gc ink widget receiver) + (with-gc (text-options ink widget) widget receiver)) + +(define (text-options ink widget) + (append-map! + (lambda (entry) + (case (car entry) + ((FOREGROUND) `((FOREGROUND . ,(allocate-color! widget (cdr entry))))) + (else '()))) + (draw-ink-options ink))) + +(define (set-text-ink-position! ink x y) + (guarantee-fixnum x 'set-text-ink-position!) + (guarantee-fixnum y 'set-text-ink-position!) + (without-interrupts + (lambda () + (let ((rect (fix-ink-extent ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)))) + (begin + (drawing-damage ink) + (set-fix-rect-position! rect x y) + (drawing-damage ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (without-interrupts + (lambda () + (let ((extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (recache-text-extent! ink) + (let ((layout (text-ink-pango-layout ink)) + (ink-extent (pango-rectangle)) + (logical-extent (pango-rectangle))) + (trace ";recache-text-extent!") + (C-call "pango_layout_get_pixel_extents" + (gobject-alien layout) 0 logical-extent) + (drawing-damage ink) + ;; Can ink extend beyond the logical extent? + (set-fix-rect-size! (fix-ink-extent ink) + (C-> logical-extent "GdkRectangle width") + (C-> logical-extent "GdkRectangle height")) + (drawing-damage ink) + (free ink-extent) + (free logical-extent))) + +(define (text-ink-color ink) + (guarantee-text-ink ink 'text-ink-color) + (get-option ink 'FOREGROUND '())) + +(define (set-text-ink-color! ink color) + (guarantee-text-ink ink 'set-text-ink-color!) + (guarantee-color-spec color 'set-text-ink-color!) + (without-interrupts + (lambda () + (if (set-option!? ink 'FOREGROUND color) + (drawing-damage ink))))) + +(define (text-ink-xy-to-index ink x y) + (let ((layout (text-ink-pango-layout ink))) + (if layout + (let ((extent (fix-ink-extent ink)) + (index-alien (malloc (C-sizeof "int") 'int)) + (layout-alien (gobject-alien layout))) + (let ((xL (fix:- x (fix-rect-x extent))) ; layout coords. + (yL (fix:- y (fix-rect-y extent)))) + (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout-alien + (pixels->pangos xL) (pixels->pangos yL) + index-alien 0)) + (begin + (free index-alien) + #f) + (let ((index (C-> index-alien "int"))) + (free index-alien) + index)))) + #f))) + +(define (with-text-ink-grapheme-rect ink index receiver) + (let ((layout (text-ink-pango-layout ink))) + (if layout + (let ((rect (pango-rectangle)) + (alien (gobject-alien layout))) + (C-call "pango_layout_index_to_pos" alien index rect) + (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) + (y (pangos->pixels (C-> rect "PangoRectangle y"))) + (width (pangos->pixels (C-> rect "PangoRectangle width"))) + (height (pangos->pixels (C-> rect "PangoRectangle height")))) + (free rect) + (receiver x y width height))) + #f))) + +(define (->pango-font-description spec operator) + (cond ((and (alien? spec) (eq? '|PangoFontDescription| (alien/ctype spec))) + spec) + ((string? spec) + (or (hash-table/get cached-font-descriptions spec #f) + (let ((alien (pango-font-description-from-string spec))) + (if (not alien) + (error:wrong-type-argument spec "PangoFontDescription" + operator)) + (hash-table/put! cached-font-descriptions spec alien) + alien))) + (else (error:wrong-type-argument spec "PangoFontDescription" + operator)))) + +(define cached-font-descriptions (make-string-hash-table)) + +(define (reset-font-descriptions!) + (hash-table/clear! cached-font-descriptions)) + +(add-event-receiver! event:after-restore reset-font-descriptions!) + +(define-class ( (constructor ())) + () + + ;; A Scheme string. The content of the paragraph. + (text define standard initial-value #f modifier set-simple-text-ink-%text!) + + ;; Corresponding PangoLayout. + (pango-layout define standard initial-value #f)) + +(define-guarantee simple-text-ink "a ") + +(define-method text-ink-pango-layout ((ink )) + ;; Simply return the PangoLayout, which is only #f if no text has + ;; (ever) been set. + (simple-text-ink-pango-layout ink)) + +(define (set-simple-text-ink-text! ink widget text) + ;; The TEXT string is shared. + (guarantee-simple-text-ink ink 'set-simple-text-ink-text!) + (guarantee-gtk-widget widget 'set-simple-text-ink-text!) + (guarantee-string text 'set-simple-text-ink-text!) + (without-interrupts + (lambda () + (let ((old (simple-text-ink-text ink))) + (if (not (and old (string=? text old))) + (let ((layout (simple-text-ink-pango-layout ink))) + (if layout + (pango-layout-set-text layout text) + (let* ((desc (get-option ink 'FONT #f)) + (layout + (if desc + (let ((layout + (gtk-widget-create-pango-layout widget ""))) + (pango-layout-set-font-description layout desc) + (pango-layout-set-text layout text) + layout) + (gtk-widget-create-pango-layout widget text)))) + (set-simple-text-ink-pango-layout! ink layout))) + (set-simple-text-ink-%text! ink text) + (recache-text-extent! ink))))))) + +(define (simple-text-ink-font ink) + (guarantee-simple-text-ink ink 'simple-text-ink-font) + (get-option ink 'FONT #f)) + +(define (set-simple-text-ink-font! ink font) + (guarantee-simple-text-ink ink 'set-simple-text-ink-font!) + (let ((new (->pango-font-description font 'set-simple-text-ink-font!))) + (without-interrupts + (lambda () + (let ((layout (simple-text-ink-pango-layout ink))) + (if (and (set-option!? ink 'FONT new) layout) + (begin + (pango-layout-set-font-description layout new) + (recache-text-extent! ink)))))))) + +(define-class ( (constructor ())) + () + ;; This slot is set to a soon after loading has begun. + (pixbuf define standard initial-value #f) + ;; This slot is set to #f when the pixbuf has been successfully loaded. + (loader define standard initializer make-pixbuf-loader)) + +(define-method initialize-instance ((ink )) + (trace ";((initialize-instance ) "ink")...\n") + (call-next-method ink) + (let ((loader (image-ink-loader ink))) + (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink)) + (set-pixbuf-loader-pixbuf-hook! loader (image-ink-pixbuf-prepared ink)) + (set-pixbuf-loader-update-hook! loader (image-ink-pixbuf-updated ink)) + (set-pixbuf-loader-close-hook! loader (image-ink-pixbuf-loaded ink)))) + +(define (image-ink-size-prepared ink) + (named-lambda (image-ink-size-prepared-handler width height) + (trace ";image-ink-size-prepared-handler "ink" "width" "height"\n") + (set-fix-ink-%size! ink width height))) + +(define (image-ink-pixbuf-prepared ink) + (named-lambda (image-ink-pixbuf-prepared-handler pixbuf) + (trace ";image-ink-pixbuf-prepared-handler "ink" "pixbuf"\n") + (set-image-ink-pixbuf! ink pixbuf))) + +(define (image-ink-pixbuf-updated ink) + (named-lambda (image-ink-pixbuf-updated-handler x y width height) + (let ((rect (make-fix-rect x y width height))) + (trace ";image-ink-pixbuf-updated-handler "ink" "rect"\n") + (drawing-damage ink rect)))) + +(define (image-ink-pixbuf-loaded ink) + (named-lambda (image-ink-pixbuf-loaded-handler loader) + (trace ";image-ink-pixbuf-loaded-handler "ink" ("(image-ink-pixbuf ink)")" + " "(pixbuf-loader-error-message loader)"\n") + (if (not (pixbuf-loader-error-message loader)) + (begin + (set-image-ink-loader! ink #f) + (gobject-unref! loader)) + (begin + ;; Hack the pixbuf with a "broken image" overlay? + ;; + ;; Leave the loader, with dead thread and closed + ;; input-port, for debugging purposes. + unspecific)))) + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + + (let ((pixbuf (let ((p (image-ink-pixbuf ink))) + (if p (gobject-alien p) #f)))) + (if (and pixbuf (not (alien-null? pixbuf))) + (let ((extent (fix-ink-extent ink)) + (view (fix-layout-view widget))) + (let ((i (fix-rect-intersection extent area)) + (view-x (fix-rect-x view)) + (view-y (fix-rect-y view))) + (with-gc '() widget + (lambda (gc) + (C-call "gdk_draw_pixbuf" window gc + pixbuf + ;; drawing->image + (fix:- (fix-rect-x i) (fix-rect-x extent)) ;src_x + (fix:- (fix-rect-y i) (fix-rect-y extent)) ;src_y + ;; drawing->window + (fix:- (fix-rect-x i) view-x) ;dest_x + (fix:- (fix-rect-y i) view-y) ;dest_y + (fix-rect-width i) (fix-rect-height i) + (C-enum "GDK_RGB_DITHER_NONE") + 0 0 ;x_dither, y_dither + )))))))) + +(define (make-image-ink-from-file filename) + (let ((ink (make-image-ink))) + (load-pixbuf-from-file (image-ink-loader ink) filename) + ink)) + +(define (set-image-ink! ink x y) + (guarantee-fixnum x 'set-image-ink-position!) + (guarantee-fixnum y 'set-image-ink-position!) + (set-fix-ink-%position! ink x y)) + +;;; Inks implemented by gtk_paint_*, using widget style/state. + +(define-class ( (constructor ())) + () + ;; Just hoping that the effects of style xthickness, ythickness, + ;; etc. do not drop ink beyond the ink-extent. + (%shadow define standard initial-value (C-enum "GTK_SHADOW_NONE"))) + +(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((alien (gobject-alien widget)) + (view (fix-layout-view widget)) + (extent (fix-ink-extent ink))) + (let ((style (C-> alien "GtkWidget style")) + (state (C-> alien "GtkWidget state"))) + (C-call "gtk_paint_box" + style window state (C-enum "GTK_SHADOW_NONE") + 0 alien 0 ;area widget detail + (fix:- (fix-rect-x extent) (fix-rect-x view)) + (fix:- (fix-rect-y extent) (fix-rect-y view)) + (fix-rect-width extent) + (fix-rect-height extent))))) + +(define (set-box-ink! ink x y width height) + (guarantee-fixnum x 'set-box-ink!) + (guarantee-fixnum y 'set-box-ink!) + (guarantee-non-negative-fixnum width 'set-box-ink!) + (guarantee-non-negative-fixnum height 'set-box-ink!) + (set-fix-ink! ink x y width height)) + +(define (set-box-ink-position! ink x y) + (guarantee-fixnum x 'set-box-ink!) + (guarantee-fixnum y 'set-box-ink!) + (set-fix-ink-%position! ink x y)) + +(define (box-ink-shadow ink) + (let ((shadow (box-ink-%shadow ink))) + (cond + ((int:= shadow (C-enum "GTK_SHADOW_NONE")) 'NONE) + ((int:= shadow (C-enum "GTK_SHADOW_IN")) 'IN) + ((int:= shadow (C-enum "GTK_SHADOW_OUT")) 'OUT) + ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN) + ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT) + (else (error "Invalid box-ink %shadow:" shadow))))) + +(define (set-box-ink-shadow! ink type) + (let ((new + (case type + ((NONE) (C-enum "GTK_SHADOW_NONE")) + ((IN) (C-enum "GTK_SHADOW_IN")) + ((OUT) (C-enum "GTK_SHADOW_OUT")) + ((ETCHED-IN) (C-enum "GTK_SHADOW_ETCHED_IN")) + ((ETCHED-OUT) (C-enum "GTK_SHADOW_ETCHED_OUT")) + (else (error:bad-range-argument type 'set-box-ink-shadow!))))) + (if (not (fix:= new (box-ink-%shadow ink))) + (begin + (set-box-ink-%shadow! ink new) + ;; Depending on the shadow type, adjust the inked extent?!!! + (drawing-damage ink))))) + +;; Punting the rest of gtk_paint_* until style members like +;; x/ythickness can be accounted for in the fix-ink-extent. + +#;(define-class ( (constructor ())) + ()) + +#;(define-method fix-ink-expose-callback ((ink ) widget window area) + (declare (ignore area)) + (trace2 "; (Re)Drawing "ink" on "widget".\n") + (let ((alien (gobject-alien widget)) + (view (fix-layout-view widget)) + (extent (fix-ink-extent ink))) + (let ((style (C-> alien "GtkWidget style")) + (state (C-> alien "GtkWidget state")) + (x (fix:- (fix-rect-x extent) (fix-rect-x view))) + (y (fix:- (fix-rect-y extent) (fix-rect-y view)))) + (C-call "gtk_paint_hline" + style window state + 0 alien 0 ;area widget detail + x (fix:+ x (fix-rect-width extent)) + y)))) + +;;;; Fixnum Rectangles + +(define-structure (fix-rect (constructor make-fix-rect (#!optional x y width height)) + (copier) + (print-procedure + (standard-unparser-method 'FIX-RECT + (lambda (rect port) + (write-string " " port) + (write-string (fix-rect-string rect) port))))) + (x #f) (y #f) (width #f) (height #f)) + +(define (fix-rect-string rect) + (define-integrable (S a) (write-to-string a)) + (string-append (S (fix-rect-x rect))","(S (fix-rect-y rect)) + " "(S (fix-rect-width rect))"x"(S (fix-rect-height rect)))) + +(define-integrable-operator (make-fix-rect-from-bounds min-x min-y max-x max-y) + (make-fix-rect min-x min-y (fix:- max-x min-x) (fix:- max-y min-y))) + +(define-integrable-operator (set-fix-rect! rect x y width height) + (set-fix-rect-x! rect x) + (set-fix-rect-y! rect y) + (set-fix-rect-width! rect width) + (set-fix-rect-height! rect height)) + +(define-integrable-operator (set-fix-rect-bounds! rect min-x max-x min-y max-y) + (set-fix-rect-x! rect min-x) + (set-fix-rect-y! rect min-y) + (set-fix-rect-width! rect (fix:- max-x min-x)) + (set-fix-rect-height! rect (fix:- max-y min-y))) + +(define-integrable-operator (set-fix-rect-position! rect x y) + (set-fix-rect-x! rect x) + (set-fix-rect-y! rect y)) + +(define-integrable-operator (fix-rect-move! rect dx dy) + (set-fix-rect-x! rect (fix:+ (fix-rect-x rect) dx)) + (set-fix-rect-y! rect (fix:+ (fix-rect-y rect) dy))) + +(define-integrable-operator (set-fix-rect-size! rect width height) + (set-fix-rect-width! rect width) + (set-fix-rect-height! rect height)) + +(define-integrable-operator (fix-rect-nominal? rect) + (and (fixnum? (fix-rect-x rect)) + (fixnum? (fix-rect-y rect)) + (fixnum? (fix-rect-width rect)) + (fixnum? (fix-rect-height rect)))) + +;;; The rest of these procedures assume a "nominal" rectangle. + +(define-integrable-operator (fix-rect-max-y rect) + (fix:+ (fix-rect-y rect) (fix-rect-height rect))) + +(define-integrable-operator (fix-rect-max-x rect) + (fix:+ (fix-rect-x rect) (fix-rect-width rect))) + +(define-integrable fix-rect-min-x fix-rect-x) +(define-integrable fix-rect-min-y fix-rect-y) + +(define-integrable-operator (with-fix-rect-bounds rect receiver) + ;; Tail-calls RECEIVER with the RECT's minx, maxx, miny and maxy (in + ;; that order). Assumes RECT is nominal. + (let ((x (fix-rect-x rect)) + (y (fix-rect-y rect)) + (width (fix-rect-width rect)) + (height (fix-rect-height rect))) + (receiver x (fix:+ x width) y (fix:+ y height)))) + +(define-integrable-operator (with-fix-rect rect receiver) + (receiver (fix-rect-x rect) (fix-rect-y rect) (fix-rect-width rect) (fix-rect-height rect))) + +(define-integrable-operator (copy-fix-rect! target source) + (set-fix-rect-x! target (fix-rect-x source)) + (set-fix-rect-y! target (fix-rect-y source)) + (set-fix-rect-width! target (fix-rect-width source)) + (set-fix-rect-height! target (fix-rect-height source))) + +(define-integrable-operator (point-in-fix-rect? x y rect) + (with-fix-rect-bounds rect + (lambda (min-x max-x min-y max-y) + (and (fix:<= min-x x) (fix:<= x max-x) + (fix:<= min-y y) (fix:<= y max-y))))) + +(define-integrable-operator (fix-rect-at-point? rect x y) + (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)))) + +(define-integrable-operator (fix-rect-intersect? rect1 rect2) + ;; Useful when you do not need to cons a new rect. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((fix:< max-x1 min-x2) #f) + ((fix:< max-y1 min-y2) #f) + ((fix:< max-x2 min-x1) #f) + ((fix:< max-y2 min-y1) #f) + (else #t))))))) + +(define (fix-rect-intersection rect1 rect2) + ;; Returns #f if RECT1 and RECT2 do not intersect, else returns a + ;; new rect -- the intersection. Assumes both rectangles are + ;; nominal. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((fix:< max-x1 min-x2) #f) + ((fix:< max-y1 min-y2) #f) + ((fix:< max-x2 min-x1) #f) + ((fix:< max-y2 min-y1) #f) + (else + (let ((min-x (fix:max min-x1 min-x2)) + (min-y (fix:max min-y1 min-y2)) + (max-x (fix:min max-x1 max-x2)) + (max-y (fix:min max-y1 max-y2))) + (make-fix-rect min-x min-y + (fix:- max-x min-x) + (fix:- max-y min-y)))))))))) + +(define (window-intersection window item) + ;; Returns #f if WINDOW and ITEM do not intersect, else returns a + ;; new rect -- the intersection *translated* to WINDOW's coords. + ;; Assumes both rectangles are nominal. + (with-fix-rect-bounds window + (lambda (window-x-start window-x-end window-y-start window-y-end) + (with-fix-rect-bounds item + (lambda (item-x-start item-x-end item-y-start item-y-end) + (cond ((fix:< window-x-end item-x-start) #f) + ((fix:< window-y-end item-y-start) #f) + ((fix:< item-x-end window-x-start) #f) + ((fix:< item-y-end window-y-start) #f) + (else + (let ((x (fix:max window-x-start item-x-start)) + (y (fix:max window-y-start item-y-start)) + (x-end (fix:min window-x-end item-x-end)) + (y-end (fix:min window-y-end item-y-end))) + (make-fix-rect (fix:- x window-x-start) + (fix:- y window-y-start) + (fix:- x-end x) + (fix:- y-end y)))))))))) + +(define (fix-rect-union! rect1 rect2) + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (let ((x (fix:min min-x1 min-x2)) + (y (fix:min min-y1 min-y2))) + (set-fix-rect! rect1 + x y + (fix:- (fix:max max-x1 max-x2) x) + (fix:- (fix:max max-y1 max-y2) y)))))))) + +(define (fix-rect-contains? rect1 rect2) + ;; True if RECT2 is wholly contained within RECT1. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (and (fix:<= min-x1 min-x2) (fix:<= max-x2 max-x1) + (fix:<= min-y1 min-y2) (fix:<= max-y2 max-y1))))))) + +(define (gdk-rectangle #!optional x y width height) + (if (not (default-object? x)) (guarantee-fixnum x 'gdk-rectangle)) + (if (not (default-object? y)) (guarantee-fixnum y 'gdk-rectangle)) + (if (not (default-object? width)) (guarantee-non-negative-fixnum width 'gdk-rectangle)) + (if (not (default-object? height)) (guarantee-non-negative-fixnum height 'gdk-rectangle)) + (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|))) + (if (default-object? x) alien + (begin + (C->= alien "GdkRectangle x" x) + (if (default-object? y) alien + (begin + (C->= alien "GdkRectangle y" y) + (if (default-object? width) alien + (begin + (C->= alien "GdkRectangle width" width) + (if (default-object? height) alien + (begin + (C->= alien "GdkRectangle height" height) + alien)))))))))) + +(define (gdk-rectangle-from-rect rect) + (gdk-rectangle (fix-rect-x rect) (fix-rect-y rect) + (fix-rect-width rect) (fix-rect-height rect))) + + +(define trace? #f) + +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(define trace2? #f) + +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index f1b27f5cb..65d871bb3 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -24,13 +24,12 @@ USA. ;;;; GtkObjects ;;; package: (gtk gobject) - (c-include "gtk") (define-class () - ;; The GObject alien. A null alien if the toolkit object has not - ;; been created (yet), or has been finalized. + ;; The address of the toolkit object. A null alien if the GObject + ;; has not been created (yet), or has been unrefed. (alien define accessor initializer (lambda () (make-alien '|GObject|))) @@ -39,135 +38,115 @@ USA. ;; IDs and toolkit handles. In this alist, a callback ID will be #f ;; if the signal was disconnected. (signals define standard - initializer (lambda () (list 'GOBJECT-SIGNALS)))) + initializer (lambda () (list 'GOBJECT-SIGNALS))) + + ;; This instance's weak-pair on the gc-cleanups list. This is + ;; cached here mainly for g-signal-connect, which must create + ;; callbacks that only weakly reference this instance. + (weak-self define standard)) -(define-integrable (gobject-finalized? object) - (alien-null? (gobject-alien object))) +(define-guarantee gobject "a ") + +(define-integrable (gobject-live? object) + (not (alien-null? (gobject-alien object)))) (define-method initialize-instance ((object )) - ;; Arrange for all gobject signal handlers to be de-registered if - ;; GCed. The object itself is g_object_unref'ed. - (add-gc-cleanup object - (gobject-cleanup-thunk (gobject-alien object) - (gobject-signals object)))) - -(define (gobject-cleanup-thunk alien signals) - ;; Return a thunk closed over ALIEN and SIGNALS (but not the - ;; gobject). - (named-lambda (gobject::cleanup-thunk) - (trace ";gobject::cleanup-thunk "alien"\n") - (gobject-cleanup alien signals) - (trace ";gobject::cleanup-thunk done with "alien"\n"))) + (call-next-method object) + (set-gobject-weak-self! + object (add-gc-cleanup object (make-gobject-cleanup-thunk + (gobject-alien object) + (gobject-signals object))))) + +(define (make-gobject-cleanup-thunk alien signals) + ;; This separate procedure ensures that the gobject is not caught in + ;; the closure. + (named-lambda (gobject-cleanup-thunk) + (gobject-cleanup alien signals))) + +(define (gobject-unref! object) + (without-interrupts + (lambda () + (gobject-cleanup (gobject-alien object) (gobject-signals object)) + (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups))))) (define (gobject-cleanup alien signals) - ;; Run as a gc-cleanup, without-interrupts. Calls g_object_unref - ;; (if necessary), and de-registers the Scheme signal handlers. - (trace ";gobject::cleanup "alien"\n") + ;; Run as a gc-daemon, or with exclusive write access to ALIEN and + ;; SIGNALS (or without-interrupts). + + (trace ";gobject-cleanup "alien"\n") (if (not (alien-null? alien)) (begin + (for-each + (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle))) + (cdr signals)) (C-call "g_object_unref" alien) (alien-null! alien))) - (for-each (lambda (name.id.handle) - (let* ((id.handle (cdr name.id.handle)) - (id (car id.handle))) - (if id - (begin - (de-register-c-callback id) - (set-car! id.handle #f) - (set-cdr! id.handle #f))))) - (cdr signals)) - (trace ";gobject::cleanup done with "alien"\n")) - -(define (gobject-unref object) - ;; Calls g_object_unref to release Scheme's reference to the toolkit - ;; object. May be called multiple times; g_object_unref will be - ;; called once (per wrapper object). + (trace ";gobject-cleanup done with "alien"\n")) + +(define (g-signal-connect gobject alien-function callback) + (guarantee-gobject gobject 'g-signal-connect) + (guarantee-alien-function alien-function 'g-signal-connect) (without-interrupts (lambda () - (gobject-cleanup (gobject-alien object) (gobject-signals object))))) - -(define (g-signal-connect object alien-function handler) - ;; Allocate a callback and connect it with g_signal_connect_... The - ;; signal name is assumed to be the same as ALIEN-FUNCTION's name, - ;; e.g. in - ;; - ;; (g-signal-connect window (C-callback "delete_event") method) - ;; - ;; the signal name is assumed to be "delete_event". - - (let* ((name (alien-function/name alien-function)) - (sym (string->symbol name)) - (alien (gobject-alien object)) - (signals (gobject-signals object)) - (sym.id.handle (or (assq sym (cdr signals)) - (let ((entry (cons* sym #f #f))) - (set-cdr! signals (cons entry (cdr signals))) - entry))) - (id.handle (cdr sym.id.handle))) - ;; Disconnect existing signal handler. - (g-signal-disconnect!? alien id.handle) - ;; Connect. - (without-interrupts - (lambda () - (let ((id (car id.handle))) - (if (not id) - (let ((newid (register-c-callback handler))) - (set-car! id.handle newid) - (set-cdr! id.handle - (C-call "g_signal_connect_data" - alien name - alien-function newid - null-alien 0))))))))) - -(define (g-signal-disconnect object name) - (let* ((str (if (string? name) name - (ferror "The signal name ("name") is not a string."))) - (sym (string->symbol str)) - (signals (gobject-signals object)) - (alien (gobject-alien object)) - (sym.id.handle (assq sym (cdr signals)))) - (if (not sym.id.handle) - (ferror "No signal "name" on "object" to disconnect.") - (if (not (g-signal-disconnect!? alien (cdr sym.id.handle))) - (fwarn "Signal "name" already disconnected from "object"."))))) - -(define (g-signal-disconnect!? alien id.handle) - ;; Don't even THINK about recovering pairs from the signal list. + (let* ((name (alien-function/name alien-function)) + (sym (string->symbol name)) + (alien (gobject-alien gobject)) + (signals (gobject-signals gobject)) + (sym.id.handle (or (assq sym (cdr signals)) + (let ((entry (cons* sym #f #f))) + (set-cdr! signals (cons entry (cdr signals))) + entry)))) + (disconnect!? alien (cdr sym.id.handle)) + (connect! alien sym.id.handle + alien-function + (register-c-callback + (make-gobject-signal-callback + sym (gobject-weak-self gobject) callback))))))) + +(define (make-gobject-signal-callback name weak-pair callback) + (named-lambda (gobject-signal-callback instance . args) + (declare (ignore instance)) + ;; Callbacks run without-interrupts. + (if (weak-pair/car? weak-pair) + (let ((gobject (weak-car weak-pair))) + (if-debugging + (if (not (alien=? (gobject-alien gobject) instance)) + (warn "Signal instance / gobject mismatch:" instance gobject))) + (apply callback gobject args)) + (error "Cannot signal a that is already GC'ed:" name args)))) + +(define (connect! alien sym.id.handle alien-function newid) + (let ((id.handle (cdr sym.id.handle))) + (set-car! id.handle newid) + (set-cdr! id.handle + (C-call "g_signal_connect_data" alien + (alien-function/name alien-function) + alien-function newid 0 0)))) + +(define (g-signal-disconnect gobject name) + (guarantee-gobject gobject 'g-signal-disconnect) + (guarantee-symbol name 'g-signal-disconnect) (without-interrupts (lambda () - (let ((id (car id.handle))) - (and id - (begin - (C-call "g_signal_handler_disconnect" alien (cdr id.handle)) - (set-cdr! id.handle #f) - (de-register-c-callback (car id.handle)) - (set-car! id.handle #f) - #t)))))) + (let* ((alien (gobject-alien gobject)) + (signals (gobject-signals gobject)) + (name.id.handle (assq name (cdr signals)))) + (if (not name.id.handle) + (warn "No signal to disconnect:" name gobject) + (if (not (disconnect!? alien (cdr name.id.handle))) + (warn "Signal already disconnected:" name gobject))))))) + +(define (disconnect!? alien id.handle) + (if (eq? (car id.handle) #f) + #f + (begin + (C-call "g_signal_handler_disconnect" alien (cdr id.handle)) + (de-register-c-callback (car id.handle)) + (set-car! id.handle #f) + #t))) - ;;; GC Cleanups -;;; Intended for any object needing a cleanup after it is GCed (any -;;; GObject?). Like the code in FFI/malloc.scm but does not need to -;;; make copies (and keep the copies consistent). These cleanup -;;; thunks can share an object's aliens at least -- something not -;;; possible for malloc! The shared structures (aliens) do not -;;; reference the object, and can be held strongly. - -;;; Note that a cleanup thunk cannot refer to its object. It should -;;; not even close over a variable referring to the object. It -;;; probably should not refer to any other object hoping for a -;;; cleanup. - -;;; A cleanup thunk may be called multiple times, so it might -;;; check first for a nulled alien before freeing a resource, and null -;;; that alien without interrupts after the resource is freed. - -;;; These cleanups are run by the gtk-thread, for easy error handling. -;;; They are rather complex to run at after-gc interrupt level (as -;;; gc-daemons). They callout and thus may run callbacks that run -;;; callouts... - (define gc-cleanups) (define (initialize-gc-cleanups!) @@ -192,13 +171,14 @@ USA. (define (reset-gc-cleanups!) (set! gc-cleanups '())) -(define (add-gc-cleanup object cleanup-thunk) - (without-interrupts - (lambda () - (set! gc-cleanups - (cons (weak-cons object cleanup-thunk) gc-cleanups))))) +(define-integrable (add-gc-cleanup object cleanup-thunk) + (let ((weak-pair (weak-cons object cleanup-thunk))) + (without-interrupts + (lambda () + (set! gc-cleanups (cons weak-pair gc-cleanups)))) + weak-pair)) -(define (punt-gc-cleanup object) +(define-integrable (punt-gc-cleanup object) (without-interrupts (lambda () (let ((entry (weak-assq object gc-cleanups))) @@ -220,22 +200,22 @@ USA. ;;; Properties (define (gobject-get-property gobject property) + (guarantee-gobject gobject 'gobject-get-property) - (let ((object (check-gobject gobject)) - (name (check-prop-name property)) + (let ((name (check-prop-name property)) (gvalue (malloc (C-sizeof "GValue") '|GValue|))) (define (unimplemented type) - (ferror "Property "name" (for "object") is "type" (unimplemented).")) + (error "Unimplemented property type:" type name gobject)) - (C-call "g_object_get_property" (gobject-alien object) name gvalue) + (C-call "g_object_get_property" (gobject-alien gobject) name gvalue) (let* ((type (C-> gvalue "GValue g_type")) (value (cond ((int:= type (C-enum "G_TYPE_INVALID")) - (ferror "Property "name" (for "object") is invalid.")) + (error "Invalid property:" name gobject)) ((int:= type (C-enum "G_TYPE_NONE")) - (ferror "Property "name" (for "object") is void.")) + (error "Void property:" name gobject)) ((int:= type (C-enum "G_TYPE_INTERFACE")) (unimplemented "an interface")) ((int:= type (C-enum "G_TYPE_CHAR")) @@ -281,40 +261,34 @@ USA. (C-call "g_value_get_object" alien gvalue) alien)) (else - (ferror "Unexpected GFundamentalType " - (C-enum "enum GFundamentalType" type) - " ("type")."))))) + (error "Unexpected GFundamentalType:" type))))) (free gvalue) value))) (define (gobject-set-properties gobject . property-list) ;; WAS primitive G-OBJECT-SET-PROPERTIES [gtk.c] - (let* ((object (check-gobject gobject)) - (object-alien (gobject-alien object)) + (let* ((gobject-alien (gobject-alien gobject)) (gvalue (malloc (C-sizeof "GValue") '|GValue|)) (pspec (malloc (C-sizeof "GParamSpec") '|GParamSpec|)) (gtype (malloc (C-sizeof "GType") '|GType|)) - (gclass (gobject-get-gclass object-alien)) + (gclass (gobject-get-gclass gobject-alien)) (gclass-name (gclass-get-name gclass))) (let loop ((plist property-list)) (cond ((null? plist) unspecific) ((not (and (pair? plist) (pair? (cdr plist)))) - (ferror "Odd length property list: "property-list)) + (error "Odd length property list:" property-list)) (else (let ((name (check-prop-name (car plist))) (value (cadr plist))) (C-call "g_object_class_find_property" pspec gclass name) (if (alien-null? pspec) - (ferror "There is no "name" property for class " - gclass-name".")) + (error "No property:" name gclass-name)) (let ((flags (C-> pspec "GParamSpec flags"))) (if (flag-set? flags (C-enum "G_PARAM_WRITABLE")) - (ferror "The "name" property of " - gclass-name" is not writable.")) + (error "Property not writable:" name gclass-name)) (if (not (flag-set? flags (C-enum "G_PARAM_CONSTRUCT_ONLY"))) - (ferror "The "name" property of " - gclass-name" may not be set" - " outside its constructor.")) + (error "Property not writable outside constructor:" + name gclass-name)) (C-call "G_PARAM_SPEC_VALUE_TYPE" gtype pspec) (C-call "g_value_init" gvalue gtype) ;; g_value_set_* gvalue * @@ -361,27 +335,21 @@ USA. (cond ((gobject? value) (gobject-alien value)) ((alien? value) value) (else - (ferror - "The value "value" for property " - name" of "gclass-name" is not a" - " nor alien.")))) + (error "Property value not an object:" + value name gclass-name)))) (value-gtype (gobject-get-gtype value-alien))) (if (fix:zero? (C-call "g_value_type_compatible" value-gtype gtype)) - (ferror "The value "value" for property " - name" of "gclass-name - " has incompatible type " - (gclass-get-name - (gobject-get-gclass value-alien)) - ".")) + (error "Property value incompatible:" + value name gclass-name)) (C-call "g_value_set_object" gvalue value-alien))) (else - (ferror "Fundamental GType " - (C-enum "enum GFundamentalType" fundamental) - " (the type of the "name" property of a " - gclass-name") is not supported.")))) - (C-call "g_object_set_property" object-alien name gvalue) + (error "Property type unsupported:" + (or (C-enum "enum GFundamentalType" fundamental) + fundamental) + name gclass-name)))) + (C-call "g_object_set_property" gobject-alien name gvalue) (C-call "g_value_reset" gvalue))) (loop (cddr plist))))) (free gtype) @@ -408,24 +376,18 @@ USA. (define (flag-set? fixnum mask) (not (fix:zero? (fix:and fixnum mask)))) -(define (check-gobject obj) - (if (gobject? obj) - (if (gobject-finalized? obj) obj - (ferror "The object "obj" has been finalized.")) - (ferror "The object "obj" is not a instance."))) - (define (check-prop-name name) ;; Allows NAME to be a symbol OR string. (cond ((symbol? name) (symbol-name name)) ((string? name) name) (else (check-prop-name - (ferror "Invalid property name "name"."))))) + (error "Invalid property name:" name))))) (define (check-prop-value value property verb-phrase type-predicate) (if (type-predicate value) value (check-prop-value - (ferror "The value ("value") for the " - property" property must "verb-phrase".") + (error (string-append "Property value must " verb-phrase ":") + value property) property verb-phrase type-predicate))) (define (check-prop-char value name) @@ -480,7 +442,6 @@ USA. (define (check-prop-gobject value name) (check-prop-value value name "be a gobject" gobject?)) - ;;; GQuarks ;;; No way (nor need) to GC. Cache them here and toss cache when @@ -491,7 +452,6 @@ USA. (define gquark-to-string-cache (make-eqv-hash-table)) (define (gquark-from-string string) - ;; Returns the GQuark, an integer. (or (hash-table/get gquark-from-string-cache string #f) (let ((gq (C-call "g_quark_from_string" string))) (hash-table/put! gquark-from-string-cache string gq) @@ -500,15 +460,14 @@ USA. (define (gquark-to-string gquark) (or (hash-table/get gquark-to-string-cache gquark #f) - (ferror "This GQuark ("gquark") has never been cached!"))) + (error "Unknown GQuark:" gquark))) (define (reset-quark-cache!) (set! gquark-from-string-cache (make-string-hash-table)) (set! gquark-to-string-cache (make-eqv-hash-table)) unspecific) - -;;;; GdkPixbufLoaders +;;; GdkPixbufLoaders (define-class ( (constructor ())) () @@ -537,49 +496,44 @@ USA. (call-next-method loader) (C-call "gdk_pixbuf_loader_new" (gobject-alien loader)) (g-signal-connect loader (C-callback "size_prepared") - (pixbuf-loader-size-prepared loader)) + pixbuf-loader-size-prepared) (g-signal-connect loader (C-callback "area_prepared") - (pixbuf-loader-area-prepared loader)) + pixbuf-loader-area-prepared) (g-signal-connect loader (C-callback "area_updated") - (pixbuf-loader-area-updated loader))) - -(define (pixbuf-loader-size-prepared loader) - (named-lambda (pixbuf-loader::size-prepared GdkPixbufLoader width height) - GdkPixbufLoader ;;Ignored. - (trace "; pixbuf-loader::size-prepared "loader" "width" "height"\n") - (let ((size (pixbuf-loader-size loader))) - (if size (ferror loader" already has a size: "(car size)"x"(cdr size))) - (set-pixbuf-loader-size! loader (cons width height)) - (let ((receiver (pixbuf-loader-size-hook loader))) - (if receiver (receiver width height)))))) + pixbuf-loader-area-updated)) + +(define (pixbuf-loader-size-prepared loader width height) + (trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n") + (let ((size (pixbuf-loader-size loader))) + (if size (error "Pixbuf loader already has a size:" loader)) + (set-pixbuf-loader-size! loader (cons width height)) + (let ((receiver (pixbuf-loader-size-hook loader))) + (if receiver (receiver width height))))) (define (pixbuf-loader-area-prepared loader) - (named-lambda (pixbuf-loader::area-prepared GdkPixbufLoader) - (trace "; pixbuf-loader::area-prepared "loader"\n") - (let* ((pixbuf (let ((p (pixbuf-loader-pixbuf loader))) + (trace "; pixbuf-loader-area-prepared "loader"\n") + (let* ((alien (gobject-alien loader)) + (pixbuf (let ((p (pixbuf-loader-pixbuf loader))) (if p - (ferror loader" already has a pixbuf: "p) + (error "Pixbuf loader already has a pixbuf:" loader) (make-pixbuf)))) - (alien (gobject-alien pixbuf))) - (C-call "gdk_pixbuf_loader_get_pixbuf" alien GdkPixbufLoader) - (C-call "g_object_ref" #f alien) + (pixbuf-alien (gobject-alien pixbuf))) + (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf-alien alien) + (C-call "g_object_ref" #f pixbuf-alien) (set-pixbuf-loader-pixbuf! loader pixbuf) (let ((receiver (pixbuf-loader-pixbuf-hook loader))) - (if receiver (receiver pixbuf)))))) + (if receiver (receiver pixbuf))))) -(define (pixbuf-loader-area-updated loader) - (named-lambda (pixbuf-loader::area-updated GdkPixbufLoader x y width height) - GdkPixbufLoader ;;Ignored. - (let ((rect (make-rect x y width height))) - (trace "; pixbuf-loader::area-updated "loader" "rect"\n") - (let ((receiver (pixbuf-loader-update-hook loader))) - (if receiver (receiver rect)))))) +(define (pixbuf-loader-area-updated loader x y width height) + (trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n") + (let ((receiver (pixbuf-loader-update-hook loader))) + (if receiver (receiver x y width height)))) -(define (start-pixbuf-loader loader input-port) +(define (load-pixbuf-from-port loader input-port) (without-interrupts (lambda () (if (pixbuf-loader-port loader) - (ferror loader" has already started.")) + (error "Pixbuf loader has already started:" loader)) (set-pixbuf-loader-port! loader input-port) (set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader))))) @@ -630,7 +584,7 @@ USA. (note-error)))))))))) (define (load-pixbuf-from-file loader filename) - (start-pixbuf-loader + (load-pixbuf-from-port loader (open-binary-input-file (->namestring (->truename filename))))) (define (set-pixbuf-loader-size-hook! loader receiver) @@ -653,6 +607,14 @@ USA. (%set-pixbuf-loader-close-hook! loader thunk) (if (pixbuf-loader-closed? loader) (thunk))))) + +(define (gdk-window-process-updates gdkwindow children-too?) + (guarantee-gdk-window gdkwindow 'gdk-window-process-updates) + (C-call "gdk_window_process_updates" gdkwindow (if children-too? 1 0))) + +(define-integrable (guarantee-gdk-window object operator) + (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object)))) + (error:wrong-type-argument object "a GdkWindow address" operator))) (define (initialize-package!) (initialize-gc-cleanups!) @@ -664,4 +626,6 @@ USA. (define-syntax trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(initialize-package!) \ No newline at end of file diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index 1aed2ec00..ff691a475 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -22,252 +22,193 @@ USA. |# ;;;; An event viewer, a translation of Havoc Pennington's GtkEv example. -;;; package: (gtk) - -(declare (usual-integrations)) - +;;; package: (gtk event-viewer) (c-include "gtk") -(define (gtk-event-viewer) +(define (make-gtk-event-viewer-demo) (let ((window (gtk-window-new 'toplevel)) - (gtk-ev (gtk-event-viewer-new))) + (gtk-ev (make-gtk-event-viewer))) (gtk-container-add window gtk-ev) (gtk-window-set-title window "gtk-event-viewer") (gtk-container-set-border-width window 10) (gtk-widget-show-all window) gtk-ev)) -(define-class ( - (constructor make-gtk-event-viewer ())) +(define-class ( (constructor ())) () ;; GdkWindow alien, and the window geometry (allocation). (window define standard initializer (lambda () (make-alien '|GdkWindow|))) (geometry define standard - initializer make-rect) + initializer make-fix-rect) ;; GdkWindow alien, and the window geometry (computed from the allocation). (event-window define standard initializer (lambda () (make-alien '|GdkWindow|))) (event-box define standard - initializer make-rect) + initializer make-fix-rect) ;; Geometry of the description area. (description-box define standard - initializer make-rect) + initializer make-fix-rect) ;; List of lines (strings, no newlines) to be displayed in the ;; description area. (buffer define standard initial-value '())) -(define (gtk-event-viewer-new) - (let ((w (make-gtk-event-viewer))) - (set-scm-widget-size-request! w (gtk-event-viewer-size-request w)) - (set-scm-widget-size-allocate! w (gtk-event-viewer-size-allocate w)) - (set-scm-widget-realize! w (gtk-event-viewer-realize w)) - (set-scm-widget-unrealize! w (gtk-event-viewer-unrealize w)) - (set-scm-widget-event! w (gtk-event-viewer-event w)) - w)) - -(define (gtk-event-viewer-realize widget) - (named-lambda (gtk-event-viewer::realize GtkWidget) - - (trace2 ";((gtk-event-viewer-realize "widget") "GtkWidget")\n") - (guarantee-my-alien 'gtk-event-viewer::realize widget GtkWidget) - - ;; ScmWidget automatically sets GTK_REALIZED. - - (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) - (main-GdkWindow (gtk-event-viewer-window widget)) - (event-GdkWindow (gtk-event-viewer-event-window widget)) - (parent-GdkWindow (make-alien '|GdkWindow|)) - ;(GdkVisual (make-alien '|GdkVisual|)) - ;(GdkColormap (make-alien '|GdkColormap|)) - (GdkCursor (make-alien '|GdkCursor|)) - (GtkStyle (make-alien '(struct |_GtkStyle|)))) - - ;; Main widget window. - - ;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget) - ;(check-!null GdkVisual "Could not get GdkVisual.") - ;(C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) - ;(check-!null GdkColormap "Could not get GdkColormap.") - - (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) - (let ((b (gtk-event-viewer-geometry widget))) - (C->= attr "GdkWindowAttr x" (rect-x b)) - (C->= attr "GdkWindowAttr y" (rect-y b)) - (C->= attr "GdkWindowAttr width" (rect-width b)) - (C->= attr "GdkWindowAttr height" (rect-height b))) - (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) - ;;(C->= attr "GdkWindowAttr visual" GdkVisual) - ;;(C->= attr "GdkWindowAttr colormap" GdkColormap) - (C->= attr "GdkWindowAttr event_mask" - (bit-or (C-call "gtk_widget_get_events" GtkWidget) - (C-enum "GDK_EXPOSURE_MASK"))) - - (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) - (check-!null parent-GdkWindow "Could not get parent.") - - (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr - (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") - ;;(C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") - )) - (check-!null main-GdkWindow "Could not create main window.") - (C->= GtkWidget "GtkWidget window" main-GdkWindow) - (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) - - ;; Event window - (C-call "gdk_cursor_new" GdkCursor (C-enum "GDK_CROSSHAIR")) - (check-!null GdkCursor "Could not create cursor.") - (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) - (let ((b (gtk-event-viewer-event-box widget))) - (C->= attr "GdkWindowAttr x" (rect-x b)) - (C->= attr "GdkWindowAttr y" (rect-y b)) - (C->= attr "GdkWindowAttr width" (rect-width b)) - (C->= attr "GdkWindowAttr height" (rect-height b))) - (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) - ;;(C->= attr "GdkWindowAttr visual" GdkVisual) - ;;(C->= attr "GdkWindowAttr colormap" GdkColormap) - (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) - (C->= attr "GdkWindowAttr cursor" GdkCursor) - (C-call "gdk_window_new" event-GdkWindow main-GdkWindow attr - (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") - ;;(C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") - (C-enum "GDK_WA_CURSOR"))) - (check-!null event-GdkWindow "Could not create event window.") - (C-call "gdk_window_set_user_data" event-GdkWindow GtkWidget) - (C-call "gdk_window_show" event-GdkWindow) - (C-call "gdk_cursor_destroy" GdkCursor) - - ;; Style - - (C-call "gtk_style_attach" GtkStyle - (C-> GtkWidget "GtkWidget style") main-GdkWindow) - (C->= GtkWidget "GtkWidget style" GtkStyle) - (C-call "gtk_style_set_background" - GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL")) - (C-call "gdk_window_set_background" - event-GdkWindow - (C-array-loc! (C-> GtkStyle "struct _GtkStyle base") - "GdkColor" (C-enum "GTK_STATE_NORMAL"))) - unspecific))) - -(define (gtk-event-viewer-unrealize widget) - (named-lambda (gtk-event-viewer::unrealize GtkWidget) - - (trace2 ";((gtk-event-viewer-unrealize "widget") "GtkWidget")\n") - (guarantee-my-alien 'GTK-EVENT-VIEWER::UNREALIZE widget GtkWidget) - - ;; ScmWidget automatically unmaps if necessary. - - ;; Destroy our child window. - (let ((event-GdkWindow (gtk-event-viewer-event-window widget))) - (if (not (alien-null? event-GdkWindow)) - (begin - (C-call "gdk_window_set_user_data" event-GdkWindow null-alien) - (C-call "gdk_window_destroy" event-GdkWindow) - (alien-null! event-GdkWindow)))) - - ;; The ScmWidget will chain up, calling parent_class->unrealize, - ;; as required by the toolkit. - unspecific)) - -(define (gtk-event-viewer-size-request widget) - (named-lambda (gtk-event-viewer::size-request GtkWidget GtkRequisition) - - (trace2 ";((gtk-event-viewer-size-request "widget") "GtkWidget" "GtkRequisition")\n") - (guarantee-my-alien 'GTK-EVENT-VIEWER::SIZE-REQUEST widget GtkWidget) - - ;; GtkEv always wants to be the same fixed size. - - (C->= GtkRequisition "GtkRequisition width" 450) - (C->= GtkRequisition "GtkRequisition height" 300) +(define-method initialize-instance ((widget )) + (trace ";\t(initialize-instance ) "widget")...\n") + (call-next-method widget) + (let ((alien (gobject-alien widget))) + (C->= alien "GtkWidget requisition width" 450) + (C->= alien "GtkWidget requisition height" 300) + (C-call "gtk_widget_set_has_window" alien 1) + (C-call "gtk_widget_set_can_focus" alien 1)) + (set-gtk-widget-size-allocate-callback! widget size-allocate-callback) + (set-gtk-widget-realize-callback! widget realize-callback) + (set-gtk-widget-unrealize-callback! widget unrealize-callback) + (set-gtk-widget-event-callback! widget event-callback)) + +(define (realize-callback widget) + (trace2 ";realize "widget"\n") + (let ((alien (gobject-alien widget)) + (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (gtk-event-viewer-window widget)) + (event-GdkWindow (gtk-event-viewer-event-window widget)) + (parent-GdkWindow (make-alien '|GdkWindow|)) + (GdkCursor (make-alien '|GdkCursor|)) + (GtkStyle (make-alien '(struct |_GtkStyle|)))) + + ;; Main widget window. + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (let ((b (gtk-event-viewer-geometry widget))) + (C->= attr "GdkWindowAttr x" (fix-rect-x b)) + (C->= attr "GdkWindowAttr y" (fix-rect-y b)) + (C->= attr "GdkWindowAttr width" (fix-rect-width b)) + (C->= attr "GdkWindowAttr height" (fix-rect-height b))) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (C->= attr "GdkWindowAttr event_mask" + (bit-or (C-call "gtk_widget_get_events" alien) + (C-enum "GDK_EXPOSURE_MASK"))) + + (C-call "gtk_widget_get_parent_window" parent-GdkWindow alien) + (error-if-null parent-GdkWindow "Could not get parent:" widget) + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y"))) + (error-if-null main-GdkWindow "Could not create main window:" widget) + (C->= alien "GtkWidget window" main-GdkWindow) + (C-call "gdk_window_set_user_data" main-GdkWindow alien) + + ;; Event window + (C-call "gdk_cursor_new" GdkCursor (C-enum "GDK_CROSSHAIR")) + (error-if-null GdkCursor "Could not create cursor:" widget) + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (let ((b (gtk-event-viewer-event-box widget))) + (C->= attr "GdkWindowAttr x" (fix-rect-x b)) + (C->= attr "GdkWindowAttr y" (fix-rect-y b)) + (C->= attr "GdkWindowAttr width" (fix-rect-width b)) + (C->= attr "GdkWindowAttr height" (fix-rect-height b))) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) + (C->= attr "GdkWindowAttr cursor" GdkCursor) + (C-call "gdk_window_new" event-GdkWindow main-GdkWindow attr + (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") + (C-enum "GDK_WA_CURSOR"))) + (error-if-null event-GdkWindow "Could not create event window:" widget) + (C-call "gdk_window_set_user_data" event-GdkWindow alien) + (C-call "gdk_window_show" event-GdkWindow) + (C-call "gdk_cursor_destroy" GdkCursor) + + ;; Style + (C-call "gtk_style_attach" GtkStyle + (C-> alien "GtkWidget style") main-GdkWindow) + (C->= alien "GtkWidget style" GtkStyle) + (C-call "gtk_style_set_background" + GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL")) + (C-call "gdk_window_set_background" + event-GdkWindow + (C-array-loc! (C-> GtkStyle "struct _GtkStyle base") + "GdkColor" (C-enum "GTK_STATE_NORMAL"))) unspecific)) -(define (gtk-event-viewer-size-allocate widget) - (named-lambda (gtk-event-viewer::size-allocate GtkWidget GtkAllocation) - - (trace2 ";((gtk-event-viewer-size-allocate "widget") "GtkWidget" "GtkAllocation")\n") - (guarantee-my-alien 'GTK-EVENT-VIEWER::SIZE-ALLOCATE widget GtkWidget) - - (let ((x (C-> GtkAllocation "GtkAllocation x")) - (y (C-> GtkAllocation "GtkAllocation y")) - (width (C-> GtkAllocation "GtkAllocation width")) - (height (C-> GtkAllocation "GtkAllocation height")) - (spacing 10)) - (set-rect! (gtk-event-viewer-geometry widget) x y width height) - (C->= GtkWidget "GtkWidget allocation x" x) - (C->= GtkWidget "GtkWidget allocation y" y) - (C->= GtkWidget "GtkWidget allocation width" width) - (C->= GtkWidget "GtkWidget allocation height" height) - (let ((event-width (max (- width (* 2 spacing)) 0)) - (event-height (max (- (quotient height 5) spacing) 0))) - (let ((event-x (quotient (- width event-width) 2)) - (event-y (min height spacing))) - (set-rect! (gtk-event-viewer-event-box widget) - event-x event-y event-width event-height) - (let* ((desc-x event-x) - (desc-y (+ event-y (+ event-height spacing))) - (desc-width event-width) - (desc-height (max (- height (+ event-height (* 3 spacing))) - 0))) - (set-rect! (gtk-event-viewer-description-box widget) - desc-x desc-y desc-width desc-height)) - - (if (not (alien-null? (gtk-event-viewer-window widget))) ;GTK_WIDGET_REALIZED - (begin - (C-call "gdk_window_move_resize" - (gtk-event-viewer-window widget) x y width height) - (C-call "gdk_window_move_resize" - (gtk-event-viewer-event-window widget) - event-x event-y event-width event-height))) - unspecific))))) - -;;; For debugging. -;;;(define gtk-event-viewer-events '()) - -(define (gtk-event-viewer-event widget) - (named-lambda (gtk-event-viewer::event GtkWidget GdkEvent) - - (trace2 ";((gtk-event-viewer-event "widget") "GtkWidget" "GdkEvent")\n") - (guarantee-my-alien 'gtk-event-viewer::event widget GtkWidget) - (let ((window (C-> GdkEvent "GdkEvent any window")) - (type (C-> GdkEvent "GdkEvent any type"))) - (let ((addr (alien/address-string window)) - (name (C-enum "GdkEventType" type))) - (trace "; "name" on window 0x"addr".\n")) - -;;; (set! gtk-event-viewer-events (cons (let ((alien (make-alien '|GdkEvent|))) -;;; (C-call "gdk_event_copy" alien GdkEvent) -;;; (check-!null alien "could not copy event") -;;; alien) -;;; gtk-event-viewer-events)) - - (if (not (alien=? window (gtk-event-viewer-window widget))) - (push-text widget (event-to-text GdkEvent))) - - (if (= type (C-enum "GDK_EXPOSE")) - (expose-handler widget GdkEvent) - (begin - (if (and (= type (C-enum "GDK_KEY_PRESS")) - (= (C-> GdkEvent "GdkEvent key keyval") - (C-enum "GDK_D"))) - ;; Test debugging in a callback. - (bkpt 'Test)) - - (if (= type (C-enum "GDK_MOTION_NOTIFY")) - (C-call "gdk_window_get_pointer" #f - (C-> GdkEvent "GdkEventMotion window") - null-alien null-alien null-alien)) - 0 ;;FALSE -- not handled. - ))))) +(define (unrealize-callback widget) + (trace2 ";unrealize "widget"\n") + ;; Destroy our event window. + (let ((event-GdkWindow (gtk-event-viewer-event-window widget))) + (if (not (alien-null? event-GdkWindow)) + (begin + (C-call "gdk_window_set_user_data" event-GdkWindow 0) + (C-call "gdk_window_destroy" event-GdkWindow) + (alien-null! event-GdkWindow)))) + ;; The main window will be destroyed by the toolkit. + unspecific) + +(define (size-allocate-callback widget GtkAllocation) + (trace2 ";size-allocate "widget" "GtkAllocation"\n") + (let ((alien (gobject-alien widget)) + (x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (spacing 10)) + (set-fix-rect! (gtk-event-viewer-geometry widget) x y width height) + (C->= alien "GtkWidget allocation x" x) + (C->= alien "GtkWidget allocation y" y) + (C->= alien "GtkWidget allocation width" width) + (C->= alien "GtkWidget allocation height" height) + (let ((event-width (max (- width (* 2 spacing)) 0)) + (event-height (max (- (quotient height 5) spacing) 0))) + (let ((event-x (quotient (- width event-width) 2)) + (event-y (min height spacing))) + (set-fix-rect! (gtk-event-viewer-event-box widget) + event-x event-y event-width event-height) + (let* ((desc-x event-x) + (desc-y (+ event-y (+ event-height spacing))) + (desc-width event-width) + (desc-height (max (- height (+ event-height (* 3 spacing))) + 0))) + (set-fix-rect! (gtk-event-viewer-description-box widget) + desc-x desc-y desc-width desc-height)) + + (if (gtk-widget-realized? widget) + (begin + (C-call "gdk_window_move_resize" + (gtk-event-viewer-window widget) x y width height) + (C-call "gdk_window_move_resize" + (gtk-event-viewer-event-window widget) + event-x event-y event-width event-height))) + unspecific)))) + +(define (event-callback widget GdkEvent) + (trace2 ";event-callback "widget" "GdkEvent"\n") + (let ((window (C-> GdkEvent "GdkEvent any window")) + (type (C-> GdkEvent "GdkEvent any type"))) + (trace "; "(C-enum "GdkEventType" type) + " on window 0x"(alien/address-string window)".\n") + + (if (not (and (alien=? window (gtk-event-viewer-window widget)) + (= type (C-enum "GDK_EXPOSE")))) + (push-text widget (event-to-text GdkEvent))) + + (if (= type (C-enum "GDK_EXPOSE")) + (expose-handler widget GdkEvent) + (begin + (if (and (= type (C-enum "GDK_KEY_PRESS")) + (= (C-> GdkEvent "GdkEvent key keyval") (C-enum "GDK_D"))) + ;; Test debugging in a callback. + (bkpt 'Test)) + + (if (= type (C-enum "GDK_MOTION_NOTIFY")) + (C-call "gdk_window_get_pointer" #f + (C-> GdkEvent "GdkEventMotion window") 0 0 0)) + 0 ;;FALSE -- not handled. + )))) (define (expose-handler widget GdkEventExpose) - (let ((window (C-> GdkEventExpose "GdkEventExpose window")) (x (C-> GdkEventExpose "GdkEventExpose area x")) (y (C-> GdkEventExpose "GdkEventExpose area y")) @@ -278,7 +219,7 @@ USA. (paint-window widget x y width height)) ((alien=? (gtk-event-viewer-event-window widget) window) (paint-event-window widget x y width height)) - (else (ferror "gtk-event-viewer-expose: unexpected window "window)))) + (else (error "gtk-event-viewer-expose: unexpected window:" window)))) 1 ;;TRUE -- handled. ) @@ -299,11 +240,11 @@ USA. ;; Draw a black rectangle around the event window (C-call "gdk_draw_rectangle" window black-gc 0 - (-1+ (rect-x rect)) - (-1+ (rect-y rect)) - (+ 2 (rect-width rect)) - (+ 2 (rect-height rect))) - (C-call "gdk_gc_set_clip_rectangle" black-gc null-alien) + (-1+ (fix-rect-x rect)) + (-1+ (fix-rect-y rect)) + (+ 2 (fix-rect-width rect)) + (+ 2 (fix-rect-height rect))) + (C-call "gdk_gc_set_clip_rectangle" black-gc 0) ;; Draw text in the description area, if applicable. @@ -314,11 +255,10 @@ USA. (if (not (= 0 (C-call "gdk_rectangle_intersect" exposed-area descrip-gdkrect intersection))) (let ((space 2) - (desc-bottom (rect-max-y descrip-box)) + (desc-bottom (fix-rect-max-y descrip-box)) (layout (make-alien '|PangoLayout|))) - (C-call "gtk_widget_create_pango_layout" layout - alien null-alien) - (let loop ((y (rect-y descrip-box)) + (C-call "gtk_widget_create_pango_layout" layout alien 0) + (let loop ((y (fix-rect-y descrip-box)) (lines (gtk-event-viewer-buffer widget))) (if (null? lines) unspecific @@ -348,7 +288,7 @@ USA. (if (gtk-widget-has-focus? widget) (C-call "gtk_paint_focus" - style window state null-alien alien "gtk-event-viewer" + style window state 0 alien "gtk-event-viewer" x y (-1+ width) (-1+ height))) (free exposed-area) unspecific)) @@ -364,7 +304,7 @@ USA. (let ((title (string-append "Event Window (0x" (alien/address-string event-window)")"))) (C-call "gtk_widget_create_pango_layout" layout alien title)) - (C-call "pango_layout_get_pixel_extents" layout extent null-alien) + (C-call "pango_layout_get_pixel_extents" layout extent 0) (C-call "gtk_paint_layout" (C-> alien "GtkWidget style") event-window @@ -372,7 +312,7 @@ USA. 1 ;; Use the text gc, not the fg gc. area alien "gtk-event-viewer" ;;center - (quotient (- (rect-width (gtk-event-viewer-event-box widget)) + (quotient (- (fix-rect-width (gtk-event-viewer-event-box widget)) (C-> extent "PangoRectangle width")) 2) 0 @@ -388,7 +328,7 @@ USA. (let ((a (gobject-alien ev)) (r (gtk-event-viewer-description-box ev))) (C-call "gtk_widget_queue_draw_area" - a (rect-x r) (rect-y r) (rect-width r) (rect-height r))))) + a (fix-rect-x r) (fix-rect-y r) (fix-rect-width r) (fix-rect-height r))))) (define (event-to-text GdkEvent) @@ -440,31 +380,31 @@ USA. (decorated-string-append "" " | " "" (append! - (if (not (= 0 (bit-and state (C-enum "GDK_SHIFT_MASK")))) + (if (bit? state (C-enum "GDK_SHIFT_MASK")) (list "Shift") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_LOCK_MASK")))) + (if (bit? state (C-enum "GDK_LOCK_MASK")) (list "Lock") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_CONTROL_MASK")))) + (if (bit? state (C-enum "GDK_CONTROL_MASK")) (list "Ctrl") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_MOD1_MASK")))) + (if (bit? state (C-enum "GDK_MOD1_MASK")) (list "Mod1") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_MOD2_MASK")))) + (if (bit? state (C-enum "GDK_MOD2_MASK")) (list "Mod2") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_MOD3_MASK")))) + (if (bit? state (C-enum "GDK_MOD3_MASK")) (list "Mod3") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_MOD4_MASK")))) + (if (bit? state (C-enum "GDK_MOD4_MASK")) (list "Mod4") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_MOD5_MASK")))) + (if (bit? state (C-enum "GDK_MOD5_MASK")) (list "Mod5") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON1_MASK")))) + (if (bit? state (C-enum "GDK_BUTTON1_MASK")) (list "Button1") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON2_MASK")))) + (if (bit? state (C-enum "GDK_BUTTON2_MASK")) (list "Button2") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON3_MASK")))) + (if (bit? state (C-enum "GDK_BUTTON3_MASK")) (list "Button3") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON4_MASK")))) + (if (bit? state (C-enum "GDK_BUTTON4_MASK")) (list "Button4") '()) - (if (not (= 0 (bit-and state (C-enum "GDK_RELEASE_MASK")))) + (if (bit? state (C-enum "GDK_RELEASE_MASK")) (list "Release") '()))) "\n")))) (if (or (not line) (string=? line "\n")) #f line))) @@ -497,33 +437,15 @@ USA. (cat "Keyval: "keyval" Text: "text"\n"))) (else #f)))) - -(define (check-!null alien message) - (if (alien-null? alien) - (begin - (ferror "gtk-event-viewer: "message)) - alien)) - -(define (guarantee-my-alien name widget alien) - ;; Complain if the WIDGET's alien does not match ALIEN. NAME is the - ;; widget method name or other debugging help. Just warn, since - ;; this is used in callbacks. - - (cond ((alien-null? (gobject-alien widget)) - (fwarn "in "name", "widget" has been finalized (or never" - " initialized).")) - ((not (alien=? alien (gobject-alien widget))) - (fwarn "in "name", "alien" is not the expected " - (gobject-alien widget)".")))) - (define trace? #f) -(define trace2? #f) (define-syntax trace (syntax-rules () ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) +(define trace2? #f) + (define-syntax trace2 (syntax-rules () ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gtk-new.pkg b/src/gtk/gtk-new.pkg new file mode 100644 index 000000000..29ef555bc --- /dev/null +++ b/src/gtk/gtk-new.pkg @@ -0,0 +1,360 @@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Gtk System Packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../ffi/ffi") +(global-definitions "../sos/sos") + +;;; This is largely a copy of gtk.pkg, with a few new declarations added. + +(declare (usual-integrations)) + +(define-package (gtk) + (parent ()) + (files "gtk")) + +(define-package (gtk gobject) + (parent (gtk)) + (files "gobject") + (depends-on "gtk-const.bin") + (export (gtk) + gobject-alien + gobject-live? gobject-unref! + g-signal-connect g-signal-disconnect + add-gc-cleanup punt-gc-cleanup + gobject-get-property gobject-set-properties + gquark-from-string gquark-to-string + make-pixbuf-loader + load-pixbuf-from-port load-pixbuf-from-file + pixbuf-loader-size-hook set-pixbuf-loader-size-hook! + pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook! + pixbuf-loader-update-hook set-pixbuf-loader-update-hook! + pixbuf-loader-close-hook set-pixbuf-loader-close-hook! + pixbuf-loader-pixbuf pixbuf-loader-error-message + + gdk-window-process-updates)) + +(define-package (gtk pango) + (parent (gtk)) + (files "pango") + (depends-on "gtk-const.bin") + (export (gtk) + + pango-layout-get-context + pango-layout-context-changed + pango-layout-get-font-description + pango-layout-set-font-description + pango-layout-set-text + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-context-get-font-description + pango-context-set-font-description + pango-context-get-metrics + pango-context-spacing + pango-font-metrics-get-ascent + pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref)) + +(define-package (gtk gtk-object) + (parent (gtk)) + (files "gtk-object") + (depends-on "gtk-const.bin") + (export (gtk) + gtk-object? guarantee-gtk-object + gtk-object-destroyed? gtk-object-destroy + gtk-adjustment? guarantee-gtk-adjustment + make-gtk-adjustment set-gtk-adjustment! + gtk-widget? guarantee-gtk-widget + gtk-widget-parent + gtk-widget-realized? + gtk-widget-drawable? gtk-widget-has-focus? + gtk-widget-grab-focus + gtk-widget-show + gtk-widget-show-all + gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-get-colormap + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-set-size-request + ;;gtk-widget-set-can-focus + set-gtk-widget-size-allocate-callback! + set-gtk-widget-realize-callback! + set-gtk-widget-unrealize-callback! + set-gtk-widget-event-callback! + + gtk-widget-font set-gtk-widget-font! + gtk-widget-fg-color gtk-widget-bg-color + gtk-widget-text-color gtk-widget-base-color + set-gtk-widget-fg-color! set-gtk-widget-bg-color! + set-gtk-widget-text-color! set-gtk-widget-base-color! + gtk-widget-parse-color + + gtk-container? guarantee-gtk-container + gtk-container-children gtk-bin-child + gtk-container-add gtk-container-remove + gtk-container-set-border-width + ;;gtk-container-set-resize-mode + ;;gtk-container-check-resize + + gtk-window? guarantee-gtk-window + gtk-window-new gtk-window-set-title gtk-window-type + gtk-window-set-opacity + gtk-window-set-default-size gtk-window-get-default-size + gtk-window-parse-geometry + gtk-window-resize + gtk-window-present + set-gtk-window-delete-event-callback! + gtk-label? guarantee-gtk-label + gtk-label-new + gtk-label-get-text gtk-label-set-text + gtk-label-set-width-chars + gtk-button? guarantee-gtk-button + gtk-button-new + set-gtk-button-clicked-callback! + gtk-check-button? guarantee-gtk-check-button + gtk-check-button-new + gtk-check-button-get-active gtk-check-button-set-active + set-gtk-check-button-toggled-callback! + gtk-vbox? guarantee-gtk-vbox gtk-vbox-new + gtk-hbox? guarantee-gtk-hbox gtk-hbox-new + gtk-box-pack-start gtk-box-pack-end + gtk-frame? guarantee-gtk-frame gtk-frame-new + gtk-frame-set-shadow-type + gtk-scrolled-window? + guarantee-gtk-scrolled-window gtk-scrolled-window-new + gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement) + (import (gtk pango) make-pango-layout guarantee-pango-font-description)) + +(define-package (gtk widget) + (parent (gtk)) + (files "scm-widget") + (depends-on "gtk-const.bin") + (import (gtk gtk-object) + set-gtk-object-destroy-callback!) + (export (gtk) + + set-scm-widget-set-scroll-adjustments-callback!)) + +(define-package (gtk fix-layout) + (parent (gtk)) + (files "fix-layout") + (depends-on "gtk.ext" "pango.ext" "gtk-const.bin") + (import (gtk pango) + make-pango-layout pango-rectangle pangos->pixels pixels->pangos) + (import (gtk gtk-object) + parse-gdkcolor set-gtk-object-destroy-callback!) + (export (gtk) + + fix-layout? make-fix-layout set-fix-layout-size! + fix-layout-drawing set-fix-layout-drawing! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw! + fix-layout-new-geometry-callback fix-layout-realize-callback + set-fix-layout-map-handler! + set-fix-layout-unmap-handler! + set-fix-layout-focus-change-handler! + set-fix-layout-visibility-notify-handler! + set-fix-layout-key-press-handler! + set-fix-layout-motion-handler! + set-fix-layout-button-handler! + + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! fix-drawing-pick-list + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-move! fix-ink-remove! + + + line-ink? make-line-ink set-line-ink! + line-ink-width set-line-ink-width! + line-ink-color set-line-ink-color! + line-ink-dash-color set-line-ink-dash-color! + + rectangle-ink? make-rectangle-ink set-rectangle-ink! + rectangle-ink-color set-rectangle-ink-color! + rectangle-ink-width set-rectangle-ink-width! + rectangle-ink-fill-color set-rectangle-ink-fill-color! + + arc-ink? make-arc-ink set-arc-ink! + arc-ink-start-angle set-arc-ink-start-angle! + arc-ink-sweep-angle set-arc-ink-sweep-angle! + arc-ink-color set-arc-ink-color! + arc-ink-width set-arc-ink-width! + arc-ink-fill-color set-arc-ink-fill-color! + + text-ink? + set-text-ink-position! + text-ink-xy-to-index + with-text-ink-grapheme-rect + text-ink-color set-text-ink-color! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + simple-text-ink-font set-simple-text-ink-font! + + make-image-ink-from-file set-image-ink! + + box-ink? make-box-ink + set-box-ink! set-box-ink-position! + box-ink-shadow set-box-ink-shadow! + + ;; make-hline-ink set-hline-ink-size! + ;; make-vline-ink set-vline-ink-size! + )) + +(define-package (gtk keys) + (parent (gtk)) + (files "keys") + (depends-on "gtk-const.bin") + (export (gtk) + gdk-key-state->char-bits + gdk-keyval->name)) + +(define-package (gtk thread) + (parent (runtime thread)) + (files "thread") + (depends-on "gtk.ext" "pango.ext") + (export (gtk) + kill-gtk-thread) + (import (gtk gobject) + run-gc-cleanups) + (import (runtime primitive-io) + select-registry-handle)) + +(define-package (gtk main) + (parent (gtk)) + (files "main") + (depends-on "gtk-const.bin") + (import (runtime load) + *unused-command-line* + hook/process-command-line + default/process-command-line) + (import (runtime) + ucode-primitive) + (import (gtk thread) + create-gtk-thread) + (export (gtk) + gtk-time-slice-window? + gtk-time-slice-window! + gtk-select-trace? + gtk-select-trace!)) + +(define-package (gtk event-viewer) + (parent (gtk)) + (files "gtk-ev") + (depends-on "gtk.ext" "pango.ext" "gtk-const.bin") + (import (gtk fix-layout) + gdk-rectangle gdk-rectangle-from-rect + make-fix-rect + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-max-y set-fix-rect! fix-rect-union!) + (import (gtk pango) + pango-rectangle pangos->pixels) + (export () + make-gtk-event-viewer-demo)) + +(define-package (gtk fix-layout demo) + (parent (gtk fix-layout)) + (files "fix-demo") + (depends-on "gtk.ext" "pango.ext") + (import (gtk fix-layout) + fix-layout-view) + (export () + make-fix-layout-demo)) + +(define-package (gtk swat) + (parent (gtk)) + (files "swat") + (depends-on "gtk.ext" "pango.ext") + (import (gtk gtk-object) + gtk-object-destroy-callback) + (import (gtk fix-layout) + fix-layout-view fix-ink-extent fix-ink-expose-callback + fix-drawing-display-list set-fix-drawing-display-list! + set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in? + fix-rect-x fix-rect-y with-fix-rect + set-fix-rect-size! fix-rect-move! copy-fix-rect! + point-in-fix-rect? fix-rect-union!) + (export (swat) + add-child! remove-child! ask-widget + add-event-handler! set-callback! + after-delay on-death! + swat-open swat-close + make-active-variable set-active-variable! + make-hbox make-vbox box-children + make-button make-label + make-checkbutton checkbutton-variable-on? + make-canvas make-canvas-item-group + make-line-on-canvas make-rectangle-on-canvas + make-oval-on-canvas make-text-on-canvas)) + +(define-package (swat) + (parent ())) + +#;(define-package (swat examples) + (parent (swat)) + (files "swat-examples")) + +(define-package (swat pole-zero) + (parent (swat)) + (files "swat-pole-zero") + (export () + make-pole-zero)) + +#;(define-package (swat plotter) + (parent (swat)) + (files "swat-plotter") + (export () + plotter + plot + set-plotter-params + reset-plotter-params + make-vals + change-color + change-pt-style + change-num-pts + clear-curve + plot-curve + delete-curve + add-show-vals + clear-show-vals + draw-show-vals + delete-show-vals + add-xticks + add-yticks + clear-ticks + draw-ticks + delete-ticks + clear-plotter + replot + reset-plotter)) \ No newline at end of file diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index 23374f29c..f871d945c 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -24,105 +24,91 @@ USA. ;;;; GtkObjects/GtkWidgets/GtkContainers ;;; package: (gtk gtk-object) - (c-include "gtk") (define-class () (destroyed? define standard initial-value #f)) -(define-method initialize-instance ((object )) - ;; Arrange for all gtk-objects to be destroyed by gtk_object_destroy - ;; when GCed. Does NOT chain (further) up; gtk-object-cleanup is - ;; sufficient. - (add-gc-cleanup object - (gtk-object-cleanup-thunk (gobject-alien object) - (gobject-signals object)))) - -(define (gtk-object-cleanup-thunk alien signals) - ;; Return a thunk closed over ALIEN and SIGNALS (but not the gtk-object). - (named-lambda (gtk-object::cleanup-thunk) - (trace ";gtk-object::cleanup-thunk "alien"\n") - (gtk-object-cleanup alien signals) - (trace ";gtk-object::cleanup-thunk done with "alien"\n"))) - -(define (gtk-object-cleanup alien signals) - ;; Run as a gc-cleanup, without-interrupts. Calls - ;; gtk_object_destroy (if necessary), and de-registers the Scheme - ;; signal handlers. - (trace ";gtk-object::cleanup "alien"\n") - (if (not (alien-null? alien)) +(define-guarantee gtk-object "a ") + +;;; This is unfortunate. We rely on the most specialized method to +;;; call out, creating a specific type of GtkObject. We want the +;;; method to go first, as usual, to add a gc-cleanup, but +;;; this method to go last, AFTER the most specific (most unusual!) +;;; else it cannot connect its destroy-callback. To do both would +;;; take... a computed effective method procedure? For now, rely on +;;; the method that calls out to set-gtk-object-destroy-callback! as +;;; well as g_object_ref_sink. + +#;(define-method initialize-instance ((object )) + (call-next-method object) + (g-signal-connect object (C-callback "destroy") gtk-object-destroy-callback)) + +(define (set-gtk-object-destroy-callback! object) + (g-signal-connect object (C-callback "destroy") gtk-object-destroy-callback)) + +;;; Methods of this generic procedure should drop references to other +;;; gobject instances used by @var{object}. If these instances are +;;; not shared, they can be explicitly g-object-unref!ed. Else they +;;; should be dropped, e.g. replaced with #f, to be cleaned up by the +;;; garbage collector. +(define-generic gtk-object-destroy-callback (object)) + +(define-method gtk-object-destroy-callback ((object )) + (if (not (gtk-object-destroyed? object)) (begin - (C-call "gtk_object_destroy" alien) - (alien-null! alien))) - ;; De-register signals. Nulled alien will not be g_object_unrefed. - (gobject-cleanup alien signals) - (trace ";gtk-object::cleanup done with "alien"\n")) - -(define-generic gtk-object-destroy (object)) - -(define-method gtk-object-destroy ((object )) - ;; Calls gtk_object_destroy and sets the destroyed? flag. - (without-interrupts - (lambda () - (if (not (gtk-object-destroyed? object)) - (begin - (set-gtk-object-destroyed?! object #t) - (gtk-object-cleanup - (gobject-alien object) (gobject-signals object))))))) - -(define-integrable (gtk-object-flags gtkobject) - ;; Returns GTK_OBJECT(obj)->flags. - (let ((alien (gobject-alien (check-gtk-object gtkobject)))) - (C-> alien "GtkObject flags"))) - -(declare (integrate-operator check-gtk-object)) -(define (check-gtk-object object) - (if (gtk-object? object) object - (error:wrong-type-argument object "" 'check-gtk-object))) + (set-gtk-object-destroyed?! object #t) + (gobject-unref! object)))) + +(define (gtk-object-destroy object) + (guarantee-live-gtk-object object 'gtk-object-destroy) + (C-call "gtk_object_destroy" (gobject-alien object))) + +(define-integrable-operator (guarantee-live-gtk-object object operator) + (guarantee-gtk-object object operator) + (if (gtk-object-destroyed? object) + (error "Gtk-object destroyed:" object operator)) + (if (not (gobject-live? object)) + (error "Gtk-object dead:" object operator))) + +(define (gtk-object-flags object) + ;; Returns GTK_OBJECT(object)->flags. + (C-> (gobject-alien object) "GtkObject flags")) - -;;;; GtkAdjustments +;;; GtkAdjustments (define-class ( (constructor ())) ()) -;(define-integrable (gtk-adjustment-value adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment value")) -;(define-integrable (gtk-adjustment-lower adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment lower")) -;(define-integrable (gtk-adjustment-upper adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment upper")) -;(define-integrable (gtk-adjustment-step-increment adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment step_increment")) -;(define-integrable (gtk-adjustment-page-increment adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment page_increment")) -;(define-integrable (gtk-adjustment-page-size adjustment) -; (C-> (live-alien-adjustment adjustment) "GtkAdjustment page_size")) -(define (live-alien-adjustment object) - (if (gtk-adjustment? object) - (if (not (gobject-finalized? object)) - (gobject-alien object) - (ferror "The gtk-adjustment "object" has been finalized.")) - (ferror "The object "object" is not a instance."))) +(define-guarantee gtk-adjustment "a ") + +(define-integrable-operator (guarantee-live-gtk-adjustment object operator) + (guarantee-gtk-adjustment object operator) + (if (not (gobject-live? object)) + (error "Gtk-adjustment dead:" object operator))) (define (set-gtk-adjustment! adjustment value lower upper page-size step-incr page-incr) - (let ((alien (live-alien-adjustment adjustment)) - (new-lower (floor->exact (check-real lower))) - (new-upper (floor->exact (check-real upper))) - (new-value (floor->exact (check-real value))) - (new-page-size (floor->exact (check-real page-size))) - (new-step-incr (floor->exact (check-real step-incr))) - (new-page-incr (floor->exact (check-real page-incr)))) - (let ((old-lower (floor->exact (C-> alien "GtkAdjustment lower"))) - (old-upper (floor->exact (C-> alien "GtkAdjustment upper"))) - (old-value (floor->exact (C-> alien "GtkAdjustment value"))) - (old-page-size - (floor->exact (C-> alien "GtkAdjustment page_size"))) - (old-step-incr - (floor->exact (C-> alien "GtkAdjustment step_increment"))) - (old-page-incr - (floor->exact (C-> alien "GtkAdjustment page_increment")))) + (guarantee-live-gtk-adjustment adjustment 'set-gtk-adjustment!) + (guarantee-real lower 'set-gtk-adjustment!) + (guarantee-real upper 'set-gtk-adjustment!) + (guarantee-real page-size 'set-gtk-adjustment!) + (guarantee-real step-incr 'set-gtk-adjustment!) + (guarantee-real page-incr 'set-gtk-adjustment!) + (define-integrable f->e floor->exact) + (let ((alien (gobject-alien adjustment)) + (new-lower (f->e lower)) + (new-upper (f->e upper)) + (new-value (f->e value)) + (new-page-size (f->e page-size)) + (new-step-incr (f->e step-incr)) + (new-page-incr (f->e page-incr))) + (let ((old-lower (f->e (C-> alien "GtkAdjustment lower"))) + (old-upper (f->e (C-> alien "GtkAdjustment upper"))) + (old-value (f->e (C-> alien "GtkAdjustment value"))) + (old-page-size (f->e (C-> alien "GtkAdjustment page_size"))) + (old-step-incr (f->e (C-> alien "GtkAdjustment step_increment"))) + (old-page-incr (f->e (C-> alien "GtkAdjustment page_increment")))) (if (not (int:= new-lower old-lower)) (C->= alien "GtkAdjustment lower" new-lower)) (if (not (int:= new-upper old-upper)) @@ -146,79 +132,115 @@ USA. (define (peek-gtk-adjustment adjustment) ;; For debugging... - (let ((alien (live-alien-adjustment adjustment))) - (list - (C-> alien "GtkAdjustment lower") - (C-> alien "GtkAdjustment upper") - (C-> alien "GtkAdjustment value") - (C-> alien "GtkAdjustment page_size") - (C-> alien "GtkAdjustment step_increment") - (C-> alien "GtkAdjustment page_increment")))) - -(declare (integrate-operator check-real)) -(define (check-real object) - (if (real? object) object - (error:wrong-type-argument object "real number" 'check-real))) + (list + (C-> adjustment "GtkAdjustment lower") + (C-> adjustment "GtkAdjustment upper") + (C-> adjustment "GtkAdjustment value") + (C-> adjustment "GtkAdjustment page_size") + (C-> adjustment "GtkAdjustment step_increment") + (C-> adjustment "GtkAdjustment page_increment"))) - -;;;; GtkWidgets, GtkContainers +;;; GtkWidgets (define-class () ;; The parent or #f. (parent define standard initial-value #f)) +(define-guarantee gtk-widget "a ") + +(define-method gtk-object-destroy-callback ((widget )) + (call-next-method widget) + (let ((parent (gtk-widget-parent widget))) + (if (and parent (not (gtk-object-destroyed? parent))) + (container-remove! parent widget)))) + +(define (gtk-widget-realized? widget) + (guarantee-gtk-widget widget 'gtk-widget-realized?) + (let ((flags (gtk-object-flags widget))) + (bit? flags (C-enum "GTK_REALIZED")))) + (define (gtk-widget-has-focus? widget) + (guarantee-gtk-widget widget 'gtk-widget-has-focus?) (let ((flags (gtk-object-flags widget))) - (not (int:zero? (bit-and flags (C-enum "GTK_HAS_FOCUS")))))) + (bit? flags (C-enum "GTK_HAS_FOCUS")))) (define (gtk-widget-drawable? widget) + (guarantee-gtk-widget widget 'gtk-widget-drawable?) (let ((flags (gtk-object-flags widget))) - (and (not (int:zero? (bit-and flags (C-enum "GTK_VISIBLE")))) - (not (int:zero? (bit-and flags (C-enum "GTK_MAPPED"))))))) + (and (bit? flags (C-enum "GTK_VISIBLE")) + (bit? flags (C-enum "GTK_MAPPED"))))) (define (gtk-widget-grab-focus widget) - (C-call "gtk_widget_grab_focus" (check-gtk-widget-alien widget))) + (guarantee-gtk-widget widget 'gtk-widget-grab-focus) + (C-call "gtk_widget_grab_focus" (gobject-alien widget))) + +(define (gtk-widget-show widget) + (guarantee-gtk-widget widget 'gtk-widget-show) + (C-call "gtk_widget_show" (gobject-alien widget))) (define (gtk-widget-show-all widget) - (C-call "gtk_widget_show_all" (check-gtk-widget-alien widget))) + (guarantee-gtk-widget widget 'gtk-widget-show-all) + (C-call "gtk_widget_show_all" (gobject-alien widget))) (define (gtk-widget-error-bell widget) - (C-call "gtk_widget_error_bell" (check-gtk-widget-alien widget))) + (guarantee-gtk-widget widget 'gtk-widget-error-bell) + (C-call "gtk_widget_error_bell" (gobject-alien widget))) (define (gtk-widget-queue-draw widget) - (C-call "gtk_widget_queue_draw" (check-gtk-widget-alien widget))) + (guarantee-gtk-widget widget 'gtk-widget-queue-draw) + (C-call "gtk_widget_queue_draw" (gobject-alien widget))) (define (gtk-widget-get-pango-context widget) + (guarantee-gtk-widget widget 'gtk-widget-get-pango-context) (C-call "gtk_widget_get_pango_context" (make-alien '|PangoContext|) (gobject-alien widget))) (define (gtk-widget-create-pango-layout widget #!optional text) - (let ((t (if (default-object? text) 0 (check-string text))) - (w (check-gtk-widget widget))) - (let ((l (make-pango-layout))) - (C-call "gtk_widget_create_pango_layout" - (gobject-alien l) (gobject-alien w) t) - l))) - -(define (check-string object) - (if (string? object) object - (error:wrong-type-argument object "a string" 'check-string))) + (guarantee-gtk-widget widget 'gtk-widget-create-pango-layout) + (if (not (default-object? text)) + (guarantee-string text 'gtk-widget-create-pango-layout)) + (let ((layout (make-pango-layout))) + (C-call "gtk_widget_create_pango_layout" + (gobject-alien layout) (gobject-alien widget) + (if (default-object? text) 0 text)) + (error-if-null layout "Could not create:" layout) + layout)) (define (gtk-widget-set-size-request widget width height) (C-call "gtk_widget_set_size_request" (gobject-alien widget) width height)) - -;;;; GtkWidget Font +(define (set-gtk-widget-size-allocate-callback! widget callback) + (guarantee-gtk-widget widget 'set-gtk-widget-size-allocate-callback!) + (guarantee-procedure-of-arity callback 2 'set-gtk-widget-size-allocate-callback!) + (g-signal-connect widget (C-callback "size_allocate") callback)) + +(define (set-gtk-widget-realize-callback! widget callback) + (guarantee-gtk-widget widget 'set-gtk-widget-realize-callback!) + (guarantee-procedure-of-arity callback 1 'set-gtk-widget-realize-callback!) + (g-signal-connect widget (C-callback "realize") callback)) + +(define (set-gtk-widget-unrealize-callback! widget callback) + (guarantee-gtk-widget widget 'set-gtk-widget-unrealize-callback!) + (guarantee-procedure-of-arity callback 1 'set-gtk-widget-unrealize-callback!) + (g-signal-connect widget (C-callback "unrealize") callback)) + +(define (set-gtk-widget-event-callback! widget callback) + (guarantee-gtk-widget widget 'set-gtk-widget-event-callback!) + (guarantee-procedure-of-arity callback 2 'set-gtk-widget-event-callback!) + (g-signal-connect widget (C-callback "event") callback)) + +;;; GtkWidget Font (define (gtk-widget-font widget) - (let ((alien (check-gtk-widget-alien widget)) - (desc (make-alien '|PangoFontDescription|))) - (C-> alien "GtkWidget style" desc) + (guarantee-gtk-widget-realized widget 'gtk-widget-font) + (let ((desc (make-alien '|PangoFontDescription|))) + (C-> (gobject-alien widget) "GtkWidget style" desc) (C-> desc "GtkStyle font_desc" desc) desc)) (define (set-gtk-widget-font! widget desc) + (guarantee-gtk-widget-realized widget 'set-gtk-widget-font!) (let ((font (->PangoFontDescription desc))) (modify-rcstyle widget (lambda (rcstyle) (set-rcstyle-font! rcstyle font))))) @@ -234,7 +256,13 @@ USA. (C-call "gtk_widget_queue_draw" gtkwidget))) (define (set-rcstyle-font! rcstyle pangofontdescription) - (C->= rcstyle "struct _GtkRcStyle font_desc" pangofontdescription)) + (let ((old (C-> rcstyle "GtkRcStyle font_desc")) + (new (C-call "pango_font_description_copy" + (make-alien 'PangoFontDescription) + pangofontdescription))) + (if (not (alien-null? old)) + (C-call "pango_font_description_free" old)) + (C->= rcstyle "GtkRcStyle font_desc" new))) (define (->PangoFontDescription desc) (cond ((and (alien? desc) (eq? '|PangoFontDescription| (alien/ctype desc))) @@ -248,50 +276,117 @@ USA. (else (error:wrong-type-argument desc "PangoFontDescription" '->PangoFontDescription)))) +;;; GtkWidget Colors + +(define-generic gtk-widget-get-colormap (widget)) -;;;; GtkWidget Colors - -(define (gtk-widget-fg-color widget) - ;; Returns WIDGET's foreground color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle fg")))) - -(define (peek-rgb colors) - (let ((color (C-array-loc colors "GdkColor" (C-enum "GTK_STATE_NORMAL")))) - (vector (/ (C-> color "GdkColor red") 65535) - (/ (C-> color "GdkColor green") 65535) - (/ (C-> color "GdkColor blue") 65535)))) - -(define (gtk-widget-bg-color widget) - ;; Returns WIDGET's background color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle bg")))) - -(define (gtk-widget-text-color widget) - ;; Returns WIDGET's text color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle text")))) - -(define (gtk-widget-base-color widget) - ;; Returns WIDGET's base color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle base")))) - -(define (set-gtk-widget-fg-color! widget color) - ;; Sets WIDGET's foreground color. Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-fg-color!))) +(define-method gtk-widget-get-colormap ((widget )) + (C-call "gtk_widget_get_colormap" + (make-alien '|GdkColormap|) + (gobject-alien widget))) + +(define (gtk-widget-parse-color widget spec) + (guarantee-gtk-widget widget 'gtk-widget-parse-color) + (guarantee-string spec 'gtk-widget-parse-color) + (let ((gdkcolor (parse-gdkcolor spec widget))) + (if gdkcolor + (let ((rgb (peek-gdkcolor gdkcolor))) + (free gdkcolor) + rgb) + #f))) + +(define-integrable-operator (peek-gdkcolor gdkcolor) + (vector (/ (C-> gdkcolor "GdkColor red") 65535) + (/ (C-> gdkcolor "GdkColor green") 65535) + (/ (C-> gdkcolor "GdkColor blue") 65535))) + +(define (parse-gdkcolor spec widget) + ;; Return a malloced GdkColor with its RGB components filled in from + ;; SPEC. Does not allocate the color. + (cond ((string? spec) (lookup-gdkcolor widget spec)) + ((symbol? spec) (lookup-gdkcolor widget (symbol-name spec))) + ((and (vector? spec) (= 3 (vector-length spec))) + (let ((new (malloc (C-sizeof "GdkColor") '|GdkColor|))) + (define-integrable (ref i) + (round->exact (* (vector-ref spec i) 65535))) + (C->= new "GdkColor red" (ref 0)) + (C->= new "GdkColor blue" (ref 1)) + (C->= new "GdkColor green" (ref 2)) + new)) + (else #f))) + +(define (lookup-gdkcolor widget string) + ;; Return a malloced GdkColor with the RGB components of a color + ;; named by STRING. Returns #f if the color name is unknown. + (let ((style (C-> (gobject-alien widget) "GtkWidget style")) + (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) + (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor)) + (zero? (C-call "gdk_color_parse" string gdkcolor))) + (begin + (free gdkcolor) + #f) + gdkcolor))) + +(define (->gdkcolor spec widget operator) + (or (parse-gdkcolor spec widget) + (error:wrong-type-argument spec "a Gtk color spec." operator))) + +(define-integrable-operator (guarantee-gtk-widget-realized widget operator) + (guarantee-gtk-widget widget operator) + (if (not (gtk-widget-realized? widget)) + (error "Not yet realized:" widget operator))) + +(define (gtk-widget-fg-color widget #!optional state) + (guarantee-gtk-widget-realized widget 'gtk-widget-fg-color) + (let ((state (->gtk-widget-state state 'gtk-widget-fg-color)) + (alien (make-alien '|GdkColor|))) + (C-> (gobject-alien widget) "GtkWidget style" alien) + (C-> alien "GtkStyle fg" alien) + (C-array-loc! alien "GdkColor" state) + (peek-gdkcolor alien))) + +(define (gtk-widget-bg-color widget #!optional state) + (guarantee-gtk-widget-realized widget 'gtk-widget-bg-color) + (let ((state (->gtk-widget-state state 'gtk-widget-bg-color)) + (alien (make-alien '|GdkColor|))) + (C-> (gobject-alien widget) "GtkWidget style" alien) + (C-> alien "GtkStyle bg" alien) + (C-array-loc! alien "GdkColor" state) + (peek-gdkcolor alien))) + +(define (gtk-widget-text-color widget #!optional state) + (guarantee-gtk-widget-realized widget 'gtk-widget-text-color) + (let ((state (->gtk-widget-state state 'gtk-widget-text-color)) + (alien (make-alien '|GdkColor|))) + (C-> (gobject-alien widget) "GtkWidget style" alien) + (C-> alien "GtkStyle text" alien) + (C-array-loc! alien "GdkColor" state) + (peek-gdkcolor alien))) + +(define (gtk-widget-base-color widget #!optional state) + (guarantee-gtk-widget-realized widget 'gtk-widget-base-color) + (let ((state (->gtk-widget-state state 'gtk-widget-base-color)) + (alien (make-alien '|GdkColor|))) + (C-> (gobject-alien widget) "GtkWidget style" alien) + (C-> alien "GtkStyle base" alien) + (C-array-loc! alien "GdkColor" state) + (peek-gdkcolor alien))) + +(define (set-gtk-widget-fg-color! widget color #!optional state) + (guarantee-gtk-widget-realized widget 'set-gtk-widget-fg-color!) + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-fg-color!)) + (state (->gtk-widget-state state 'set-gtk-widget-fg-color!))) (modify-rcstyle widget (lambda (rcstyle) - (set-rcstyle-fg-color! rcstyle gdkcolor))) + (set-rcstyle-fg-color! rcstyle gdkcolor state))) (free gdkcolor))) -(define (set-rcstyle-fg-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle fg") - (C-> rcstyle "struct _GtkRcStyle color_flags") +(define (set-rcstyle-fg-color! rcstyle gdkcolor state) + (set-rcstyle-gdkcolor! gdkcolor state + (C-> rcstyle "GtkRcStyle fg") + (C-> rcstyle "GtkRcStyle color_flags") (C-enum "GTK_RC_FG"))) (define (set-rcstyle-gdkcolor! newcolor index colors flagss newflag) - ;; Hack modifier style GdkColor array and corresponding flags. (let ((color (C-array-loc! colors "GdkColor" index)) (flags (C-array-loc! flagss "uint" index))) (C->= color "GdkColor red" (C-> newcolor "GdkColor red")) @@ -299,311 +394,379 @@ USA. (C->= color "GdkColor blue" (C-> newcolor "GdkColor blue")) (C->= flags "GtkRcFlags" (fix:or newflag (C-> flags "GtkRcFlags"))))) -(define (set-gtk-widget-bg-color! widget color) - ;; Sets WIDGET's background color. Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-bg-color!))) +(define-generic set-gtk-widget-bg-color! (widget color #!optional state)) + +(define-method set-gtk-widget-bg-color! ((widget ) color + #!optional state) + (let ((gdkcolor (->gdkcolor color widget '(set-gtk-widget-bg-color! ))) + (state (->gtk-widget-state state '(set-gtk-widget-bg-color! )))) (modify-rcstyle widget (lambda (rcstyle) - (set-rcstyle-bg-color! rcstyle gdkcolor))) + (set-rcstyle-bg-color! rcstyle gdkcolor state))) (free gdkcolor))) -(define (set-rcstyle-bg-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle bg") - (C-> rcstyle "struct _GtkRcStyle color_flags") +(define (set-rcstyle-bg-color! rcstyle gdkcolor state) + (set-rcstyle-gdkcolor! gdkcolor state + (C-> rcstyle "GtkRcStyle bg") + (C-> rcstyle "GtkRcStyle color_flags") (C-enum "GTK_RC_BG"))) -(define (set-gtk-widget-text-color! widget color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-text-color!))) +(define (set-gtk-widget-text-color! widget color #!optional state) + (guarantee-gtk-widget-realized widget 'set-gtk-widget-text-color!) + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-text-color!)) + (state (->gtk-widget-state state 'set-gtk-widget-text-color!))) (modify-rcstyle widget (lambda (rcstyle) - (set-rcstyle-text-color! rcstyle gdkcolor))) + (set-rcstyle-text-color! rcstyle gdkcolor state))) (free gdkcolor))) -(define (set-rcstyle-text-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle text") - (C-> rcstyle "struct _GtkRcStyle color_flags") +(define (set-rcstyle-text-color! rcstyle gdkcolor state) + (set-rcstyle-gdkcolor! gdkcolor state + (C-> rcstyle "GtkRcStyle text") + (C-> rcstyle "GtkRcStyle color_flags") (C-enum "GTK_RC_TEXT"))) -(define (set-gtk-widget-base-color! widget color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-base-color!))) +(define (set-gtk-widget-base-color! widget color #!optional state) + (guarantee-gtk-widget-realized widget 'set-gtk-widget-base-color!) + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-base-color!)) + (state (->gtk-widget-state state 'set-gtk-widget-base-color!))) (modify-rcstyle widget (lambda (rcstyle) - (set-rcstyle-base-color! rcstyle gdkcolor))) + (set-rcstyle-base-color! rcstyle gdkcolor state))) (free gdkcolor))) -(define (set-rcstyle-base-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle base") - (C-> rcstyle "struct _GtkRcStyle color_flags") +(define (set-rcstyle-base-color! rcstyle gdkcolor state) + (set-rcstyle-gdkcolor! gdkcolor state + (C-> rcstyle "GtkRcStyle base") + (C-> rcstyle "GtkRcStyle color_flags") (C-enum "GTK_RC_BASE"))) -(define (->gdkcolor object widget operator) - (let ((rgb (->rgb object widget operator)) - (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) - (C->= gdkcolor "GdkColor red" (round->exact (* (vector-ref rgb 0) 65535))) - (C->= gdkcolor "GdkColor green" (round->exact(* (vector-ref rgb 1) 65535))) - (C->= gdkcolor "GdkColor blue" (round->exact (* (vector-ref rgb 2) 65535))) - gdkcolor)) - -(define (->rgb object widget operator) - (or (and (string? object) - (gtk-widget-parse-color widget object)) - (and (vector? object) (= 3 (vector-length object)) - object) - (error:wrong-type-argument object "a color name or #(rgb)" operator))) - -(define (gtk-widget-parse-color widget string) - ;; Returns the color named by STRING, or #F. STRING can be a color - ;; name, hex number, or symbolic color name for the WIDGET. - (guarantee-string string 'gtk-widget-parse-color) - (let ((style (C-> (check-gtk-widget-alien widget) "GtkWidget style")) - (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) - (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor)) - (zero? (C-call "gdk_color_parse" string gdkcolor))) - (begin - (free gdkcolor) - #f) - (let ((rgb (vector (/ (C-> gdkcolor "GdkColor red") 65535) - (/ (C-> gdkcolor "GdkColor green") 65535) - (/ (C-> gdkcolor "GdkColor blue") 65535)))) - (free gdkcolor) - rgb)))) +(define (->gtk-widget-state object operator) + (case (if (default-object? object) 'normal object) + ((NORMAL) (C-enum "GTK_STATE_NORMAL")) + ((ACTIVE) (C-enum "GTK_STATE_ACTIVE")) + ((PRELIGHT) (C-enum "GTK_STATE_PRELIGHT")) + ((SELECTED) (C-enum "GTK_STATE_SELECTED")) + ((INSENSITIVE) (C-enum "GTK_STATE_INSENSITIVE")) + (else (error:wrong-type-argument object "a GtkWidget state" operator)))) - -;;;; GtkContainers +;;; GtkContainers (define-class () + ;; A list of child gtk-widgets, in the reverse of the order in which + ;; they were added. + (reverse-children define standard initial-value '())) - ;; A list of child gtk-widgets. - (children define standard initial-value '())) +(define-guarantee gtk-container "a ") -(define-method gtk-object-destroy ((widget )) - ;; Calls gtk_object_destroy for WIDGET and all its children. +(define (gtk-container-children container) + (reverse (gtk-container-reverse-children container))) - (call-next-method widget) - (for-each (lambda (child) (gtk-container-destroy-child child)) - (gtk-container-children widget))) - -(define (gtk-container-destroy-child child) - ;; Destroy the child of a container without actually calling - ;; gtk_object_destroy, since an earlier call to gtk_object_destroy - ;; with an ancestor gtk-widget has already destroyed this child in - ;; the toolkit. Just mark these wrappers as destroyed (implicitly). - (if (not (gtk-object-destroyed? child)) - (let ((alien (gobject-alien child))) - (alien-null! alien) - (gtk-object-destroy child)))) +(define (gtk-bin-child container) + (let ((c (gtk-container-reverse-children container))) + (if (pair? c) (car c) #f))) (define (gtk-container-add parent child) - ;; gtk_container_add with some Scheme-side bookkeeping. - (let ((children (gtk-container-children parent))) - (if (memq child children) - (ferror child" is already contained in "parent".")) - (set-gtk-container-children! parent (cons child children))) - (set-gtk-widget-parent! child parent) - (C-call "gtk_container_add" - (gobject-alien parent) (gobject-alien child)) - unspecific) + (guarantee-gtk-container parent 'gtk-container-add) + (guarantee-gtk-widget child 'gtk-container-add) + (container-add! parent child) + (C-call "gtk_container_add" (gobject-alien parent) (gobject-alien child))) + +(define (gtk-container-remove parent child) + (guarantee-gtk-container parent 'gtk-container-remove) + (guarantee-gtk-widget child 'gtk-container-remove) + (container-remove! parent child) + (C-call "gtk_container_remove" (gobject-alien parent) (gobject-alien child))) (define (gtk-container-set-border-width container width) - (C-call "gtk_container_set_border_width" - (gobject-alien (check-gtk-container container)) - width)) - -(define-integrable (check-gtk-widget-alien object) - (gobject-alien (check-gtk-widget object))) - -(declare (integrate-operator check-gtk-widget)) -(define (check-gtk-widget object) - (if (gtk-widget? object) object - (error:wrong-type-argument object "" 'check-gtk-widget))) - -(declare (integrate-operator check-gtk-container)) -(define (check-gtk-container object) - (if (gtk-container? object) object - (error:wrong-type-argument object "" - 'check-gtk-container))) - + (guarantee-gtk-container container 'gtk-container-set-border-width) + (guarantee-positive-fixnum width 'gtk-container-set-border-width) + (C-call "gtk_container_set_border_width" (gobject-alien container) width)) +(define (container-add! container child) + (without-interrupts + (lambda () + (if (gtk-widget-parent child) + (error "Already a child:" child)) + (let ((children (gtk-container-reverse-children container))) + (if (memq child children) + (error "Already a child:" child container)) + (set-gtk-container-reverse-children! container (cons child children))) + (set-gtk-widget-parent! child container)))) + +(define (container-remove! container child) + (without-interrupts + (lambda () + (if (not (eq? container (gtk-widget-parent child))) + (error "Not parent:" container child)) + (let ((children (gtk-container-reverse-children container))) + (if (memq child children) + (set-gtk-container-reverse-children! container (delq! child children)) + (error "Not in container:" child container))) + (set-gtk-widget-parent! child #f)))) + ;;; GtkLabels -(define-class ( (constructor ())) ()) +(define-class ( (constructor () (string))) ()) + +(define-guarantee gtk-label "a ") + +(define-method initialize-instance ((label ) string) + (call-next-method label) + (let ((alien (gobject-alien label))) + (C-call "gtk_label_new" alien string) + (error-if-null alien "Could not create:" label string) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! label)) (define (gtk-label-new string) - (let* ((s (if (string? string) string - (ferror "The gtk-label string ("string") is not a string."))) - (l (make-gtk-label)) - (a (gobject-alien l))) - (C-call "gtk_label_new" a s) - (if (alien-null? a) (ferror "Could not create label "string".")) - l)) + (guarantee-string string 'gtk-label-new) + (make-gtk-label string)) (define (gtk-label-get-text label) + (guarantee-gtk-label label 'gtk-label-get-text) (let ((retval (make-alien '|gchar|))) (C-call "gtk_label_get_text" retval (gobject-alien label)) (c-peek-cstring retval))) (define (gtk-label-set-text label string) - (let ((s (if (string? string) string - (ferror "The gtk-label string ("string") is not a string.")))) - (C-call "gtk_label_set_text" (gobject-alien label) s))) - + (guarantee-gtk-label label 'gtk-label-set-text) + (guarantee-string string 'gtk-label-set-text) + (C-call "gtk_label_set_text" (gobject-alien label) string)) +(define (gtk-label-set-width-chars label n-chars) + (guarantee-non-negative-fixnum n-chars 'set-label-width!) + (C-call "gtk_label_set_width_chars" (gobject-alien label) n-chars)) + ;;; GtkButtons -(define-class ( (constructor ())) ()) - -(define (gtk-button-new) - (let* ((b (make-gtk-button)) - (a (gobject-alien b))) - (C-call "gtk_button_new" a) - (if (alien-null? a) (ferror "Could not create button.")) - b)) - -(declare (integrate-operator check-gtk-button)) -(define (check-gtk-button object) - (if (gtk-button? object) object - (error:wrong-type-argument object "" 'check-gtk-button))) - -(define (set-gtk-button-clicked-callback! button handler) - (let ((b (check-gtk-button button))) - (g-signal-connect - b (C-callback "clicked") - (lambda (GtkButton) - GtkButton ;ignore - (handler))))) +(define-class ( (constructor gtk-button-new ())) ()) + +(define-guarantee gtk-button "a ") + +(define-method initialize-instance ((button )) + (call-next-method button) + (let ((alien (gobject-alien button))) + (C-call "gtk_button_new" alien) + (error-if-null alien "Could not create:" button) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! button)) + +(define (set-gtk-button-clicked-callback! button callback) + (guarantee-gtk-button button 'set-gtk-button-clicked-callback!) + (guarantee-procedure-of-arity callback 1 'set-gtk-button-clicked-callback!) + (g-signal-connect button (C-callback "clicked") + (make-clicked-callback callback))) + +(define (make-clicked-callback callback) + (named-lambda (clicked-callback button) + (callback button))) + +(define-class ( (constructor gtk-check-button-new ())) + ()) + +(define-guarantee gtk-check-button "a ") + +(define-method initialize-instance ((button )) + (call-next-method button) + (let ((alien (gobject-alien button))) + (C-call "gtk_check_button_new" alien) + (error-if-null alien "Could not create:" button) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! button)) + +(define (gtk-check-button-get-active button) + (guarantee-gtk-check-button button 'gtk-check-button-get-active) + (not (fix:zero? + (C-call "gtk_toggle_button_get_active" (gobject-alien button))))) + +(define (gtk-check-button-set-active button active?) + (guarantee-gtk-check-button button 'gtk-check-button-set-active) + (C-call "gtk_toggle_button_set_active" + (gobject-alien button) (if active? 1 0))) + +(define (set-gtk-check-button-toggled-callback! button callback) + (guarantee-gtk-check-button button 'set-gtk-check-button-toggled-callback!) + (guarantee-procedure-of-arity callback 1 'set-gtk-check-button-toggled-callback!) + (g-signal-connect button (C-callback "toggled") + (make-toggled-callback callback))) + +(define (make-toggled-callback callback) + (named-lambda (gtk-check-button-toggled-callback button) + (callback button))) - ;;; GtkVBox -(define-class ( (constructor ())) ()) +(define-class ( (constructor () (homogeneous? spacing))) + ()) -(define (gtk-vbox-new homogeneous? spacing) - ;; homogeneous : TRUE if all children are to be given equal space allotments. - ;; spacing : the number of pixels to place by default between children. +(define-guarantee gtk-vbox "a ") - (let* ((vbox (make-gtk-vbox)) - (alien (gobject-alien vbox))) +(define-method initialize-instance ((vbox ) homogeneous? spacing) + (call-next-method vbox) + (let ((alien (gobject-alien vbox))) (C-call "gtk_vbox_new" alien (if homogeneous? 1 0) spacing) - (if (alien-null? alien) (ferror "Could not create vbox.")) - vbox)) + (error-if-null alien "Could not create:" vbox) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! vbox)) + +(define (gtk-vbox-new homogeneous? spacing) + (guarantee-boolean homogeneous? 'gtk-vbox-new) + (guarantee-non-negative-fixnum spacing 'gtk-vbox-new) + (make-gtk-vbox homogeneous? spacing)) + +(define-integrable-operator (guarantee-boolean object operator) + (if (not (or (eq? object #t) (eq? object #f))) + (error:wrong-type-argument object "#t or #f" operator))) + +(define-class ( (constructor () (homogeneous? spacing))) + ()) + +(define-guarantee gtk-hbox "a ") + +(define-method initialize-instance ((hbox ) homogeneous? spacing) + (call-next-method hbox) + (let ((alien (gobject-alien hbox))) + (C-call "gtk_hbox_new" alien (if homogeneous? 1 0) spacing) + (error-if-null alien "Could not create:" hbox) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! hbox)) + +(define (gtk-hbox-new homogeneous? spacing) + (guarantee-boolean homogeneous? 'gtk-hbox-new) + (guarantee-non-negative-fixnum spacing 'gtk-hbox-new) + (make-gtk-hbox homogeneous? spacing)) (define (gtk-box-pack-start box child expand? fill? padding) - (let ((children (gtk-container-children box))) - (if (memq child children) - (ferror "Child "child" is already packed in parent "box".")) - (set-gtk-container-children! box (cons child children))) - (set-gtk-widget-parent! child box) + (container-add! box child) (C-call "gtk_box_pack_start" (gobject-alien box) (gobject-alien child) - (if expand? 1 0) (if fill? 1 0) padding) - unspecific) + (if expand? 1 0) (if fill? 1 0) padding)) (define (gtk-box-pack-end box child expand? fill? padding) - (let ((children (gtk-container-children box))) - (if (memq child children) - (ferror "Child "child" is already packed in parent "box".")) - (set-gtk-container-children! box (cons child children))) - (set-gtk-widget-parent! child box) + (container-add! box child) (C-call "gtk_box_pack_end" (gobject-alien box) (gobject-alien child) - (if expand? 1 0) (if fill? 1 0) padding) - unspecific) - + (if expand? 1 0) (if fill? 1 0) padding)) -;;;; GtkScrolledWindows +(define-class ( (constructor () (label))) ()) -(define-class ( - (constructor make-gtk-scrolled-window ())) +(define-guarantee gtk-frame "a ") + +(define-method initialize-instance ((frame ) label) + (call-next-method frame) + (let ((alien (gobject-alien frame))) + (C-call "gtk_frame_new" alien label) + (error-if-null alien "Could not create:" frame) + (C-call "g_object_ref_sink" alien alien)) + (set-gtk-object-destroy-callback! frame)) + +(define (gtk-frame-new label) + (guarantee-string label 'gtk-frame-new) + (make-gtk-frame label)) + +(define (gtk-frame-set-shadow-type frame type) + (let ((t (->gtk-shadow-type type 'gtk-frame-set-shadow-type))) + (C-call "gtk_frame_set_shadow_type" (gobject-alien frame) t))) + +(define (->gtk-shadow-type object operator) + (case object + ((none) (C-enum "GTK_SHADOW_NONE")) + ((in) (C-enum "GTK_SHADOW_IN")) + ((out) (C-enum "GTK_SHADOW_OUT")) + ((etched-in) (C-enum "GTK_SHADOW_ETCHED_IN")) + ((etched-out) (C-enum "GTK_SHADOW_ETCHED_OUT")) + (else + (error:wrong-type-argument object "a GtkShadowType symbol" operator)))) + +;;; GtkScrolledWindows + +(define-class ( (constructor ())) ()) +(define-guarantee gtk-scrolled-window "a ") + (define (gtk-scrolled-window-new) (let* ((window (make-gtk-scrolled-window)) (alien (gobject-alien window))) - (C-call "gtk_scrolled_window_new" alien null-alien null-alien) - (if (alien-null? alien) (ferror "Could not create GtkScrolledWindow.")) + (C-call "gtk_scrolled_window_new" alien 0 0) + (error-if-null alien "Could not create:" window) + (C-call "g_object_ref_sink" alien alien) + (set-gtk-object-destroy-callback! window) window)) (define (gtk-scrolled-window-set-policy window horizontal vertical) - (let ((w (check-scrolled-window window)) - (h (check-scrollbar-policy horizontal)) - (v (check-scrollbar-policy vertical))) - (C-call "gtk_scrolled_window_set_policy" (gobject-alien w) h v))) + (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-policy) + (C-call "gtk_scrolled_window_set_policy" (gobject-alien window) + (->policy horizontal 'gtk-scrolled-window-set-policy) + (->policy vertical 'gtk-scrolled-window-set-policy))) (define (gtk-scrolled-window-set-placement window placement) - (let ((w (check-scrolled-window window)) - (p (check-scrolled-window-placement placement))) - (C-call "gtk_scrolled_window_set_placement" (gobject-alien w) p))) - -(declare (integrate-operator check-scrolled-window)) -(define (check-scrolled-window object) - (if (gtk-scrolled-window? object) object - (error:wrong-type-argument object "" - 'check-scrolled-window))) - -(declare (integrate-operator check-scrollbar-policy)) -(define (check-scrollbar-policy object) + (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-placement) + (C-call "gtk_scrolled_window_set_placement" (gobject-alien window) + (->placement placement 'gtk-scrolled-window-set-placement))) + +(define (->policy object operator) (case object ((ALWAYS) (C-enum "GTK_POLICY_ALWAYS")) ((AUTO) (C-enum "GTK_POLICY_AUTOMATIC")) ((NEVER) (C-enum "GTK_POLICY_NEVER")) - (else (error:wrong-type-argument object "symbol: ALWAYS, AUTO or NEVER" - 'check-scrollbar-policy)))) + (else (error:wrong-type-argument + object "a symbol -- one of ALWAYS, AUTO or NEVER" operator)))) -(declare (integrate-operator check-scrolled-window-placement)) -(define (check-scrolled-window-placement object) +(define (->placement object operator) (case object ((TOP-LEFT) (C-enum "GTK_CORNER_TOP_LEFT")) ((BOTTOM-LEFT) (C-enum "GTK_CORNER_BOTTOM_LEFT")) ((TOP-RIGHT) (C-enum "GTK_CORNER_TOP_RIGHT")) ((BOTTOM-RIGHT) (C-enum "GTK_CORNER_BOTTOM_RIGHT")) (else (error:wrong-type-argument - object "symbol: TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT" - 'check-scrolled-window-placement)))) + object + "a symbol -- one of TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT" + operator)))) +;;; GtkWindows -;;;; GtkWindows - -(define-class ( (constructor make-gtk-window (type))) +(define-class ( (constructor gtk-window-new () (type))) () ;; 'POPUP or 'TOPLEVEL (type define accessor)) -(define (gtk-window-new type) - (let* ((type (check-window-type type)) - (window (make-gtk-window type)) - (alien (gobject-alien window))) - (C-call "gtk_window_new" alien - (case type - ((TOPLEVEL) (C-enum "GTK_WINDOW_TOPLEVEL")) - ((POPUP) (C-enum "GTK_WINDOW_POPUP")))) - (if (alien-null? alien) (ferror "Could not create window.")) - (g-signal-connect window (C-callback "destroy") - (named-lambda (gtk-window-new::destroy GtkObject) - GtkObject ;;ignore - (gtk-object-destroy window))) - (C-call "gtk_window_set_default_size" alien -1 -1) - window)) +(define-guarantee gtk-window "a ") + +(define-method initialize-instance ((window ) type) + (call-next-method window) + (let ((type (->window-type type 'gtk-window-new)) + (alien (gobject-alien window))) + (C-call "gtk_window_new" alien type) + (error-if-null alien "Could not create:" window type) + (C-call "g_object_ref_sink" alien alien) + (set-gtk-object-destroy-callback! window) + (set! toplevel-windows (cons window toplevel-windows)))) -(declare (integrate-operator check-window-type)) -(define (check-window-type type) +(define toplevel-windows '()) + +(define-method gtk-object-destroy-callback ((window )) + (call-next-method window) + (set! toplevel-windows (delq! window toplevel-windows))) + +(define (->window-type type operator) (case type - ((TOPLEVEL POPUP) type) + ((TOPLEVEL) (C-enum "GTK_WINDOW_TOPLEVEL")) + ((POPUP) (C-enum "GTK_WINDOW_POPUP")) (else - (error:wrong-type-argument type "symbol: TOPLEVEL or POPUP" - 'check-window-type)))) - -(declare (integrate-operator check-gtk-window)) -(define (check-gtk-window object) - (if (gtk-window? object) object - (error:wrong-type-argument object "" 'check-gtk-window))) + (error:wrong-type-argument + type "a symbol -- one of TOPLEVEL or POPUP" operator)))) (define (gtk-window-set-title window title) + (guarantee-gtk-window window 'gtk-window-set-title) (guarantee-string title 'gtk-window-set-title) - (let ((alien (gobject-alien (check-gtk-window window)))) - (C-call "gtk_window_set_title" alien title))) + (C-call "gtk_window_set_title" (gobject-alien window) title)) + +(define (gtk-window-set-opacity window opacity) + (guarantee-gtk-window window 'gtk-window-set-opacity) + (guarantee-real opacity 'gtk-window-set-opacity) + (if (not (<= 0. opacity 1.)) + (error:bad-range-argument opacity 'gtk-window-set-opacity)) + (C-call "gtk_window_set_opacity" (gobject-alien window) opacity)) (define (gtk-window-get-default-size window receiver) - ;; Calls RECEIVER with WINDOW's default width and height. + (guarantee-gtk-window window 'gtk-window-get-default-size) (let* ((*width (malloc (fix:* 2 (C-sizeof "gint")) 'gint)) (*height (alien-byte-increment *width (C-sizeof "gint") 'gint))) (C-call "gtk_window_get_default_size" @@ -614,34 +777,131 @@ USA. (receiver width height)))) (define (gtk-window-set-default-size window width height) + (guarantee-gtk-window window 'gtk-window-set-default-size) (guarantee-integer width 'gtk-window-set-default-size) (guarantee-integer height 'gtk-window-set-default-size) - (let ((alien (gobject-alien (check-gtk-window window)))) - (C-call "gtk_window_set_default_size" alien width height))) + (C-call "gtk_window_set_default_size" (gobject-alien window) width height)) + +(define (gtk-window-set-geometry-hints window widget . hints) + (let ((geometry (malloc (C-sizeof "GdkGeometry"))) + (mask 0)) + + (define-integrable-operator (get-fixnum name) + (let ((entry (assq name hints))) + (and entry + (let ((v (cdr entry))) + (cond ((not (fixnum? v)) (error "Not a fixnum:" v name 'gtk-window-set-geometry-hints)) + ((fix:< v -1) (error "Negative:" v name 'gtk-window-set-geometry-hints)) + (else v)))))) + + (define-integrable-operator (get-real name) + (let ((entry (assq name hints))) + (and entry + (let ((v (cdr entry))) + (if (not (real? v)) + (error "Not real:" v name 'gtk-window-set-geometry-hints) + v))))) + + (define-integrable (get-gravity) + (let ((entry (assq 'gravity hints))) + (and entry + (case (cdr entry) + ((north) (C-enum "GDK_GRAVITY_NORTH")) + ((northeast) (C-enum "GDK_GRAVITY_NORTH_EAST")) + ((east) (C-enum "GDK_GRAVITY_EAST")) + ((southeast) (C-enum "GDK_GRAVITY_SOUTH_EAST")) + ((south) (C-enum "GDK_GRAVITY_SOUTH")) + ((southwest) (C-enum "GDK_GRAVITY_SOUTH_WEST")) + ((west) (C-enum "GDK_GRAVITY_WEST")) + ((northwest) (C-enum "GDK_GRAVITY_NORTH_WEST")) + ((center) (C-enum "GDK_GRAVITY_CENTER")) + ((static) (C-enum "GDK_GRAVITY_STATIC")) + (else (error "Not a gravity:" (cdr entry) 'gtk-window-set-geometry-hints)))))) + + (let ((width (get-fixnum 'min-width)) + (height (get-fixnum 'min-height))) + (cond ((and width height) + (C->= geometry "GdkGeometry min_width" width) + (C->= geometry "GdkGeometry min_height" height) + (set! mask (fix:+ mask (C-enum "GDK_HINT_MIN_SIZE")))) + ((and (not width) (not height))) + (else (error "Both min-width and min-height are required:" hints)))) + + (let ((width (get-fixnum 'max-width)) + (height (get-fixnum 'max-height))) + (cond ((and width height) + (C->= geometry "GdkGeometry max_width" width) + (C->= geometry "GdkGeometry max_height" height) + (set! mask (fix:+ mask (C-enum "GDK_HINT_MAX_SIZE")))) + ((and (not width) (not height))) + (else (error "Both max-width and max-height are required:" hints)))) + + (let ((width (get-fixnum 'base-width)) + (height (get-fixnum 'base-height))) + (cond ((and width height) + (C->= geometry "GdkGeometry base_width" width) + (C->= geometry "GdkGeometry base_height" height) + (set! mask (fix:+ mask (C-enum "GDK_HINT_BASE_SIZE")))) + ((and (not width) (not height))) + (else (error "Both base-width and base-height are required:" hints)))) + + (let ((width (get-fixnum 'width-increment)) + (height (get-fixnum 'height-increment))) + (cond ((and width height) + (C->= geometry "GdkGeometry width_inc" width) + (C->= geometry "GdkGeometry height_inc" height) + (set! mask (fix:+ mask (C-enum "GDK_HINT_RESIZE_INC")))) + ((and (not width) (not height))) + (else (error "Both width-increment and height-increment are required:" hints)))) + + (let ((min (get-real 'min-aspect)) + (max (get-real 'max-aspect))) + (cond ((and min max) + (C->= geometry "GdkGeometry min_aspect" min) + (C->= geometry "GdkGeometry max_aspect" max) + (set! mask (fix:+ mask (C-enum "GDK_HINT_ASPECT")))) + ((and (not min) (not max))) + (else (error "Both min-aspect and max-aspect must be specified:" hints)))) + + (let ((gravity (get-gravity))) + (if gravity + (begin + (C->= geometry "GdkGeometry win_gravity" gravity) + (set! mask (fix:+ mask (C-enum "GDK_HINT_WIN_GRAVITY")))))) + + (C-call "gtk_window_set_geometry_hints" + (gobject-alien window) + (gobject-alien widget) + geometry mask) + (free geometry))) (define (gtk-window-parse-geometry window geometry) + (guarantee-gtk-window window 'gtk-window-parse-geometry) (guarantee-string geometry 'gtk-window-parse-geometry) - (let ((alien (gobject-alien (check-gtk-window window)))) - (if (fix:zero? (C-call "gtk_window_parse_geometry" alien geometry)) - (ferror "Could not parse geometry string: "geometry)))) + (if (fix:zero? (C-call "gtk_window_parse_geometry" + (gobject-alien window) geometry)) + (error "Could not parse geometry string:" geometry))) (define (gtk-window-resize window width height) - (guarantee-integer width 'gtk-window-resize) - (guarantee-integer height 'gtk-window-resize) - (let ((alien (gobject-alien (check-gtk-window window)))) - (C-call "gtk_window_resize" alien width height))) + (guarantee-gtk-window window 'gtk-window-resize) + (guarantee-positive-fixnum width 'gtk-window-resize) + (guarantee-positive-fixnum height 'gtk-window-resize) + (C-call "gtk_window_resize" (gobject-alien window) width height)) (define (gtk-window-present window) - (let ((alien (gobject-alien (check-gtk-window window)))) - (C-call "gtk_window_present" alien))) - -(define (set-gtk-window-delete-event-callback! window handler) - (let ((w (check-gtk-window window))) - (g-signal-connect - w (C-callback "delete_event") - (lambda (GtkWidget GdkEvent) - GtkWidget GdkEvent ;ignore - (handler))))) + (guarantee-gtk-window window 'gtk-window-present) + (C-call "gtk_window_present" (gobject-alien window))) + +(define (set-gtk-window-delete-event-callback! window callback) + (guarantee-gtk-window window 'set-gtk-window-delete-event-callback!) + (guarantee-procedure-of-arity callback 1 'set-gtk-window-delete-event-callback!) + (g-signal-connect window (C-callback "delete_event") + (make-delete-event-callback callback))) + +(define (make-delete-event-callback callback) + (named-lambda (delete-event-callback window GdkEvent) + (declare (ignore GdkEvent)) + (callback window))) (define trace? #f) diff --git a/src/gtk/gtk-shim.h b/src/gtk/gtk-shim.h index 7836b820e..ef00c526e 100644 --- a/src/gtk/gtk-shim.h +++ b/src/gtk/gtk-shim.h @@ -39,9 +39,6 @@ typedef struct _ScmWidget ScmWidget; struct _ScmWidgetClass { GtkWidgetClass parent_class; - void (*set_scroll_adjustments) (GtkWidget *widget, - GtkAdjustment *hadjustment, - GtkAdjustment *vadjustment); /* Padding for future expansion */ void (*_gtk_reserved1) (void); @@ -53,15 +50,6 @@ struct _ScmWidgetClass struct _ScmWidget { GtkWidget widget; - /* Callback ids, for the methods to use when calling the callback tramps. */ - gint finalize; - gint destroy; - gint realize; - gint unrealize; - gint size_request; - gint size_allocate; - gint event; - gint set_scroll_adjustments; }; extern GtkWidget* scm_widget_new (void); diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index 2c2cef703..8d1f06e24 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -36,35 +36,9 @@ USA. (typedef ScmWidget (struct _ScmWidget - (widget GtkWidget) - (finalize gint) - (destroy gint) - (realize gint) - (unrealize gint) - (size_request gint) - (size_allocate gint) - (event gint) - (set_scroll_adjustments gint))) + (widget GtkWidget))) (extern (* GtkWidget) scm_widget_new) - -(callback void widget_finalize - (ID int) (object (* GObject))) -(callback void widget_destroy - (ID int) (object (* GtkObject))) -(callback void widget_realize - (ID int) (widget (* GtkWidget))) -(callback void widget_unrealize - (ID int) (widget (* GtkWidget))) -(callback void widget_size_request - (ID int) (widget (* GtkWidget)) (requisition (* GtkRequisition))) -(callback void widget_size_allocate - (ID int) (widget (* GtkWidget)) (allocation (* GtkAllocation))) -(callback gint widget_event - (ID int) (widget (* GtkWidget)) (event (* GdkEvent))) -(callback void widget_set_scroll_adjustments - (ID int) (widget (* GtkWidget)) - (hadj (* GtkAdjustment)) (vadj (* GtkAdjustment))) ;;; Signal handlers. @@ -73,6 +47,30 @@ USA. (object (* GtkObject)) (ID gpointer)) +(callback void size_allocate + (widget (* GtkWidget)) + (allocation (* GtkAllocation)) + (ID gpointer)) + +(callback void realize + (widget (* GtkWidget)) + (ID gpointer)) + +(callback void unrealize + (widget (* GtkWidget)) + (ID gpointer)) + +(callback gint event + (widget (* GtkWidget)) + (event (* GdkEvent)) + (ID gpointer)) + +(callback void set_scroll_adjustments + (widget (* GtkWidget)) + (hadj (* GtkAdjustment)) + (vadj (* GtkAdjustment)) + (ID gpointer)) + (callback gboolean delete_event (window (* GtkWidget)) (event (* GdkEventAny)) @@ -82,6 +80,10 @@ USA. (widget (* GtkWidget)) (ID gpointer)) +(callback void toggled + (togglebutton (* GtkToggleButton)) + (ID gpointer)) + (callback void value_changed (adjustment (* GtkAdjustment)) (ID gpointer)) @@ -114,15 +116,16 @@ USA. (argc (* int)) (argv (* (* (* char))))) -(extern void - gtk_widget_queue_resize - (widget (* GtkWidget))) - (extern void ;gtk+-2.4.0/gtk/gtkcontainer.h gtk_container_add (container (* GtkContainer)) (widget (* GtkWidget))) +(extern void ;gtk+-2.4.0/gtk/gtkcontainer.h + gtk_container_remove + (container (* GtkContainer)) + (widget (* GtkWidget))) + (extern void ;gtk+-2.4.0/gtk/gtkcontainer.h gtk_container_set_border_width (container (* GtkContainer)) @@ -131,34 +134,30 @@ USA. (extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtkbutton.h gtk_button_new) -(extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtklabel.h - gtk_label_new - (str (* (const char)))) - -(extern (* (const gchar)) ;gtk+-2.4.0/gtk/gtklabel.h - gtk_label_get_text - (label (* GtkLabel))) +(extern (* GtkWidget) ;gtk+-2.20.1/gtk/gtkcheckbutton.h + gtk_check_button_new) -(extern void gtk_label_set_text ;gtk+-2.4.0/gtk/gtklabel.h - (label (* GtkLabel)) - (str (* (const char)))) +(extern void ;gtk+-2.20.1/gtk/gtktogglebutton.h + gtk_toggle_button_set_active + (toggle_button (* GtkToggleButton)) + (is_active gboolean)) -(extern void gdk_rgb_find_color ;gtk+-2.8.20/gdk/gdkrgb.h - (colormap (* GdkColormap)) - (color (* GdkColor))) +(extern gboolean ;gtk+-2.20.1/gtk/gtktogglebutton.h + gtk_toggle_button_get_active + (toggle_button (* GtkToggleButton))) (extern (* GtkWidget) ;gtk+-2.8.20/gtk/gtkscrolledwindow.h gtk_scrolled_window_new (hadjustment (* GtkAdjustment)) (vadjustment (* GtkAdjustment))) -(extern void +(extern void ;gtk+-2.8.20/gtk/gtkscrolledwindow.h gtk_scrolled_window_set_policy (scrolled_window (* GtkScrolledWindow)) (hscrollbar_policy GtkPolicyType) (vscrollbar_policy GtkPolicyType)) -(extern void +(extern void ;gtk+-2.8.20/gtk/gtkscrolledwindow.h gtk_scrolled_window_set_placement (scrolled_window (* GtkScrolledWindow)) (window_placement GtkCornerType)) \ No newline at end of file diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index c285c9531..4d2ff583f 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -36,34 +36,71 @@ USA. (files "gobject") (export (gtk) gobject-alien - gobject-unref gobject-finalized? + gobject-live? gobject-unref! g-signal-connect g-signal-disconnect add-gc-cleanup punt-gc-cleanup gobject-get-property gobject-set-properties gquark-from-string gquark-to-string - make-pixbuf-loader load-pixbuf-from-file + make-pixbuf-loader + load-pixbuf-from-port load-pixbuf-from-file pixbuf-loader-size-hook set-pixbuf-loader-size-hook! pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook! pixbuf-loader-update-hook set-pixbuf-loader-update-hook! pixbuf-loader-close-hook set-pixbuf-loader-close-hook! - pixbuf-loader-pixbuf pixbuf-loader-error-message) - (initialization (initialize-package!))) + pixbuf-loader-pixbuf pixbuf-loader-error-message + + gdk-window-process-updates)) + +(define-package (gtk pango) + (parent (gtk)) + (files "pango") + (export (gtk) + + pango-layout-get-context + pango-layout-context-changed + pango-layout-get-font-description + pango-layout-set-font-description + pango-layout-set-text + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-context-get-font-description + pango-context-set-font-description + pango-context-get-metrics + pango-context-spacing + pango-font-metrics-get-ascent + pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref)) (define-package (gtk gtk-object) (parent (gtk)) (files "gtk-object") (export (gtk) - gtk-object-destroyed? gtk-object-destroy - make-gtk-adjustment set-gtk-adjustment! - gtk-widget? gtk-widget-parent + gtk-object? guarantee-gtk-object + gtk-object-destroyed? gtk-object-destroy + gtk-adjustment? guarantee-gtk-adjustment + make-gtk-adjustment set-gtk-adjustment! + gtk-widget? guarantee-gtk-widget + gtk-widget-parent + gtk-widget-realized? gtk-widget-drawable? gtk-widget-has-focus? gtk-widget-grab-focus + gtk-widget-show gtk-widget-show-all gtk-widget-error-bell gtk-widget-queue-draw + gtk-widget-get-colormap gtk-widget-get-pango-context gtk-widget-create-pango-layout gtk-widget-set-size-request + ;;gtk-widget-set-can-focus + set-gtk-widget-size-allocate-callback! + set-gtk-widget-realize-callback! + set-gtk-widget-unrealize-callback! + set-gtk-widget-event-callback! gtk-widget-font set-gtk-widget-font! gtk-widget-fg-color gtk-widget-bg-color @@ -72,100 +109,119 @@ USA. set-gtk-widget-text-color! set-gtk-widget-base-color! gtk-widget-parse-color - gtk-container? - gtk-container-children gtk-container-add + gtk-container? guarantee-gtk-container + gtk-container-children gtk-bin-child + gtk-container-add gtk-container-remove gtk-container-set-border-width - gtk-window-type - gtk-window-new gtk-window-set-title + ;;gtk-container-set-resize-mode + ;;gtk-container-check-resize + + gtk-window? guarantee-gtk-window + gtk-window-new gtk-window-set-title gtk-window-type + gtk-window-set-opacity gtk-window-set-default-size gtk-window-get-default-size gtk-window-parse-geometry gtk-window-resize gtk-window-present set-gtk-window-delete-event-callback! - gtk-button-new - set-gtk-button-clicked-callback! - gtk-label-new + gtk-label? guarantee-gtk-label + gtk-label-new gtk-label-get-text gtk-label-set-text - gtk-vbox-new gtk-box-pack-start gtk-box-pack-end - gtk-scrolled-window-new + gtk-label-set-width-chars + gtk-button? guarantee-gtk-button + gtk-button-new + set-gtk-button-clicked-callback! + gtk-check-button? guarantee-gtk-check-button + gtk-check-button-new + gtk-check-button-get-active gtk-check-button-set-active + set-gtk-check-button-toggled-callback! + gtk-vbox? guarantee-gtk-vbox gtk-vbox-new + gtk-hbox? guarantee-gtk-hbox gtk-hbox-new + gtk-box-pack-start gtk-box-pack-end + gtk-frame? guarantee-gtk-frame gtk-frame-new + gtk-frame-set-shadow-type + gtk-scrolled-window? + guarantee-gtk-scrolled-window gtk-scrolled-window-new gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement) - (import (gtk gobject) gobject-cleanup gobject-signals) - (import (gtk pango) make-pango-layout check-PangoFontDescription)) + (import (gtk pango) make-pango-layout guarantee-pango-font-description)) (define-package (gtk widget) (parent (gtk)) (files "scm-widget") + (import (gtk gtk-object) + set-gtk-object-destroy-callback!) (export (gtk) - set-scm-widget-destroy! - set-scm-widget-realize! set-scm-widget-unrealize! - set-scm-widget-size-request! set-scm-widget-size-allocate! - set-scm-widget-event! - set-scm-widget-set-scroll-adjustments!)) + set-scm-widget-set-scroll-adjustments-callback!)) -(define-package (gtk layout) +(define-package (gtk fix-layout) (parent (gtk)) - (files "scm-layout") + (files "fix-layout") + (import (gtk pango) + make-pango-layout pango-rectangle pangos->pixels pixels->pangos) + (import (gtk gtk-object) + parse-gdkcolor set-gtk-object-destroy-callback!) (export (gtk) - scm-layout-new - scm-layout-geometry set-scm-layout-size! - scm-layout-drawing set-scm-layout-drawing! - scm-layout-on-screen-area set-scm-layout-scroll-pos! - scm-layout-scroll-step set-scm-layout-scroll-step! + fix-layout? make-fix-layout set-fix-layout-size! + fix-layout-drawing set-fix-layout-drawing! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw! + fix-layout-new-geometry-callback fix-layout-realize-callback + set-fix-layout-map-handler! + set-fix-layout-unmap-handler! + set-fix-layout-focus-change-handler! + set-fix-layout-visibility-notify-handler! + set-fix-layout-key-press-handler! + set-fix-layout-motion-handler! + set-fix-layout-button-handler! - set-scm-layout-map-handler! - set-scm-layout-unmap-handler! - set-scm-layout-focus-change-handler! - set-scm-layout-visibility-notify-handler! - set-scm-layout-key-press-handler! - set-scm-layout-motion-handler! - set-scm-layout-button-release-handler! + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! fix-drawing-pick-list + fix-drawing-add-ink! - make-drawing drawing-widgets - set-drawing-size! drawing-pick-list + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-move! fix-ink-remove! + - - drawn-item-drawing drawn-item-area set-drawn-item-position! - drawn-item-widgets set-drawn-item-widgets! - drawn-item-remove! + line-ink? make-line-ink set-line-ink! + line-ink-width set-line-ink-width! + line-ink-color set-line-ink-color! + line-ink-dash-color set-line-ink-dash-color! - add-box-item set-box-item-size! - set-box-item-pos-size! set-box-item-shadow! + rectangle-ink? make-rectangle-ink set-rectangle-ink! + rectangle-ink-color set-rectangle-ink-color! + rectangle-ink-width set-rectangle-ink-width! + rectangle-ink-fill-color set-rectangle-ink-fill-color! - add-hline-item set-hline-item-size! - add-vline-item set-vline-item-size! + arc-ink? make-arc-ink set-arc-ink! + arc-ink-start-angle set-arc-ink-start-angle! + arc-ink-sweep-angle set-arc-ink-sweep-angle! + arc-ink-color set-arc-ink-color! + arc-ink-width set-arc-ink-width! + arc-ink-fill-color set-arc-ink-fill-color! - add-text-item text-item-text set-text-item-text! - text-item? text-item-xy-to-index - call-with-text-item-grapheme-rect + text-ink? + set-text-ink-position! + text-ink-xy-to-index + with-text-ink-grapheme-rect + text-ink-color set-text-ink-color! - add-image-item-from-file)) + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + simple-text-ink-font set-simple-text-ink-font! -(define-package (gtk pango) - (parent (gtk)) - (files "pango") - (export (gtk) - - pango-layout-get-context - pango-layout-get-font-description - pango-layout-set-text - pango-layout-get-pixel-extents - pango-layout-index-to-pos - pango-font-description-from-string - pango-font-description-to-string - pango-font-description-free - pango-context-get-font-description - pango-context-set-font-description - pango-context-get-metrics - pango-context-spacing - pango-font-metrics-get-ascent - pango-font-metrics-get-descent - pango-font-metrics-get-approximate-char-width - pango-font-metrics-unref - pango-rectangle - pangos->pixels - pixels->pangos)) + make-image-ink-from-file set-image-ink! + + box-ink? make-box-ink + set-box-ink! set-box-ink-position! + box-ink-shadow set-box-ink-shadow! + + ;; make-hline-ink set-hline-ink-size! + ;; make-vline-ink set-vline-ink-size! + )) (define-package (gtk keys) (parent (gtk)) @@ -178,7 +234,6 @@ USA. (parent (runtime thread)) (files "thread") (export (gtk) - create-gtk-thread kill-gtk-thread) (import (gtk gobject) run-gc-cleanups) @@ -194,21 +249,97 @@ USA. default/process-command-line) (import (runtime) ucode-primitive) + (import (gtk thread) + create-gtk-thread) (export (gtk) gtk-time-slice-window? gtk-time-slice-window! gtk-select-trace? - gtk-select-trace!) - (initialization (initialize-package!))) + gtk-select-trace!)) (define-package (gtk event-viewer) (parent (gtk)) (files "gtk-ev") + (import (gtk fix-layout) + gdk-rectangle gdk-rectangle-from-rect + make-fix-rect + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-max-y set-fix-rect! fix-rect-union!) + (import (gtk pango) + pango-rectangle pangos->pixels) (export () - gtk-event-viewer)) + make-gtk-event-viewer-demo)) -(define-package (gtk demo) +(define-package (gtk fix-layout demo) + (parent (gtk fix-layout)) + (files "fix-demo") + (import (gtk fix-layout) + fix-layout-view) + (export () + make-fix-layout-demo)) + +(define-package (gtk swat) (parent (gtk)) - (files "demo") + (files "swat") + (import (gtk gtk-object) + gtk-object-destroy-callback) + (import (gtk fix-layout) + fix-layout-view fix-ink-extent fix-ink-expose-callback + fix-drawing-display-list set-fix-drawing-display-list! + set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in? + fix-rect-x fix-rect-y with-fix-rect + set-fix-rect-size! fix-rect-move! copy-fix-rect! + point-in-fix-rect? fix-rect-union!) + (export (swat) + add-child! remove-child! ask-widget + add-event-handler! set-callback! + after-delay on-death! + swat-open swat-close + make-active-variable set-active-variable! + make-hbox make-vbox box-children + make-button make-label + make-checkbutton checkbutton-variable-on? + make-canvas make-canvas-item-group + make-line-on-canvas make-rectangle-on-canvas + make-oval-on-canvas make-text-on-canvas)) + +(define-package (swat) + (parent ())) + +#;(define-package (swat examples) + (parent (swat)) + (files "swat-examples")) + +(define-package (swat pole-zero) + (parent (swat)) + (files "swat-pole-zero") + (export () + make-pole-zero)) + +#;(define-package (swat plotter) + (parent (swat)) + (files "swat-plotter") (export () - scm-layout-demo)) \ No newline at end of file + plotter + plot + set-plotter-params + reset-plotter-params + make-vals + change-color + change-pt-style + change-num-pts + clear-curve + plot-curve + delete-curve + add-show-vals + clear-show-vals + draw-show-vals + delete-show-vals + add-xticks + add-yticks + clear-ticks + draw-ticks + delete-ticks + clear-plotter + replot + reset-plotter)) \ No newline at end of file diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm index fb8a8a688..6f7c8024b 100644 --- a/src/gtk/gtk.scm +++ b/src/gtk/gtk.scm @@ -22,10 +22,66 @@ USA. |# ;;;; Core utilities. -;;; package: (gtk) - - -(c-include "gtk") +;;; package: (gtk utilities) + +(define-syntax define-integrable-operator + (er-macro-transformer + (lambda (form rename compare) + (declare (ignore compare)) + (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form)) + (let ((r-begin (rename 'BEGIN)) + (r-declare (rename 'DECLARE)) + (r-define (rename 'DEFINE))) + `(,r-begin + (,r-declare (INTEGRATE-OPERATOR ,(caadr form))) + (,r-define ,@(cdr form))))) + (else + (ill-formed-syntax form)))))) + +(define-syntax if-debugging + (er-macro-transformer + (lambda (form rename compare) + (declare (ignore compare)) + (let ((r-begin (rename 'BEGIN))) + (if debugging? + `(,r-begin ,@(cdr form)) + `(,r-begin)))))) + +;; Setting this affects only newly-compiled code. +(define debugging? #f) + +(define-syntax error-if-null + (syntax-rules () + ((_ ALIEN . MESSAGE) + (if (alien-null? ALIEN) + ((lambda () (apply error . MESSAGE))))))) + +(define-integrable-operator (fix:max n m) (if (fix:> n m) n m)) + +(define-integrable-operator (fix:min n m) (if (fix:< n m) n m)) + +(define-integrable-operator (fix:negate i) (fix:- 0 i)) + +(define-integrable-operator (fix:abs n) + (if (fix:negative? n) (fix:negate n) n)) + +(define (bit-mask . ints) + ;; For bit field masks. INTS is assumed to be a list of powers + ;; of two, no repeats. + (fold-left int:+ 0 ints)) + +(define-integrable (bit-mask-indices num) + ;; The indices of the bits set in NUM. + (let ((str (unsigned-integer->bit-string 32 num))) + (let loop ((start 0)) + (let ((next (bit-substring-find-next-set-bit str start 32))) + (if next + (cons next (loop (fix:1+ next))) + '()))))) + +(define-integrable (bit? int mask) + ;; This seems... inefficient. + (not (int:zero? (bit-and int mask)))) (define (bit-and . numbers) (bit-string->unsigned-integer @@ -45,282 +101,4 @@ USA. (bit-string-or! bits bits2) bits)) (unsigned-integer->bit-string 32 0) - numbers))) - - -;;;; Rectangles. - -(define-structure (rect (constructor make-rect (#!optional x y width height)) - (print-procedure - (standard-unparser-method 'RECT - (lambda (rect port) - (write-string - (let ((x (number->string (rect-x rect))) - (y (number->string (rect-y rect))) - (w (number->string (rect-width rect))) - (h (number->string (rect-height rect)))) - (string-append " "w"x"h" at "x","y)) - port))))) - (x #f) (y #f) (width #f) (height #f)) - -(define-integrable (set-rect! rect x y width height) - (set-rect-x! rect x) - (set-rect-y! rect y) - (set-rect-width! rect width) - (set-rect-height! rect height)) - -(define-integrable (set-rect-pos! rect x y) - (set-rect-x! rect x) - (set-rect-y! rect y)) - -(define-integrable (set-rect-size! rect width height) - (set-rect-width! rect width) - (set-rect-height! rect height)) - -(define-integrable (rect-nominal? rect) - ;; An integer in every slot. - (and (integer? (rect-x rect)) - (integer? (rect-y rect)) - (integer? (rect-width rect)) - (integer? (rect-height rect)))) - -;;; The rest of these procedures assume a "nominal" rectangle. - -(define-integrable (rect-max-y rect) (int:+ (rect-y rect) (rect-height rect))) -(define-integrable (rect-max-x rect) (int:+ (rect-x rect) (rect-width rect))) -(define-integrable rect-min-x rect-x) -(define-integrable rect-min-y rect-y) - -(define-integrable (call-with-rect-bounds rect receiver) - ;; Tail-calls RECEIVER with the RECT's minx, maxx, miny and maxy (in - ;; that order). Assumes RECT is nominal. - (let ((x (rect-x rect)) - (y (rect-y rect)) - (width (rect-width rect)) - (height (rect-height rect))) - (receiver x (int:+ x width) y (int:+ y height)))) - -(define-integrable (int:max integer1 integer2) - (if (int:> integer1 integer2) integer1 integer2)) -(define-integrable (int:min integer1 integer2) - (if (int:< integer1 integer2) integer1 integer2)) - -(define-integrable (point-in-rect? x y rect) - (call-with-rect-bounds rect - (lambda (min-x max-x min-y max-y) - (and (int:<= min-x x) (int:<= x max-x) - (int:<= min-y y) (int:<= y max-y))))) - -(define-integrable (rect-intersect? rect1 rect2) - ;; Useful when you do not need to cons a new rect. - (call-with-rect-bounds rect1 - (lambda (min-x1 max-x1 min-y1 max-y1) - (call-with-rect-bounds rect2 - (lambda (min-x2 max-x2 min-y2 max-y2) - (cond ((int:< max-x1 min-x2) #f) - ((int:< max-y1 min-y2) #f) - ((int:< max-x2 min-x1) #f) - ((int:< max-y2 min-y1) #f) - (else #t))))))) - -(define (rect-intersection rect1 rect2) - ;; Returns #f if RECT1 and RECT2 do not intersect, else returns a - ;; new rect -- the intersection. Assumes both rectangles are - ;; nominal. - (call-with-rect-bounds rect1 - (lambda (min-x1 max-x1 min-y1 max-y1) - (call-with-rect-bounds rect2 - (lambda (min-x2 max-x2 min-y2 max-y2) - (cond ((int:< max-x1 min-x2) #f) - ((int:< max-y1 min-y2) #f) - ((int:< max-x2 min-x1) #f) - ((int:< max-y2 min-y1) #f) - (else - (let ((min-x (int:max min-x1 min-x2)) - (min-y (int:max min-y1 min-y2)) - (max-x (int:min max-x1 max-x2)) - (max-y (int:min max-y1 max-y2))) - (make-rect min-x min-y - (int:- max-x min-x) - (int:- max-y min-y)))))))))) - -(define (window-intersection window item) - ;; Returns #f if WINDOW and ITEM do not intersect, else returns a - ;; new rect -- the intersection *translated* to WINDOW's coords. - ;; Assumes both rectangles are nominal. - (call-with-rect-bounds window - (lambda (window-x-start window-x-end window-y-start window-y-end) - (call-with-rect-bounds item - (lambda (item-x-start item-x-end item-y-start item-y-end) - (cond ((int:< window-x-end item-x-start) #f) - ((int:< window-y-end item-y-start) #f) - ((int:< item-x-end window-x-start) #f) - ((int:< item-y-end window-y-start) #f) - (else - (let ((x (int:max window-x-start item-x-start)) - (y (int:max window-y-start item-y-start)) - (x-end (int:min window-x-end item-x-end)) - (y-end (int:min window-y-end item-y-end))) - (make-rect (int:- x window-x-start) - (int:- y window-y-start) - (int:- x-end x) - (int:- y-end y)))))))))) - -(define (rect-union! rect1 rect2) - (call-with-rect-bounds rect1 - (lambda (min-x1 max-x1 min-y1 max-y1) - (call-with-rect-bounds rect2 - (lambda (min-x2 max-x2 min-y2 max-y2) - (let ((x (int:min min-x1 min-x2)) - (y (int:min min-y1 min-y2))) - (set-rect! rect1 - x y - (int:- x (int:max max-x1 max-x2)) - (int:- y (int:max max-y1 max-y2))))))))) - -(define (gdk-rectangle #!optional x y width height) - (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|))) - (if (default-object? x) alien - (begin - (C->= alien "GdkRectangle x" (check-integer x)) - (if (default-object? y) alien - (begin - (C->= alien "GdkRectangle y" (check-integer y)) - (if (default-object? width) alien - (begin - (C->= alien "GdkRectangle width" (check-integer width)) - (if (default-object? height) alien - (begin - (C->= alien "GdkRectangle height" - (check-integer height)) - alien)))))))))) - -(define (gdk-rectangle-from-rect rect) - (gdk-rectangle (rect-x rect) (rect-y rect) - (rect-width rect) (rect-height rect))) - -(define-integrable (check-integer obj) - (if (integer? obj) obj - (ferror "not an integer: "obj))) - - -;;;; Ferror - -(define condition-type:ferror - (make-condition-type - 'FORMATTED-ERROR - condition-type:error - '(ARGS) - (lambda (condition port) - (write-string ";Error: " port) - (for-each (lambda (arg) - (if (string? arg) - (write-string arg port) - (write arg port))) - (access-condition condition 'ARGS)) - (newline port)))) - -(define ferror - (let ((signal (condition-signaller condition-type:ferror '(ARGS) - standard-error-handler))) - (named-lambda (ferror . args) - (call-with-current-continuation - (lambda (continuation) - (with-restart - 'USE-VALUE ;name - "Return a value from the call to ferror." ;reporter - continuation ;effector - (lambda () ;interactor - (values (prompt-for-evaluated-expression - "Value to return from ferror"))) - (lambda () ;thunk - (signal args)))))))) - -(define condition-type:fwarn - (make-condition-type - 'FORMATTED-WARNING - condition-type:warning - '(ARGS) - (lambda (condition port) - (write-string ";Warning: " port) - (for-each (lambda (arg) - (if (string? arg) - (write-string arg port) - (write arg port))) - (access-condition condition 'ARGS)) - (newline port)))) - -(define fwarn - (let ((signal (condition-signaller condition-type:fwarn '(ARGS) - standard-warning-handler))) - (named-lambda (fwarn . args) - (with-simple-restart 'MUFFLE-WARNING "Ignore warning." - (lambda () (signal args)))))) - -;;; Pango -;;; -;;; Debugging hacks. No gc-cleanups! - -(define (pango-font-families widget) - (pango-context-list-families (gtk-widget-get-pango-context widget))) - -(define (pango-context-list-families PangoContext) - (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|)))) - (count-arg (malloc (C-sizeof "int") 'int))) - (C-call "pango_context_list_families" PangoContext data-arg count-arg) - (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFamily|)))) - (count (C-> count-arg "int"))) - (free data-arg) (free count-arg) - (let* ((scan (copy-alien data)) - (family (make-alien '|PangoFontFamily|)) - (alist - (let loop ((i 0) (entries '())) - (if (fix:< i count) - (begin - (C-> scan "*" family) - (alien-byte-increment! scan (C-sizeof "*")) - (loop (fix:1+ i) - (cons - (cons* (pango-font-family-get-name family) - (pango-font-family-is-monospace? family) - (pango-font-family-faces family)) - entries))) - entries)))) - (C-call "g_free" data) - alist)))) - -(define (pango-font-family-get-name PangoFontFamily) - (let ((name (make-alien '(const char)))) - (C-call "pango_font_family_get_name" name PangoFontFamily) - (c-peek-cstring name))) - -(define (pango-font-family-is-monospace? PangoFontFamily) - (not (fix:zero? (C-call "pango_font_family_is_monospace" PangoFontFamily)))) - -(define (pango-font-family-faces PangoFontFamily) - (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFace|)))) - (count-arg (malloc (C-sizeof "int") 'int))) - (C-call "pango_font_family_list_faces" PangoFontFamily data-arg count-arg) - (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFace|)))) - (count (C-> count-arg "int"))) - (free data-arg) (free count-arg) - (let* ((scan (copy-alien data)) - (face (make-alien '|PangoFontFace|)) - (faces - (let loop ((i 0) (faces '())) - (if (fix:< i count) - (begin - (C-> scan "*" face) - (alien-byte-increment! scan (C-sizeof "*")) - (loop (fix:1+ i) - (cons - (pango-font-face-get-name face) - faces))) - faces)))) - (C-call "g_free" data) - faces)))) - -(define (pango-font-face-get-name PangoFontFace) - (let ((name (make-alien '(const char)))) - (C-call "pango_font_face_get_face_name" name PangoFontFace) - (c-peek-cstring name))) \ No newline at end of file + numbers))) \ No newline at end of file diff --git a/src/gtk/gtk.sf b/src/gtk/gtk.sf index 33846a1b4..5fb530e22 100644 --- a/src/gtk/gtk.sf +++ b/src/gtk/gtk.sf @@ -1,25 +1,4 @@ -#| -*-Scheme-*- - -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# +#| -*-Scheme-*- |# ;;;; Syntax the GTK system @@ -28,69 +7,9 @@ USA. (load-option 'SOS) (load-option 'FFI)) -(with-working-directory-pathname (directory-pathname (current-load-pathname)) - (lambda () - (let* ((files.packages - '(("gtk" . (gtk)) - ("keys" . (gtk keys)) - ("main" . (gtk main)) - ("gobject" . (gtk gobject)) - ("gtk-object" . (gtk gtk-object)) - ("pango" . (gtk pango)) - ("scm-widget" . (gtk widget)) - ("scm-layout" . (gtk layout)) - ("thread" . (gtk thread)) - ("gtk-ev" . (gtk event-viewer)) - ("demo" . (gtk demo)))) - (sf+ - (lambda (files deps) - (let loop ((files (if (pair? files) files (list files)))) - (if (pair? files) - (let* ((file (car files)) - (file.package (assoc file files.packages)) - (package (if (pair? file.package) - (cdr file.package) - (error "No package: " file))) - (env (->environment package))) - (fluid-let ((sf/default-declarations - (cons '(usual-integrations) - sf/default-declarations))) - (sf-with-dependencies file deps env)) - (loop (cdr files))))))) - (sfx+ - (lambda (files deps) - (fluid-let ((sf/default-declarations - (append! - (map (lambda (file) - `(integrate-external - ,(pathname-new-type file #f))) - deps) - sf/default-declarations))) - (sf+ files deps))))) - - ;; Build an empty package for use at syntax-time. - ;; The C-include syntax will bind C-INCLUDES here. - (if (not (name->package '(GTK))) - (let ((package-set (package-set-pathname "gtk"))) - (if (not (file-exists? package-set)) - (cref/generate-trivial-constructor "gtk")) - (construct-packages-from-file (fasload package-set)))) - - ;; Load the gtkio primitives too. - (load-library-object-file "prgtkio" #t) - - ;; These core files depend only on the constants behind the C- - ;; syntax. - (sf+ '("gtk" "keys" "main" "gobject" "gtk-object" "pango" "scm-widget") - '("gtk-const")) - - ;; These files will want the latest rect(angle) and - ;; pango/pixel procedures for inlining. - (sfx+ '("scm-layout" "thread" "gtk-ev" "demo") - '("gtk" "pango")) +;; Load the gtkio primitives too, so SF can check their arity(?). +(load-library-object-file "prgtkio" #t) - ;; Depends only on (runtime thread). - (sf+ '("thread") '()) +(sf-package-set "gtk-new") - ;; Cross-check. - (cref/generate-constructors "gtk" 'ALL)))) \ No newline at end of file +(cref/generate-constructors "gtk" 'ALL) \ No newline at end of file diff --git a/src/gtk/hello.scm b/src/gtk/hello.scm index debba9b92..2c34bdd3b 100644 --- a/src/gtk/hello.scm +++ b/src/gtk/hello.scm @@ -13,14 +13,14 @@ This is Havoc Pennington's Hello World example from GGAD, wrapped in Scheme. |# (let ((counter 0)) (set-gtk-window-delete-event-callback! window - (lambda () + (lambda (window) (outf-console ";Bite me "(- 2 counter)" times.\n") (set! counter (1+ counter)) ;; Three or more is the charm. (if (> counter 2) 0 1))) (set-gtk-button-clicked-callback! button - (lambda () + (lambda (button) (let ((text (gtk-label-get-text label))) (gtk-label-set-text label (list->string (reverse! (string->list text))))) diff --git a/src/gtk/keys.scm b/src/gtk/keys.scm index 7189ceb96..5879430ef 100644 --- a/src/gtk/keys.scm +++ b/src/gtk/keys.scm @@ -27,19 +27,13 @@ USA. (c-include "gtk") (define (gdk-key-state->char-bits modifier-state) - ;; Given a Gdk modifier-state, returns a bitmap (sum) of - ;; char-bit:control, :meta, :super, :hyper. (fix:+ - (if (zero? (bit-and (C-enum "GDK_CONTROL_MASK") modifier-state)) - 0 char-bit:control) + (if (bit? modifier-state (C-enum "GDK_CONTROL_MASK")) char-bit:control 0) (fix:+ - (if (zero? (bit-and (C-enum "GDK_META_MASK") modifier-state)) - 0 char-bit:meta) + (if (bit? modifier-state (C-enum "GDK_META_MASK")) char-bit:meta 0) (fix:+ - (if (zero? (bit-and (C-enum "GDK_SUPER_MASK") modifier-state)) - 0 char-bit:super) - (if (zero? (bit-and (C-enum "GDK_HYPER_MASK") modifier-state)) - 0 char-bit:hyper))))) + (if (bit? modifier-state (C-enum "GDK_SUPER_MASK")) char-bit:super 0) + (if (bit? modifier-state (C-enum "GDK_HYPER_MASK")) char-bit:hyper 0))))) (define (gdk-keyval->name keyval) (let ((entry diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 59d589815..6e893112d 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -24,7 +24,6 @@ USA. ;;;; Main Loop Hack ;;; package: (gtk main) - (c-include "gtk") (define (initialize-package!) @@ -99,4 +98,6 @@ USA. (define gtk-time-slice-window? (ucode-primitive gtk-time-slice-window? 0)) (define gtk-time-slice-window! (ucode-primitive gtk-time-slice-window! 1)) (define gtk-select-trace? (ucode-primitive gtk-select-trace? 0)) -(define gtk-select-trace! (ucode-primitive gtk-select-trace! 1)) \ No newline at end of file +(define gtk-select-trace! (ucode-primitive gtk-select-trace! 1)) + +(initialize-package!) \ No newline at end of file diff --git a/src/gtk/make.scm b/src/gtk/make.scm index aadb41269..d204511c0 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -6,4 +6,4 @@ Load the Gtk option. |# (with-loader-base-uri (system-library-uri "gtk/") (lambda () (load-package-set "gtk"))) -(add-subsystem-identification! "Gtk" '(0 1)) \ No newline at end of file +(add-subsystem-identification! "Gtk" '(0 2)) \ No newline at end of file diff --git a/src/gtk/pango-cairo.scm b/src/gtk/pango-cairo.scm deleted file mode 100644 index 7a6e9b935..000000000 --- a/src/gtk/pango-cairo.scm +++ /dev/null @@ -1,59 +0,0 @@ -#| -*-Scheme-*- - -This is example 1 from section "Cairo Rendering" of the "Pango -Reference Manual for Pango 1.18.3". |# - -(define (pango-cairo #!optional filename) - - (define pi (* 4 (atan 1 1))) - (define radius 150) - (define n_words 10) - (define font "Sans Bold 27") - - (define (draw-text cr) - (let ((layout (make-alien '|PangoLayout|)) - (extent (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|)) - (desc (make-alien '|PangoFontDescription|))) - ;; Center coordinates on the middle of the region we are drawing - (C-call "cairo_translate" cr radius radius) - ;; Create a PangoLayout, set the font and text - (C-call "pango_cairo_create_layout" layout cr) - (C-call "pango_layout_set_text" layout "Text" 4) - (C-call "pango_font_description_from_string" desc font) - (C-call "pango_layout_set_font_description" layout desc) - (C-call "pango_font_description_free" desc) - ;; Draw the layout N_WORDS times in a circle - (do ((i 0 (1+ i))) - ((fix:= i n_words)) - (C-call "cairo_save" cr) - (let* ((angle (* 360. (/ i n_words))) - ;; Gradient from red at angle == 60 to blue at angle == 240 - (red (/ (+ 1. (cos (* (- angle 60.) (/ pi 180.)))) 2.))) - (C-call "cairo_set_source_rgb" cr red 0 (- 1. red)) - (C-call "cairo_rotate" cr (* angle (/ pi 180.))) - ;; Inform Pango to re-layout the text with the new transformation - (C-call "pango_cairo_update_layout" cr layout) - (C-call "pango_layout_get_pixel_extents" layout 0 extent) - (C-call "cairo_move_to" cr - (- (/ (C-> extent "PangoRectangle width") 2)) - (- radius)) - (C-call "pango_cairo_show_layout" cr layout) - (C-call "cairo_restore" cr))) - (C-call "g_object_unref" layout) - (free extent))) - - (let ((surface (make-alien '|cairo_surface_t|)) - (cr (make-alien '|cairo_t|)) - (filename (if (default-object? filename) "pango-cairo.png" filename))) - (C-call "cairo_image_surface_create" surface - (C-enum "CAIRO_FORMAT_ARGB32") - (* 2 radius) (* 2 radius)) - (C-call "cairo_create" cr surface) - (C-call "cairo_set_source_rgb" cr 1.0 1.0 1.0) - (C-call "cairo_paint" cr) - (draw-text cr) - (C-call "cairo_destroy" cr) - (let ((status (C-call "cairo_surface_write_to_png" surface filename))) - (C-call "cairo_surface_destroy" surface) - (if (not (= status (C-enum "CAIRO_STATUS_SUCCESS"))) - (ferror "Could not save png to '"filename"'."))))) \ No newline at end of file diff --git a/src/gtk/pango.scm b/src/gtk/pango.scm index 9537b0428..50e18131d 100644 --- a/src/gtk/pango.scm +++ b/src/gtk/pango.scm @@ -24,49 +24,60 @@ USA. ;;;; Pango interface. ;;; package: (gtk pango) - (c-include "gtk") - -;;; PangoLayout (define-class ( (constructor ())) ()) +(define-guarantee pango-layout "a ") + (define-method initialize-instance ((pango-layout )) (call-next-method pango-layout) (set-alien/ctype! (gobject-alien pango-layout) '|PangoLayout|)) (define (pango-layout-get-context layout) + (guarantee-pango-layout layout 'pango-layout-get-context) (C-call "pango_layout_get_context" (make-alien '|PangoContext|) (gobject-alien layout))) +(define (pango-layout-context-changed layout) + (guarantee-pango-layout layout 'pango-layout-context-changed) + (C-call "pango_layout_context_changed" (gobject-alien layout))) + (define (pango-layout-get-font-description layout) + (guarantee-pango-layout layout 'pango-layout-get-font-description) (C-call "pango_layout_get_font_description" (make-alien '|PangoFontDescription|) (gobject-alien layout))) +(define (pango-layout-set-font-description layout font) + ;; The toolkit makes a copy of FONT. + (guarantee-pango-font-description font 'pango-layout-set-font-description) + (C-call "pango_layout_set_font_description" + (gobject-alien layout) (if (not font) 0 font))) + (define (pango-layout-set-text layout text) - (let ((l (check-pango-layout layout)) - (s (check-string text))) - (C-call "pango_layout_set_text" (gobject-alien l) s (string-length s)))) + (guarantee-pango-layout layout 'pango-layout-set-text) + (guarantee-string text 'pango-layout-set-text) + (C-call "pango_layout_set_text" (gobject-alien layout) + text (string-length text))) (define (pango-layout-get-pixel-extents layout receiver) - ;; Calls RECEIVER with the logical(?) dimensions (width and height) - ;; of the laid-out text. - - (let ((log-extent (pango-rectangle)) - (ink-extent null-alien)) + (guarantee-pango-layout layout 'pango-layout-set-text) + (guarantee-procedure-of-arity receiver 2 'pango-layout-set-text) + (let ((ink-extent (pango-rectangle)) + (logical-extent (pango-rectangle))) (C-call "pango_layout_get_pixel_extents" - (gobject-alien layout) ink-extent log-extent) - (let ((width (C-> log-extent "GdkRectangle width")) - (height (C-> log-extent "GdkRectangle height"))) - (free log-extent) + (gobject-alien layout) ink-extent logical-extent) + ;; Can ink extend beyond the logical extent? + (let ((width (C-> logical-extent "GdkRectangle width")) + (height (C-> logical-extent "GdkRectangle height"))) + (free ink-extent) + (free logical-extent) (receiver width height)))) (define (pango-layout-index-to-pos layout index receiver) - ;; Calls RECEIVER with the x, y, width and height of the grapheme at - ;; INDEX in LAYOUT. (let ((rect (pango-rectangle))) (C-call "pango_layout_index_to_pos" (gobject-alien layout) index rect) (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) @@ -75,100 +86,96 @@ USA. (height (pangos->pixels (C-> rect "PangoRectangle height")))) (free rect) (receiver x y width height)))) - -(define-integrable (check-pango-layout object) - (if (pango-layout? object) - object - (error:wrong-type-argument object "" 'check-pango-layout))) ;;; PangoFontDescription (define (pango-font-description-from-string string) - (let ((str (check-string string))) - (let ((font (make-alien '|PangoFontDescription|)) - (copy (make-alien '|PangoFontDescription|))) - (add-gc-cleanup font (pango-font-description-cleanup copy)) - (C-call "pango_font_description_from_string" copy str) - (copy-alien-address! font copy) - font))) + ;; The returned PangoFontDescription is owned by Scheme. + (guarantee-string string 'pango-font-description-from-string) + (let ((font (make-alien '|PangoFontDescription|)) + (copy (make-alien '|PangoFontDescription|))) + (add-gc-cleanup font (pango-font-description-cleanup copy)) + (C-call "pango_font_description_from_string" copy string) + (if (alien-null? copy) + (begin + (punt-gc-cleanup font) + #f) + (begin + (copy-alien-address! font copy) + font)))) (define (pango-font-description-cleanup alien) (lambda () - ;;without-interrupts - (if (not (alien-null? alien)) - (begin - (C-call "pango_font_description_free" alien) - (alien-null! alien))))) - -(define (pango-font-description-free font) - (let ((alien (check-PangoFontDescription font))) (without-interrupts (lambda () (if (not (alien-null? alien)) - (let ((cleanup (punt-gc-cleanup alien))) - (if cleanup (cleanup)) + (begin + (C-call "pango_font_description_free" alien) (alien-null! alien))))))) -(define (pango-font-description-to-string PangoFontDescription) - (let ((font (check-PangoFontDescription PangoFontDescription))) - (if (alien-null? font) - "" - (let ((cstr (make-alien '|char|))) - (C-call "pango_font_description_to_string" cstr font) - (let ((str (c-peek-cstring cstr))) - (C-call "g_free" cstr) - str))))) - -(define (check-PangoFontDescription object) - (if (and (alien? object) (eq? '|PangoFontDescription| (alien/ctype object))) - object - (check-PangoFontDescription - (error:wrong-type-argument - object "PangoFontDescription's (alien) address" - 'check-PangoFontDescription)))) - -(define (check-string object) - (if (string? object) object - (error:wrong-type-argument object "a string" 'check-string))) +(define (pango-font-description-free font) + (guarantee-pango-font-description font 'pango-font-description-free) + (without-interrupts + (lambda () + (if (not (alien-null? font)) + (let ((cleanup (punt-gc-cleanup font))) + (if cleanup (cleanup)) + (alien-null! font)))))) + +(define (pango-font-description-to-string font) + (guarantee-pango-font-description font 'pango-font-description-to-string) + (if (alien-null? font) + "" + (let ((cstr (make-alien '|char|))) + (C-call "pango_font_description_to_string" cstr font) + (let ((str (c-peek-cstring cstr))) + (C-call "g_free" cstr) + str)))) + +(define-integrable (guarantee-pango-font-description object operator) + (if (not (and (alien? object) + (eq? '|PangoFontDescription| (alien/ctype object)))) + (error:wrong-type-argument + object "a PangoFontDescription address" operator))) ;;; PangoContext (define (pango-context-get-font-description context) - ;; Owned by the PangoContext, not Scheme. + ;; The returned PangoFontDescription is owned by the toolkit + ;; (the PangoContext), not Scheme. + (guarantee-pango-context context 'pango-context-get-font-description) (C-call "pango_context_get_font_description" - (make-alien '|PangoFontDescription|) - (check-PangoContext context))) + (make-alien '|PangoFontDescription|) context)) (define (pango-context-set-font-description context font) - (C-call "pango_context_set_font_description" - (check-PangoContext context) - (check-PangoFontDescription font))) + ;; FONT is still owned by Scheme. The toolkit makes a copy. + (guarantee-pango-context context 'pango-context-set-font-description) + (guarantee-pango-font-description font 'pango-context-set-font-description) + (C-call "pango_context_set_font_description" context font)) (define (pango-context-get-metrics context font) - ;; Owned by Scheme. - (let ((context (check-PangoContext context)) - (font (check-PangoFontDescription font))) - (let ((alien (make-alien '|PangoFontMetrics|)) - (copy (make-alien '|PangoFontMetrics|))) - (add-gc-cleanup alien (pango-font-metrics-cleanup copy)) - (C-call "pango_context_get_metrics" copy context font 0) - (copy-alien-address! alien copy) - alien))) + ;; The new PangoFontMetrics is owned by Scheme. + (guarantee-pango-context context 'pango-context-get-metrics) + (guarantee-pango-font-description font 'pango-context-get-metrics) + (let ((alien (make-alien '|PangoFontMetrics|)) + (copy (make-alien '|PangoFontMetrics|))) + (add-gc-cleanup alien (pango-font-metrics-cleanup copy)) + (C-call "pango_context_get_metrics" copy context font 0) + (copy-alien-address! alien copy) + alien)) (define (pango-context-spacing context) + (guarantee-pango-context context 'pango-context-spacing) (let ((layout (make-alien '|PangoLayout|))) - (C-call "pango_layout_new" layout (check-PangoContext context)) + (C-call "pango_layout_new" layout context) (let ((spacing (C-call "pango_layout_get_spacing" layout))) (C-call "g_object_unref" layout) spacing))) -(define (check-PangoContext object) - (if (and (alien? object) (eq? '|PangoContext| (alien/ctype object))) - object - (check-PangoContext - (error:wrong-type-argument - object "the (alien) address of a PangoContext" - 'check-PangoContext)))) +(define-integrable (guarantee-pango-context object operator) + (if (not (and (alien? object) (eq? '|PangoContext| (alien/ctype object)))) + (error:wrong-type-argument + object "a PangoContext address" operator))) ;;; PangoFontMetrics @@ -181,31 +188,34 @@ USA. (alien-null! alien))))) (define (pango-font-metrics-unref metrics) - (let ((alien (check-PangoFontMetrics metrics))) - (without-interrupts - (lambda () - (if (not (alien-null? alien)) - (let ((cleanup (punt-gc-cleanup alien))) - (if cleanup (cleanup)) - (alien-null! alien))))))) + (guarantee-pango-font-metrics metrics 'pango-font-metrics-unref) + (without-interrupts + (lambda () + (if (not (alien-null? metrics)) + (let ((cleanup (punt-gc-cleanup metrics))) + (if cleanup (cleanup)) + (alien-null! metrics)))))) (define (pango-font-metrics-get-ascent metrics) - (C-call "pango_font_metrics_get_ascent" (check-PangoFontMetrics metrics))) + (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-ascent) + (C-call "pango_font_metrics_get_ascent" metrics)) (define (pango-font-metrics-get-descent metrics) - (C-call "pango_font_metrics_get_descent" (check-PangoFontMetrics metrics))) + (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-descent) + (C-call "pango_font_metrics_get_descent" metrics)) (define (pango-font-metrics-get-approximate-char-width metrics) - (C-call "pango_font_metrics_get_approximate_char_width" - (check-PangoFontMetrics metrics))) - -(define (check-PangoFontMetrics object) - (if (and (alien? object) (eq? '|PangoFontMetrics| (alien/ctype object))) - object - (check-PangoFontMetrics - (error:wrong-type-argument - object "the (alien) address of PangoFontMetrics" - 'check-PangoFontMetrics)))) + (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-approximate-char-width) + (C-call "pango_font_metrics_get_approximate_char_width" metrics)) + +(define-integrable (guarantee-live-pango-font-metrics object operator) + (guarantee-pango-font-metrics object operator) + (if (alien-null? object) (error "Dead:" object))) + +(define-integrable (guarantee-pango-font-metrics object operator) + (if (not (and (alien? object) (eq? '|PangoFontMetrics| (alien/ctype object)))) + (error:wrong-type-argument + object "a PangoFontMetrics address" operator))) ;;; PangoRectangle @@ -223,4 +233,70 @@ USA. (quotient (int:+ pango-units 512) 1024)) (define-integrable (pixels->pangos pixel-units) - (* pixel-units 1024)) \ No newline at end of file + (* pixel-units 1024)) + +;;; Debugging hacks. No gc-cleanups! + +(define (pango-font-families widget) + (pango-context-list-families (gtk-widget-get-pango-context widget))) + +(define (pango-context-list-families PangoContext) + (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|)))) + (count-arg (malloc (C-sizeof "int") 'int))) + (C-call "pango_context_list_families" PangoContext data-arg count-arg) + (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFamily|)))) + (count (C-> count-arg "int"))) + (free data-arg) (free count-arg) + (let* ((scan (copy-alien data)) + (family (make-alien '|PangoFontFamily|)) + (alist + (let loop ((i 0) (entries '())) + (if (fix:< i count) + (begin + (C-> scan "*" family) + (alien-byte-increment! scan (C-sizeof "*")) + (loop (fix:1+ i) + (cons + (cons* (pango-font-family-get-name family) + (pango-font-family-is-monospace? family) + (pango-font-family-faces family)) + entries))) + entries)))) + (C-call "g_free" data) + alist)))) + +(define (pango-font-family-get-name PangoFontFamily) + (let ((name (make-alien '(const char)))) + (C-call "pango_font_family_get_name" name PangoFontFamily) + (c-peek-cstring name))) + +(define (pango-font-family-is-monospace? PangoFontFamily) + (not (fix:zero? (C-call "pango_font_family_is_monospace" PangoFontFamily)))) + +(define (pango-font-family-faces PangoFontFamily) + (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFace|)))) + (count-arg (malloc (C-sizeof "int") 'int))) + (C-call "pango_font_family_list_faces" PangoFontFamily data-arg count-arg) + (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFace|)))) + (count (C-> count-arg "int"))) + (free data-arg) (free count-arg) + (let* ((scan (copy-alien data)) + (face (make-alien '|PangoFontFace|)) + (faces + (let loop ((i 0) (faces '())) + (if (fix:< i count) + (begin + (C-> scan "*" face) + (alien-byte-increment! scan (C-sizeof "*")) + (loop (fix:1+ i) + (cons + (pango-font-face-get-name face) + faces))) + faces)))) + (C-call "g_free" data) + faces)))) + +(define (pango-font-face-get-name PangoFontFace) + (let ((name (make-alien '(const char)))) + (C-call "pango_font_face_get_face_name" name PangoFontFace) + (c-peek-cstring name))) \ No newline at end of file diff --git a/src/gtk/scm-layout.scm b/src/gtk/scm-layout.scm deleted file mode 100644 index 36edc555b..000000000 --- a/src/gtk/scm-layout.scm +++ /dev/null @@ -1,1062 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; A implementing a scrollable GtkDrawingArea-like widget. -;;; package: (gtk layout) - - -(c-include "gtk") - -(define-class ( (constructor make-scm-layout ())) - () - - ;; Our window, a GdkWindow alien. Until realized, this will be NULL. - (window define accessor - initializer (lambda () (make-alien '|GdkWindow|))) - - ;; Our window geometry (allocation) -- a rectangular area in device - ;; coordinates (e.g. size in pixels, offset within parent window - ;; [ancestor widget]). - (geometry define accessor initializer make-rect) - - ;; Scrollbar widgets. - (vadjustment define standard initial-value #f) - (hadjustment define standard initial-value #f) - (scroll-step define accessor initializer (lambda () (cons 10 20))) - - ;; Scrollable area (drawing size), in logical device coords. - (scrollable-area define accessor - initializer (lambda () (make-rect 0 0 100 100))) - - ;; Scroll offset (and window size) in logical device coordinates. - ;; (The size should match the window geometry.) - (on-screen-area define accessor - initializer (lambda () (make-rect 0 0))) - - (drawing define standard - modifier %set-scm-layout-drawing! - initial-value #f) - - (event-handlers define accessor initializer - (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) - -(define (scm-layout-new width height) - (let ((w (check-non-negative-integer width)) - (h (check-non-negative-integer height)) - (layout (make-scm-layout))) - (let ((alien (gobject-alien layout))) - (C->= alien "GtkWidget requisition width" w) - (C->= alien "GtkWidget requisition height" h)) - (set-scm-widget-size-request! layout (scm-layout-size-request layout)) - (set-scm-widget-size-allocate! layout (scm-layout-size-allocate layout)) - (set-scm-widget-realize! layout (scm-layout-realize layout)) - (set-scm-widget-event! layout (scm-layout-event-handler layout)) - (set-scm-widget-set-scroll-adjustments! - layout (scm-layout-set-scroll-adjustments layout)) - layout)) - -(define-integrable (scm-layout-realized? layout) - (not (alien-null? (scm-layout-window layout)))) - -(define (set-scm-layout-size! widget width height) - ;; Tells WIDGET to (re)request the given WIDTH and HEIGHT in pixels. - (let ((w (check-non-negative-integer width)) - (h (check-non-negative-integer height)) - (alien (check-scm-layout-alien widget))) - (let ((rw (C-> alien "GtkWidget requisition width")) - (rh (C-> alien "GtkWidget requisition height"))) - (if (not (and (fix:= w rw) (fix:= h rh))) - (begin - (if (not (fix:= w rw)) - (C->= alien "GtkWidget requisition width" w)) - (if (not (fix:= h rh)) - (C->= alien "GtkWidget requisition height" h)) - (if (scm-layout-realized? widget) - (C-call "gtk_widget_queue_resize" alien))))))) - -(define (set-scm-layout-scroll-size! widget width height) - ;; Tells WIDGET to adjust its scrollable area. Notifies any - ;; scrollbars. - (let ((w (check-positive-integer width)) - (h (check-positive-integer height)) - (area (scm-layout-scrollable-area widget))) - (if (not (and (int:= w (rect-width area)) - (int:= h (rect-height area)))) - (begin - (set-rect-size! area w h) - (if (scm-layout-realized? widget) - (adjust-adjustments widget)))))) - -(define (set-scm-layout-scroll-pos! widget x y) - (let ((x1 (check-integer x)) - (y1 (check-integer y))) - (scroll widget x1 y1))) - -(define (scroll widget new-x new-y) - ;; Scroll if more than 25% will remain in the window, else jump. - (if (scm-layout-realized? widget) - (let ((scroll (scm-layout-on-screen-area widget))) - (let ((old-x (rect-x scroll)) - (old-y (rect-y scroll))) - (let ((dx (int:- new-x old-x)) - (dy (int:- new-y old-y))) - (if (not (and (int:zero? dx) (int:zero? dy))) - (let ((width (rect-width scroll)) - (height (rect-height scroll)) - (gdkwindow (scm-layout-window widget))) - (let ((remaining-width (int:- width (int:abs dy))) - (remaining-height (int:- height (int:abs dx)))) - (if (or (int:negative? remaining-width) - (int:negative? remaining-height) - (< 0.25 (/ (int:* remaining-width remaining-height) - (int:* width height)))) - (C-call "gdk_window_scroll" - gdkwindow (int:negate dx) (int:negate dy)) - (C-call "gtk_widget_queue_draw" - (gobject-alien widget))) - (set-rect-pos! scroll new-x new-y) - (adjust-adjustments widget)) - (C-call "gdk_window_process_updates" gdkwindow 0)))))))) - -(define-integrable (int:abs i) - (if (int:negative? i) (int:negate i) i)) - -(define (set-scm-layout-scroll-step! widget width height) - ;; Tells WIDGET to use WIDTH/HEIGHT as its "step-increment" when - ;; setting up h/vscrollbars. - (let ((w (check-positive-integer width)) - (h (check-positive-integer height))) - (let ((width.height (scm-layout-scroll-step widget))) - (set-car! width.height w) - (set-cdr! width.height h))) - (if (scm-layout-realized? widget) - (adjust-adjustments widget))) - -(define (set-scm-layout-drawing! widget drawing) - (let ((old (scm-layout-drawing widget)) - (new (check-drawing drawing)) - (alien (check-scm-layout-alien widget))) - (if old (drawing-remove-widget! old widget)) - (%set-scm-layout-drawing! widget new) - (drawing-add-widget! new widget) - (let ((a (drawing-area new))) - (set-rect! (scm-layout-scrollable-area widget) - (rect-x a) (rect-y a) (rect-width a) (rect-height a)) - (if (scm-layout-realized? widget) - (begin - (adjust-adjustments widget) - (C-call "gtk_widget_queue_draw" alien)))))) - -(define-integrable (check-scm-layout-alien obj) - (if (scm-layout? obj) (gobject-alien obj) - (error:wrong-type-argument obj "" 'check-scm-layout-alien))) - - -;;;; Callback handlers. - -(define (scm-layout-size-request widget) - (named-lambda (scm-layout::size-request GtkWidget GtkRequisition) - (trace2 ";((scm-layout-size-request "widget") "GtkWidget - " "GtkRequisition")\n") - - (let ((alien (gobject-alien widget))) - (let ((width (C-> alien "GtkWidget requisition width")) - (height(C-> alien "GtkWidget requisition height"))) - (C->= GtkRequisition "GtkRequisition width" width) - (C->= GtkRequisition "GtkRequisition height" height) - (trace "; Requisition: "width"x"height" from "widget"\n") - )))) - -(define (scm-layout-size-allocate widget) - (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation) - (trace2 ";((scm-layout-size-allocate "widget") "GtkWidget - " "GtkAllocation")\n") - - (let ((x (C-> GtkAllocation "GtkAllocation x")) - (y (C-> GtkAllocation "GtkAllocation y")) - (width (C-> GtkAllocation "GtkAllocation width")) - (height (C-> GtkAllocation "GtkAllocation height")) - (rect (scm-layout-geometry widget))) - (set-rect! rect x y width height) - (trace "; Allocation: "rect" to "widget"\n") - (set-rect-size! (scm-layout-on-screen-area widget) width height) - ;; For the random toolkit GtkWidget method. - (C->= GtkWidget "GtkWidget allocation x" x) - (C->= GtkWidget "GtkWidget allocation y" y) - (C->= GtkWidget "GtkWidget allocation width" width) - (C->= GtkWidget "GtkWidget allocation height" height) - (if (scm-layout-realized? widget) - (begin - (C-call "gdk_window_move_resize" (scm-layout-window widget) - x y width height) - (adjust-adjustments widget)))))) - -(define (scm-layout-realize widget) - (named-lambda (scm-layout::realize GtkWidget) - (trace2 ";((scm-layout-realize "widget") "GtkWidget")\n") - - ;; ScmWidget automatically sets GTK_REALIZED. - - (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) - (main-GdkWindow (scm-layout-window widget)) - (parent-GdkWindow (make-alien '|GdkWindow|)) -; (GdkVisual (make-alien '|GdkVisual|)) -; (GdkColormap (make-alien '|GdkColormap|)) - (check-!null (lambda (alien message) - (if (alien-null? alien) - (ferror "scm-layout: "message) - alien)))) - - ;; Create widget window. - -; (C-call "gtk_widget_get_visual" GdkVisual GtkWidget) -; (check-!null GdkVisual "Could not get GdkVisual.") -; (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) -; (check-!null GdkColormap "Could not get GdkColormap.") - - (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) - (let ((r (scm-layout-geometry widget))) - (C->= attr "GdkWindowAttr x" (rect-x r)) - (C->= attr "GdkWindowAttr y" (rect-y r)) - (C->= attr "GdkWindowAttr width" (rect-width r)) - (C->= attr "GdkWindowAttr height" (rect-height r))) - (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) -; (C->= attr "GdkWindowAttr visual" GdkVisual) -; (C->= attr "GdkWindowAttr colormap" GdkColormap) - (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) - - (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) - (check-!null parent-GdkWindow "Could not get parent.") - - (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr - (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") -; (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") - )) - (check-!null main-GdkWindow "Could not create main window.") - (C->= GtkWidget "GtkWidget window" main-GdkWindow) - (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) - (trace "; Realize "widget" on "main-GdkWindow"\n") - - ;; Style - - (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) - (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) - (C->= GtkWidget "GtkWidget style" GtkStyle) - (C-call "gdk_window_set_background" - main-GdkWindow - (C-array-loc (C-> GtkStyle "GtkStyle base" ) - "GdkColor" (C-enum "GTK_STATE_NORMAL")))) - - (adjust-adjustments widget) - unspecific))) - -(define (scm-layout-set-scroll-adjustments widget) - (named-lambda (scm-layout::set-scroll-adjustments - GtkWidget hGtkAdjustment vGtkAdjustment) - (trace2 ";((scm-layout-set-scroll-adjustments "widget")" - " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") - - (let ((haddr (alien/address-string hGtkAdjustment)) - (vaddr (alien/address-string vGtkAdjustment))) - (trace "; Adjustments: 0x"haddr" 0x"vaddr"\n")) - (connect-adjustment (scm-layout-hadjustment widget) hGtkAdjustment - widget set-scm-layout-hadjustment!) - (connect-adjustment (scm-layout-vadjustment widget) vGtkAdjustment - widget set-scm-layout-vadjustment!) - (if (scm-layout-realized? widget) - (adjust-adjustments widget)) - 0 ;; What does this mean? - )) - -(define (connect-adjustment old-adjustment new-alien widget setter) - ;; Disconnects OLD-ADJUSTMENT (if any) and applies SETTER to WIDGET - ;; and the new adjustment (if any). - - (let ((old-alien (and old-adjustment (gobject-alien old-adjustment)))) - ;; Disconnect. - (cond ((not old-adjustment)) - ((alien=? new-alien old-alien)) - (else - (gobject-unref old-adjustment))) - ;; Connect. - (cond ((alien-null? new-alien)) - ((and old-adjustment (alien=? new-alien old-alien))) - (else - (let ((new-adjustment (make-gtk-adjustment))) - (copy-alien-address! (gobject-alien new-adjustment) new-alien) - (C-call "g_object_ref_sink" new-alien new-alien) - (setter widget new-adjustment) - (g-signal-connect - new-adjustment (C-callback "value_changed") - (scm-layout-adjustment-value-changed widget new-adjustment))))))) - -(define (scm-layout-adjustment-value-changed widget adjustment) - (named-lambda (scm-layout::adjustment-value-changed GtkAdjustment) - (trace2 ";((scm-layout-adjustment-value-changed "widget" "adjustment")" - " "GtkAdjustment")\n") - - (let ((window-area (scm-layout-on-screen-area widget)) - (vadjustment (scm-layout-vadjustment widget)) - (hadjustment (scm-layout-hadjustment widget)) - (value (floor->exact - (C-> (gobject-alien adjustment) "GtkAdjustment value")))) - (cond ((eq? adjustment vadjustment) - (trace "; Vadjustment to "value"\n") - (scroll widget (rect-x window-area) value)) - ((eq? adjustment hadjustment) - (trace "; Hadjustment to "value"\n") - (scroll widget value (rect-y window-area))) - (else (fwarn "Unexpected adjustment "adjustment - " (not "vadjustment" nor "hadjustment").")))))) - -(define (adjust-adjustments widget) - ;; Called after the widget gets new adjustment(s) or its size or - ;; scrollable area changes. - - (let ((vadj (scm-layout-vadjustment widget))) - (if (and vadj (not (gobject-finalized? vadj))) - (let* ((window (scm-layout-on-screen-area widget)) - (window-height (rect-height window)) - (area (scm-layout-scrollable-area widget)) - (top (rect-y area)) ;most neg. - (bottom (int:+ top ;most pos. - (max (rect-height area) window-height))) - (value (rect-y window)) - (page-size window-height) - (step-incr (cdr (scm-layout-scroll-step widget))) - (page-incr (min page-size (- page-size step-incr)))) - (set-gtk-adjustment! vadj value top bottom - page-size step-incr page-incr)))) - - (let ((hadj (scm-layout-hadjustment widget))) - (if (and hadj (not (gobject-finalized? hadj))) - (let* ((window (scm-layout-on-screen-area widget)) - (window-width (rect-width window)) - (area (scm-layout-scrollable-area widget)) - (left (rect-x area)) ;most neg. - (right (int:+ left ;most pos. - (max (rect-width area) window-width))) - (value (rect-x window)) - (page-size window-width) - (step-incr (car (scm-layout-scroll-step widget))) - (page-incr (min page-size (- page-size step-incr)))) - (set-gtk-adjustment! hadj value left right - page-size step-incr page-incr))))) - - -;;;; Event Handlers - -(define (scm-layout-event-handler layout) - (named-lambda (scm-layout-handle-event GtkWidget GdkEvent) - (trace2 ";((scm-layout-handle-event "layout") "GtkWidget" "GdkEvent")\n") - - (let ((type (C-> GdkEvent "GdkEvent any type"))) - (if (int:= type (C-enum "GDK_EXPOSE")) - (let ((window (C-> GdkEvent "GdkEvent any window")) - (x (C-> GdkEvent "GdkEventExpose area x")) - (y (C-> GdkEvent "GdkEventExpose area y")) - (width (C-> GdkEvent "GdkEventExpose area width")) - (height (C-> GdkEvent "GdkEventExpose area height")) - ;;(count (C-> GdkEvent "GdkEventExpose count")) - (drawing (scm-layout-drawing layout)) - (widget-window (scm-layout-window layout))) - (cond ((not (alien=? window widget-window)) - (trace "; Expose a strange window "window - " (not "widget-window").\n")) - (drawing - (let* ((scroll (scm-layout-on-screen-area layout)) - (offx (rect-x scroll)) - (offy (rect-y scroll))) - (trace "; Expose area "width"x"height"+"x"+"y - " of "layout".\n") - (drawing-expose drawing layout window - (make-rect (int:+ x offx) (int:+ y offy) - width height))))) - 1 ;;TRUE -- "handled" -- done. - ) - (let ((handler (vector-ref (scm-layout-event-handlers layout) type))) - (if handler - (handler GtkWidget GdkEvent) - ;; Unhandled - 0)))))) - -(define (set-scm-layout-map-handler! layout handler) - (let ((handler (check-procedure-arity handler 1))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_MAP") - (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent) - GtkWidget GdkEvent ;ignore - (handler layout))))) - -(define (set-scm-layout-unmap-handler! layout handler) - (let ((handler (check-procedure-arity handler 1))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_UNMAP") - (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent) - GtkWidget GdkEvent ;ignore - (handler layout))))) - -(define (set-scm-layout-focus-change-handler! layout handler) - (let ((handler (check-procedure-arity handler 2))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_FOCUS_CHANGE") - (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent) - GtkWidget ;ignore - (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in"))))) - (handler layout in?)))))) - -(define (set-scm-layout-visibility-notify-handler! layout handler) - (let ((handler (check-procedure-arity handler 2))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_VISIBILITY_NOTIFY") - (named-lambda (scm-layout-visibility-notify-handler GtkWidget GdkEvent) - GtkWidget ;ignore - (let ((state (C-> GdkEvent "GdkEventVisibility state"))) - (handler - layout - (cond - ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE) - ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED) - ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED) - (else (C-enum "GdkVisibilityState" state))))))))) - -(define (set-scm-layout-key-press-handler! layout handler) - (let ((handler (check-procedure-arity handler 3))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_KEY_PRESS") - (named-lambda (scm-layout-key-press-handler GtkWidget GdkEvent) - GtkWidget ;ignore - (let ((alien (C-> GdkEvent "GdkEvent key string")) - (length (C-> GdkEvent "GdkEvent key length")) - (state (C-> GdkEvent "GdkEvent key state")) - (keyval (C-> GdkEvent "GdkEvent key keyval"))) - (let ((string (c-peek-cstring alien)) - (char-bits (gdk-key-state->char-bits state))) - (if (zero? (string-length string)) - (cond ((int:= length 1) - (handler layout #\NUL char-bits)) - ((int:= length 0) - (handler layout (gdk-keyval->name keyval) char-bits)) - (else (error "Unexpected length in GdkEventKey."))) - (let ((l (string-length string))) - (let loop ((i 0)) - (if (int:< i l) - (if (zero? (handler layout - (string-ref string i) char-bits)) - 0 ;;NOT handled. - (loop (int:1+ i))) - 1 ;;Handled. - )))))))))) - -(define (set-scm-layout-motion-handler! layout handler) - (let ((handler (check-procedure-arity handler 3))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_MOTION_NOTIFY") - (named-lambda (scm-layout-motion-handler GtkWidget GdkEvent) - GtkWidget ;ignore - (let ((handled? - (handler layout - (floor->exact (C-> GdkEvent "GdkEventMotion x")) - (floor->exact (C-> GdkEvent "GdkEventMotion y"))))) - (C-call "gdk_window_get_pointer" #f - (C-> GdkEvent "GdkEventMotion window") 0 0 0) - handled?))))) - -(define (set-scm-layout-button-release-handler! layout handler) - (let ((handler (check-procedure-arity handler 3))) - (vector-set! - (scm-layout-event-handlers layout) (C-enum "GDK_BUTTON_RELEASE") - (named-lambda (scm-layout-button-release-handler GtkWidget GdkEvent) - GtkWidget ;ignore - (let ((x (floor->exact (C-> GdkEvent "GdkEventButton x"))) - (y (floor->exact (C-> GdkEvent "GdkEventButton y")))) - (handler layout x y)))))) - -(define-integrable (check-procedure-arity object arity) - (cond ((not (procedure? object)) - (error:wrong-type-argument object "procedure" 'check-procedure-arity)) - ((not (procedure-arity-valid? object arity)) - (error:bad-range-argument object 'check-procedure-arity)) - (else object))) - - -;;;; Drawings - -(define-class ( (constructor () 1)) - () - (area define accessor initializer (lambda () (make-rect 0 0 0 0))) - (widgets define standard initial-value '()) - (display-list define standard initial-value '())) - -(define-method initialize-instance ((d ) widget) - (set-drawing-widgets! d (list widget))) - -(define (check-drawing obj) - (if (drawing? obj) obj - (ferror "Not a instance: "obj))) - -(define (drawing-damage item #!optional rect) - ;; Invalidates any widget areas affected by RECT in ITEM. By - ;; default, RECT is ITEM's entire area. - (trace2 ";(drawing-damage "item")\n") - - (let ((area (if (default-object? rect) - (drawn-item-area item) - rect)) - (drawing (drawn-item-drawing item))) - (if (not (rect-nominal? area)) - (ferror "Cannot damage an item ("item") with an ill-defined area.")) - (if (and (not (int:zero? (rect-width area))) - (not (int:zero? (rect-height area)))) - (for-each - (lambda (widget) - (let ((intersect (let ((a (scm-layout-on-screen-area widget))) - (and (rect-nominal? a) - (window-intersection a area))))) - (if (and intersect (not (gtk-object-destroyed? widget))) - (C-call "gtk_widget_queue_draw_area" - (gobject-alien widget) - (rect-x intersect) (rect-y intersect) - (rect-width intersect) (rect-height intersect))))) - (let ((widgets (drawn-item-widgets item))) - (if (eq? #f widgets) - (drawing-widgets drawing) - widgets)))))) - -(define-integrable (drawing-pick-list drawing widget x y) - ;; Return a list of s in DRAWING that are tangible in - ;; WIDGET at (X,Y). - - (keep-matching-items (drawing-display-list drawing) - (lambda (item) - (let ((widgets (drawn-item-widgets item)) - (area (drawn-item-area item))) - (and (or (eq? widgets #f) - (memq widget widgets)) - (point-in-rect? x y area)))))) - -(define (drawing-expose drawing widget window area) - ;; AREA is in drawing coords. - - (if (rect-nominal? area) - (for-each - (lambda (item) - (let ((item-area (drawn-item-area item)) - (widgets (drawn-item-widgets item))) - (if (and (or (eq? widgets #f) - (memq widget widgets)) - (rect-nominal? item-area) - (rect-intersect? item-area area)) - (drawn-item-expose item widget window area)))) - (drawing-display-list drawing)))) - -(define-generic drawn-item-expose (item widget window expose-area) - ;; Due to the checks in drawing-expose, methods of this generic can - ;; assume expose-area and the drawn item's area are well-defined (all - ;; four members are integers), intersecting, and ITEM is visible in - ;; WIDGET. Methods may also assume the widget is realized and its - ;; window's (gc's) clipping is already set. The widget's scroll - ;; offset (on-screen area) is also always well-defined. - ) - -(define (drawing-add-widget! drawing widget) - (if (not (scm-layout? widget)) - (ferror "Not a : "widget)) - (let ((widgets (drawing-widgets drawing))) - (if (not (memq widget widgets)) - (set-drawing-widgets! drawing (cons widget widgets))))) - -(define (drawing-remove-widget! drawing widget) - (if (not (scm-layout? widget)) - (ferror "Not a : "widget)) - (let ((widgets (drawing-widgets drawing))) - (if (not (memq widget widgets)) - (ferror "Widget "widget" not found on list for drawing "drawing".")) - (set-drawing-widgets! drawing (delq! widget widgets)))) - -(define (drawing-add-item! drawing item where) - ;; WHERE can be 'TOP (or #f) or 'BOTTOM or a drawn item already in - ;; the display list. If a drawn-item, WHERE means ITEM should be - ;; spliced in just under (before) it. - (cond ((or (eq? #f where) - (eq? 'TOP where)) - (set-drawing-display-list! - drawing (append! (drawing-display-list drawing) (list item)))) - ((eq? 'BOTTOM where) - (set-drawing-display-list! - drawing (cons item (drawing-display-list drawing)))) - ((drawn-item? where) - (let loop ((items (drawing-display-list drawing)) - (prev #f)) - (if (null? items) - (error "Item not found in drawing:" item drawing) - (let ((i (car items))) - (if (eq? where i) - (if (pair? prev) - (set-cdr! prev (cons item items)) - (set-drawing-display-list! drawing (cons item items))) - (loop (cdr items) items)))))) - (else (error:wrong-type-argument where "display list location, one of #F, TOP, BOTTOM, or a already in the drawing's display list" 'drawing-add-item!))) - (drawing-damage item)) - -(define (set-drawing-size! drawing width height) - (let ((w (check-non-negative-integer width)) - (h (check-non-negative-integer height))) - (set-rect-size! (drawing-area drawing) w h) - (for-each - (lambda (widget) (set-scm-layout-scroll-size! widget w h)) - (drawing-widgets drawing)))) - -(define (set-drawing-area! drawing rectangle) - (let ((area (drawing-area drawing))) - (set-rect! area - (rect-x rectangle) - (rect-y rectangle) - (rect-width rectangle) - (rect-height rectangle)))) - - -;;;; Drawn items. - -(define-class - () - (area define standard initializer (lambda () (make-rect 0 0 0 0))) - (drawing define standard initial-value #f) - ;; #f if the item is visible in all widgets. - ;; Else, a list of widgets in which the item should be drawn. - (widgets define standard modifier %set-drawn-item-widgets! initial-value #f)) - -(define-method initialize-instance ((item ) where) - (drawing-add-item! (drawn-item-drawing item) item where)) - -(define (set-drawn-item-position! item x y) - (let ((x (check-non-negative-integer x)) - (y (check-non-negative-integer y))) - (without-interrupts - (lambda () - (let ((area (drawn-item-area item))) - (let ((x* (rect-x area)) - (y* (rect-y area))) - (if (and (int:= x x*) (int:= y y*)) - unspecific - (begin - (drawing-damage item) - (set-rect-pos! area x y) - (drawing-damage item))))))))) - -(define (set-drawn-item-size! item width height) - (let ((area (drawn-item-area item))) - (let ((width* (rect-width area)) - (height* (rect-height area))) - (if (and (int:= width width*) (int:= height height*)) - unspecific - (begin - (drawing-damage item) - (set-rect-size! area width height) - (drawing-damage item)))))) - -(define (set-drawn-item-widgets! item new) - ;; Draw ITEM only on the NEW widgets. If NEW is #f, ITEM will - ;; appear in all views. - (let ((old (drawn-item-widgets item))) - (if (not (equal? old new)) - (without-interrupts - (lambda () - (drawing-damage item) - (%set-drawn-item-widgets! item new) - (drawing-damage item)))))) - -(define (drawn-item-widget item) - ;; Return a widget that will display the item. - (let* ((drawing (drawn-item-drawing item)) - (widgets (drawing-widgets drawing))) - (if (null? widgets) - (ferror "No widgets display drawing "drawing".") - (car widgets)))) - -(define (drawn-item-remove! item) - (let ((drawing (drawn-item-drawing item))) - (if (not (memq item (drawing-display-list drawing))) - (warn "Removing orphan drawn-item" item drawing) - (set-drawing-display-list! - drawing (delq! item (drawing-display-list drawing)))) - (drawing-damage item) - (set-drawn-item-drawing! item #f))) - - -;;;; Simple Items (e.g. the toolkit's gtk_paint_* operators). - -(define-class ( (constructor add-box-item (drawing) 1)) - () - (shadow define standard - accessor %box-item-shadow - modifier %set-box-item-shadow! - initial-value (C-enum "GTK_SHADOW_NONE"))) - -(define-method drawn-item-expose ((item ) widget window area) - area ;;Ignored. Assumed clipping already set. - (trace "; (Re)Drawing "item" on "widget".\n") - - (let ((widgets (drawn-item-widgets item))) - (if (or (eq? #f widgets) - (memq widget widgets)) - (let ((alien (gobject-alien widget)) - (scroll (scm-layout-on-screen-area widget))) - (let ((scroll-x (rect-x scroll)) - (scroll-y (rect-y scroll)) - (style (C-> alien "GtkWidget style")) - (state (C-enum "GTK_STATE_ACTIVE")) - (area (drawn-item-area item))) - (C-call "gtk_paint_box" - style window state (%box-item-shadow item) - 0 alien 0 ;area widget detail - (int:- (rect-x area) scroll-x) - (int:- (rect-y area) scroll-y) - (rect-width area) - (rect-height area))))))) - -(define (set-box-item-size! item width height) - (let ((w (check-non-negative-integer width)) - (h (check-non-negative-integer height))) - (set-drawn-item-size! item w h))) - -(define (set-box-item-pos-size! item x y width height) - (let ((area (drawn-item-area item)) - (xI (if (and (integer? x) (not (int:negative? x))) x 0)) - (yI (if (and (integer? y) (not (int:negative? y))) y 0)) - (wI (if (and (fixnum? width) (not (fix:negative? width))) width 0)) - (hI (if (and (fixnum? height) (not (fix:negative? height))) height 0))) - (without-interrupts - (lambda () - (drawing-damage item) - (set-rect! area xI yI wI hI) - (drawing-damage item))))) - -(define (box-item-shadow item) - (let ((shadow (%box-item-shadow item))) - (cond - ((int:= shadow (C-enum "GTK_SHADOW_NONE")) 'NONE) - ((int:= shadow (C-enum "GTK_SHADOW_IN")) 'IN) - ((int:= shadow (C-enum "GTK_SHADOW_OUT")) 'OUT) - ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN) - ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT)))) - -(define (set-box-item-shadow! item type) - (let ((new - (case type - ((NONE) (C-enum "GTK_SHADOW_NONE")) - ((IN) (C-enum "GTK_SHADOW_IN")) - ((OUT) (C-enum "GTK_SHADOW_OUT")) - ((ETCHED-IN) (C-enum "GTK_SHADOW_ETCHED_IN")) - ((ETCHED-OUT) (C-enum "GTK_SHADOW_ETCHED_OUT")) - (else (ferror "Not a shadow type: "type"."))))) - (if (not (fix:= new (%box-item-shadow item))) - (begin - (%set-box-item-shadow! item new) - (drawing-damage item))))) - -(define-class ( (constructor add-hline-item (drawing) 1)) - ()) - -(define-method drawn-item-expose ((item ) widget window area) - area ;;Ignored. Assumed clipping already set. - (trace "; (Re)Drawing "item" on "widget".\n") - - (let ((widgets (drawn-item-widgets item))) - (if (or (eq? #f widgets) - (memq widget widgets)) - (let ((alien (gobject-alien widget)) - (scroll (scm-layout-on-screen-area widget))) - (let ((scroll-x (rect-x scroll)) - (scroll-y (rect-y scroll)) - (style (C-> alien "GtkWidget style")) - (state (C-enum "GTK_STATE_NORMAL")) - (area (drawn-item-area item))) - (C-call "gtk_paint_hline" - style window state - 0 alien 0 ;area widget detail - (int:- (rect-min-x area) scroll-x) - (int:- (rect-max-x area) scroll-x) - (int:- (rect-y area) scroll-y))))))) - -(define (set-hline-item-size! item width) - (let ((w (check-non-negative-integer width)) - (hline (check-hline-item item))) - (set-drawn-item-size! hline w (rect-height (drawn-item-area hline))))) - -(define (check-hline-item obj) - (if (hline-item? obj) obj - (ferror "Not an instance: "obj))) - -(define-class ( (constructor add-vline-item (drawing) 1)) - ()) - -(define-method drawn-item-expose ((item ) widget window area) - area ;;Ignored. Assumed clipping already set. - (trace "; (Re)Drawing "item" on "widget".\n") - - (let ((widgets (drawn-item-widgets item))) - (if (or (eq? #f widgets) - (memq widget widgets)) - (let ((alien (gobject-alien widget)) - (scroll (scm-layout-on-screen-area widget))) - (let ((scroll-x (rect-x scroll)) - (scroll-y (rect-y scroll)) - (style (C-> alien "GtkWidget style")) - (state (C-enum "GTK_STATE_NORMAL")) - (area (drawn-item-area item))) - (C-call "gtk_paint_vline" - style window state - 0 alien 0 ;area widget detail - (int:- (rect-min-y area) scroll-y) - (int:- (rect-max-y area) scroll-y) - (int:- (rect-x area) scroll-x))))))) - -(define (set-vline-item-size! item height) - (let ((h (check-non-negative-integer height)) - (vline (check-vline-item item))) - (set-drawn-item-size! vline (rect-width (drawn-item-area vline)) h))) - -(define (check-vline-item obj) - (if (vline-item? obj) obj - (ferror "Not a instance: "obj))) - - -;;;; Text Items (aka PangoLayouts) - -(define-class ( (constructor add-text-item (drawing) 1)) - () - (pango-layout define accessor - initializer (lambda () (make-alien '|PangoLayout|))) - (text define standard - modifier %set-text-item-text! - initial-value #f)) - -(define-method initialize-instance ((item ) where) - (call-next-method item where) - (add-gc-cleanup item - (text-item-cleanup-thunk (text-item-pango-layout item)))) - -(define (text-item-cleanup-thunk pango-layout) - ;; Return a thunk closed over PANGO-LAYOUT (but not the item). - ;; Thunk is run as a gc-cleanup, without-interrupts. - (named-lambda (text-item::cleanup-thunk) - (trace ";text-item::cleanup-thunk "pango-layout"\n") - (if (not (alien-null? pango-layout)) - (begin - (C-call "g_object_unref" pango-layout) - (alien-null! pango-layout))) - (trace ";text-item::cleanup-thunk done with "pango-layout"\n"))) - -(define-method drawn-item-expose ((item ) widget window area) - area ;;Ignored. Assumed clipping already set. - (trace "; (Re)Drawing "item" on "widget".\n") - - (let ((widgets (drawn-item-widgets item))) - (if (or (eq? #f widgets) - (memq widget widgets)) - (let ((alien (gobject-alien widget)) - (scroll (scm-layout-on-screen-area widget))) - (let ((scroll-x (rect-x scroll)) - (scroll-y (rect-y scroll)) - (style (C-> alien "GtkWidget style")) - (state (C-> alien "GtkWidget state")) - (area (drawn-item-area item)) - (layout (text-item-pango-layout item))) - (if (not (alien-null? layout)) - (C-call "gtk_paint_layout" - style window state 1 - 0 alien 0 ;area widget detail - (int:- (rect-x area) scroll-x) - (int:- (rect-y area) scroll-y) - layout))))))) - -(define (set-text-item-text! text-item text) - (let ((layout (text-item-pango-layout text-item))) - - (if (alien-null? layout) - (begin - (C-call "gtk_widget_create_pango_layout" layout - (gobject-alien (drawn-item-widget text-item)) text)) - (begin - (C-call "pango_layout_set_text" layout text -1))) - (let ((log-extent (pango-rectangle)) - (ink-extent 0)) - (C-call "pango_layout_get_pixel_extents" layout ink-extent log-extent) - - (without-interrupts - (lambda () - (drawing-damage text-item) - (set-rect-size! (drawn-item-area text-item) - (C-> log-extent "GdkRectangle width") - (C-> log-extent "GdkRectangle height")) - (%set-text-item-text! text-item text) - (drawing-damage text-item))) - - (free log-extent)))) - -(define (text-item-xy-to-index item x y) - ;; Assumes (X,Y) is in ITEM's area (all logical dev. coords.). - (let ((layout (text-item-pango-layout item))) - (if (not (alien-null? layout)) - (let ((area (drawn-item-area item)) - (index-alien (malloc (C-sizeof "int") 'int))) - (let ((xL (int:- x (rect-x area))) ; layout coords. - (yL (int:- y (rect-y area)))) - (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout - (pixels->pangos xL) (pixels->pangos yL) - index-alien 0)) - (begin - (free index-alien) - #f) - (let ((index (C-> index-alien "int"))) - (free index-alien) - index)))) - #f))) - -(define (call-with-text-item-grapheme-rect item index receiver) - ;; Calls RECEIVER with the x, y, width and height of the grapheme at - ;; INDEX in ITEM. - (let ((layout (text-item-pango-layout item))) - (if (not (alien-null? layout)) - (let ((rect (pango-rectangle))) - (C-call "pango_layout_index_to_pos" layout index rect) - (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) - (y (pangos->pixels (C-> rect "PangoRectangle y"))) - (width (pangos->pixels (C-> rect "PangoRectangle width"))) - (height (pangos->pixels (C-> rect "PangoRectangle height")))) - (free rect) - (receiver x y width height))) - #f))) - - -;;;; Images (aka GdkPixbufLoaders) - -(define-class ( (constructor add-image-item (drawing) 1)) - () - ;; This slot is set to a soon after loading has begun. - (pixbuf define standard initial-value #f) - ;; This slot is set to #f when the pixbuf has been successfully loaded. - (loader define standard initializer make-pixbuf-loader)) - -(define-method initialize-instance ((item ) where) - (call-next-method item where) - (let ((loader (image-item-loader item))) - (set-pixbuf-loader-size-hook! loader (image-item-size-prepared item)) - (set-pixbuf-loader-pixbuf-hook! loader (image-item-pixbuf-prepared item)) - (set-pixbuf-loader-update-hook! loader (image-item-pixbuf-updated item)) - (set-pixbuf-loader-close-hook! loader (image-item-pixbuf-loaded item)))) - -(define (image-item-size-prepared item) - (named-lambda (image-item::size-prepared width height) - (trace "; image-item::size-prepared "item" "width" "height"\n") - (set-drawn-item-size! item width height))) - -(define (image-item-pixbuf-prepared item) - (named-lambda (image-item::pixbuf-prepared pixbuf) - (trace "; image-item::pixbuf-prepared "item" "pixbuf"\n") - (set-image-item-pixbuf! item pixbuf))) - -(define (image-item-pixbuf-updated item) - (named-lambda (image-item::pixbuf-updated rectangle) - (trace "; image-item::pixbuf-updated "item" "rectangle"\n") - (drawing-damage item rectangle))) - -(define (image-item-pixbuf-loaded item) - (named-lambda (image-item::pixbuf-loaded loader) - (trace "; image-item::pixbuf-loaded "item" ("(image-item-pixbuf item)")" - " "(pixbuf-loader-error-message loader)"\n") - (if (not (pixbuf-loader-error-message loader)) - (begin - (set-image-item-loader! item #f) - (gobject-unref loader)) - (begin - ;; Hack the pixbuf with a "broken image" overlay? - ;; - ;; Leave the loader, with dead thread and closed - ;; input-port, for debugging purposes. - unspecific)))) - -(define-method drawn-item-expose ((item ) widget window area) - (trace "; (Re)Drawing "item" on "widget".\n") - - (let ((widgets (drawn-item-widgets item))) - (if (or (eq? #f widgets) - (memq widget widgets)) - (let ((pixbuf (let ((p (image-item-pixbuf item))) - (if p (gobject-alien p) #f)))) - (if (and pixbuf (not (alien-null? pixbuf))) - (let ((item-area (drawn-item-area item)) - (scroll (scm-layout-on-screen-area widget)) - (GdkGC* (let ((alien (make-alien '(* |GdkGC|)))) - (C-> (gobject-alien widget) "GtkWidget style" - alien) - (C-> alien "GtkStyle fg_gc" alien) - (C-array-loc! alien "* GdkGC" - (C-enum "GTK_STATE_NORMAL")) - (C-> alien "* GdkGC" alien) - alien))) - (let ((i (rect-intersection item-area area)) - (scroll-x (rect-x scroll)) - (scroll-y (rect-y scroll))) - (C-call "gdk_draw_pixbuf" - window GdkGC* pixbuf - ;; drawing->image - (int:- (rect-x i) (rect-x item-area)) ;src_x - (int:- (rect-y i) (rect-y item-area)) ;src_y - ;; drawing->window - (int:- (rect-x i) scroll-x) ;dest_x - (int:- (rect-y i) scroll-y) ;dest_y - (rect-width i) (rect-height i) - (C-enum "GDK_RGB_DITHER_NONE") - 0 0 ;x_dither, y_dither - )))))))) - -(define (add-image-item-from-file drawing where filename) - (let ((item (add-image-item drawing where))) - (load-pixbuf-from-file (image-item-loader item) filename) - item)) - -(define-integrable (check-positive-integer obj) - (if (and (integer? obj) (int:> obj 0)) - obj - (error:wrong-type-argument obj "positive, non-zero integer" - 'check-positive-integer))) - -(define-integrable (check-non-negative-integer obj) - (if (integer? obj) - (if (int:negative? obj) - (ferror "Not a NON-NEGATIVE integer: "obj) - obj) - (ferror "Not a non-negative integer: "obj))) - -(define trace? #f) - -(define-syntax trace - (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) - -(define trace2? #f) -(define-syntax trace2 - (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/scm-widget.scm b/src/gtk/scm-widget.scm index 542b7476c..3311d974f 100644 --- a/src/gtk/scm-widget.scm +++ b/src/gtk/scm-widget.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -24,91 +24,22 @@ USA. ;;;; A representing a ScmWidget. ;;; package: (gtk widget) - (c-include "gtk") (define-class ()) +(define-guarantee scm-widget "a ") + (define-method initialize-instance ((new )) - ;; Calls scm_widget_new, modifying NEW's alien. + (call-next-method new) (let ((a (gobject-alien new))) (C-call "scm_widget_new" a) - (if (alien-null? a) (ferror "Could not create a Scheme widget.")) - (let ((id (register-c-callback - (named-lambda (scm-widget::finalize GObject) - (scm-widget-finalize! GObject))))) - (C->= a "ScmWidget finalize" id) - unspecific))) - -(define (scm-widget-finalize! GObject) - (define (de-register id) - (if (zero? id) unspecific (de-register-c-callback id))) - (de-register - (C-> GObject "ScmWidget finalize")) - (C->= GObject "ScmWidget finalize" 0) - (de-register - (C-> GObject "ScmWidget destroy")) - (C->= GObject "ScmWidget destroy" 0) - (de-register - (C-> GObject "ScmWidget realize")) - (C->= GObject "ScmWidget realize" 0) - (de-register - (C-> GObject "ScmWidget unrealize")) - (C->= GObject "ScmWidget unrealize" 0) - (de-register - (C-> GObject "ScmWidget size_request")) - (C->= GObject "ScmWidget size_request" 0) - (de-register - (C-> GObject "ScmWidget size_allocate")) - (C->= GObject "ScmWidget size_allocate" 0) - (de-register - (C-> GObject "ScmWidget event")) - (C->= GObject "ScmWidget event" 0) - (de-register - (C-> GObject "ScmWidget set_scroll_adjustments")) - (C->= GObject "ScmWidget set_scroll_adjustments" 0) - unspecific) - -(define (set-scm-widget-destroy! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget destroy"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget destroy" (register-c-callback proc)))) - -(define (set-scm-widget-realize! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget realize"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget realize" (register-c-callback proc)))) - -(define (set-scm-widget-unrealize! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget unrealize"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget unrealize" (register-c-callback proc)))) - -(define (set-scm-widget-size-request! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget size_request"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget size_request" (register-c-callback proc)))) - -(define (set-scm-widget-size-allocate! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget size_allocate"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget size_allocate" (register-c-callback proc)))) - -(define (set-scm-widget-event! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget event"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien "ScmWidget event" (register-c-callback proc)))) - -(define (set-scm-widget-set-scroll-adjustments! widget proc) - (let* ((alien (gobject-alien widget)) - (id (C-> alien "ScmWidget set_scroll_adjustments"))) - (if (not (zero? id)) (de-register-c-callback id)) - (C->= alien - "ScmWidget set_scroll_adjustments" - (register-c-callback proc)))) \ No newline at end of file + (if (alien-null? a) + (error "Could not create: a Scheme widget.") + (C-call "g_object_ref_sink" a a)) + (set-gtk-object-destroy-callback! new))) + +(define (set-scm-widget-set-scroll-adjustments-callback! widget callback) + (guarantee-scm-widget widget 'set-scm-widget-set-scroll-adjustments-callback!) + (guarantee-procedure-of-arity callback 3 'set-scm-widget-set-scroll-adjustments-callback!) + (g-signal-connect widget (C-callback "set_scroll_adjustments") callback)) \ No newline at end of file diff --git a/src/gtk/scmwidget.c.stay b/src/gtk/scmwidget.c.stay index 7273c4f93..4e241b176 100644 --- a/src/gtk/scmwidget.c.stay +++ b/src/gtk/scmwidget.c.stay @@ -1,6 +1,6 @@ /* -*-C-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -26,26 +26,8 @@ USA. #include #include "gtk-shim.h" -static void scm_widget_class_init (ScmWidgetClass* klass); -static void scm_widget_init (ScmWidget* sw); -static void scm_widget_finalize (GObject* object); -static void scm_widget_destroy (GtkObject* object); +static void scm_widget_class_init (ScmWidgetClass *klass); static void scm_widget_realize (GtkWidget* widget); -static void scm_widget_unrealize (GtkWidget* widget); -static void scm_widget_size_request (GtkWidget* widget, GtkRequisition* requisition); -static void scm_widget_size_allocate (GtkWidget* widget, GtkAllocation* allocation); -static gint scm_widget_event (GtkWidget* widget, GdkEvent* event); -static void scm_widget_set_scroll_adjustments (GtkWidget* widget, GtkAdjustment *hadj, GtkAdjustment *vadj); - -/* The callbacks in gtk.cdecl. */ -extern void Scm_widget_finalize (int ID, GObject* object); -extern void Scm_widget_destroy (int ID, GtkObject* object); -extern void Scm_widget_realize (int ID, GtkWidget* widget); -extern void Scm_widget_unrealize (int ID, GtkWidget* widget); -extern void Scm_widget_size_request (int ID, GtkWidget* w, GtkRequisition* r); -extern void Scm_widget_size_allocate (int ID, GtkWidget* w, GtkAllocation* a); -extern gint Scm_widget_event (int ID, GtkWidget* widget, GdkEvent* event); -extern void Scm_widget_set_scroll_adjustments (int ID, GtkWidget* widget, GtkAdjustment *hadj, GtkAdjustment *vadj); GType scm_widget_get_type (void) @@ -62,7 +44,7 @@ scm_widget_get_type (void) NULL, /* class_data */ sizeof (ScmWidget), 0, /* n_preallocs */ - (GInstanceInitFunc) scm_widget_init, + NULL, /* instance_init */ NULL /* value_table */ }; @@ -74,7 +56,7 @@ scm_widget_get_type (void) return widget_type; } -static GtkWidgetClass* parent_class = NULL; +static GtkWidgetClass *parent_class = NULL; /* VOID:OBJECT,OBJECT (./gtkmarshalers.list:91) */ static void @@ -117,180 +99,37 @@ static void scm_widget_class_init (ScmWidgetClass *klass) { GObjectClass *gobject_class; - GtkObjectClass *object_class; GtkWidgetClass *widget_class; gobject_class = G_OBJECT_CLASS (klass); - object_class = (GtkObjectClass*) klass; widget_class = (GtkWidgetClass*) klass; parent_class = g_type_class_peek_parent (klass); - gobject_class->finalize = scm_widget_finalize; - - object_class->destroy = scm_widget_destroy; - widget_class->realize = scm_widget_realize; - widget_class->unrealize = scm_widget_unrealize; - - widget_class->size_request = scm_widget_size_request; - - widget_class->size_allocate = scm_widget_size_allocate; - - widget_class->event = scm_widget_event; - - klass->set_scroll_adjustments = scm_widget_set_scroll_adjustments; widget_class->set_scroll_adjustments_signal = g_signal_new ("set_scroll_adjustments", G_OBJECT_CLASS_TYPE (gobject_class), G_SIGNAL_RUN_LAST | G_SIGNAL_ACTION, - /* */ - G_STRUCT_OFFSET (ScmWidgetClass, set_scroll_adjustments), - NULL, NULL, /* Accumulator and accu_data. */ + 0, NULL, NULL, /* class_offset, accumulator, accu_data */ marshal_VOID__OBJECT_OBJECT, G_TYPE_NONE, 2, GTK_TYPE_ADJUSTMENT, GTK_TYPE_ADJUSTMENT); } -static void -scm_widget_init (ScmWidget* w) -{ - GTK_WIDGET_SET_FLAGS (GTK_WIDGET(w), GTK_CAN_FOCUS); - w->finalize = 0; - w->destroy = 0; - w->realize = 0; - w->unrealize = 0; - w->size_request = 0; - w->size_allocate = 0; - w->event = 0; - w->set_scroll_adjustments = 0; -} - GtkWidget * scm_widget_new (void) { - ScmWidget* sw = (ScmWidget*) g_object_new (GTK_TYPE_SCMWIDGET, NULL); - return ((GtkWidget*)sw); -} - - - -/* ScmWidget methods. - - These methods call the callback trampolines, adding the ID argument - previously stored in the ScmWidget. */ - -static void -scm_widget_finalize (GObject* object) -{ - ScmWidget* w = GTK_SCMWIDGET (object); - int ID = w->finalize; - if (ID == 0) { - outf_error ("ScmWidget (0x%x) had no finalize callback.\n", (uint)w); - outf_flush_error (); - } else { - Scm_widget_finalize (ID, object); - } - - G_OBJECT_CLASS (parent_class)->finalize (object); -} - -static void -scm_widget_destroy (GtkObject* object) -{ - ScmWidget* w = GTK_SCMWIDGET (object); - int ID = w->destroy; - if (ID != 0) { - Scm_widget_destroy (ID, object); - } - - GTK_OBJECT_CLASS(parent_class)->destroy (object); + return ((GtkWidget*) g_object_new (GTK_TYPE_SCMWIDGET, NULL)); } static void scm_widget_realize (GtkWidget* widget) { - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->realize; - GTK_WIDGET_SET_FLAGS (widget, GTK_REALIZED); - if (ID == 0) { - outf_error ("ScmWidget (0x%x) had no realize callback.\n", (uint)w); - outf_flush_error (); - } else { - Scm_widget_realize (ID, widget); - } -} + /* The default GtkWidget method expects !gtk_widget_get_has_window, + so it is replaced by this near no-op. ScmWidget realization + actually happens during REALIZE signal emission. */ -static void -scm_widget_unrealize (GtkWidget* widget) -{ - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->unrealize; - - if (GTK_WIDGET_MAPPED (widget)) { - gtk_widget_unmap (widget); - GTK_WIDGET_UNSET_FLAGS (widget, GTK_MAPPED); - } - - if (ID != 0) { - Scm_widget_unrealize (ID, widget); - } - - if (GTK_WIDGET_CLASS (parent_class) ->unrealize) { - (* GTK_WIDGET_CLASS (parent_class) ->unrealize) (widget); - } -} - -static void -scm_widget_size_request (GtkWidget* widget, GtkRequisition* requisition) -{ - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->size_request; - if (ID == 0) { - outf_error ("ScmWidget (0x%x) had no size_request callback.\n", (uint)w); - outf_flush_error (); - } else { - Scm_widget_size_request (ID, widget, requisition); - } -} - -static void -scm_widget_size_allocate (GtkWidget* widget, GtkAllocation* allocation) -{ - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->size_allocate; - if (ID == 0) { - outf_error ("ScmWidget (0x%x) had no size_allocate callback.\n", (uint)w); - outf_flush_error (); - } else { - Scm_widget_size_allocate (ID, widget, allocation); - } -} - -static gboolean -scm_widget_event (GtkWidget* widget, GdkEvent* event) -{ - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->event; - if (ID == 0) { - outf_error ("ScmWidget (0x%x) had no event callback.\n", (uint)w); - outf_flush_error (); - return FALSE; /* NOT handled */ - } else { - return Scm_widget_event (ID, widget, event); - } -} - -static void -scm_widget_set_scroll_adjustments (GtkWidget* widget, - GtkAdjustment *hadj, GtkAdjustment *vadj) -{ - ScmWidget* w = GTK_SCMWIDGET (widget); - int ID = w->set_scroll_adjustments; - if (ID == 0) { - /* This is nominal. */ - } else { - Scm_widget_set_scroll_adjustments (ID, widget, hadj, vadj); - } + gtk_widget_set_realized (widget, TRUE); } diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm new file mode 100644 index 000000000..d8dcfa437 --- /dev/null +++ b/src/gtk/swat.scm @@ -0,0 +1,1233 @@ +#| -*-Scheme-*- + +Copyright (C) 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; SWAT adapter. +;;; package: (gtk swat) + +;;;; SWAT Widgets + +;;; These specializations of subclasses implement SWAT's +;;; widgets. + +(define-class + () + + ;; This flag is set by a realize signal handler (or fix-layout-realize). + (realized? define standard initial-value #f) + + ;; An alist of SWAT's configuration settings (fonts, colors, etc.). + (options define standard initial-value '()) + + ;; A pair (list of pairs?): (reason . thunk). + (on-death define standard initial-value #f)) + +(define-method initialize-instance ((widget ) . args) + (trace ";((initialize-instance ) "widget" "args")...\n") + (apply call-next-method widget args) + ;; Do NOT replace fix-layout's realize callback. (Add a method to + ;; fix-layout-realize-callback instead [or support a more generic + ;; realize-callback?].) + (if (not (fix-layout? widget)) + (set-gtk-widget-realize-callback! widget realize-options))) + +(define-method gtk-object-destroy-callback ((object )) + (call-next-method object) + (let ((on-death (without-interrupts + (lambda () + (let ((on-death (swat-widget-on-death object))) + (if on-death (set-swat-widget-on-death! object #f)) + on-death))))) + (if on-death + (begin + (trace ";on-death "object": "on-death"\n") + ((cdr on-death)))))) + +(define-class ( (constructor ())) + ( )) + +;; s can have a callback AND/or a -variable. These +;; could be two signal handlers connected to the "toggled" signal, but +;; Gtk does not support more than one signal handler per signal name. +;; Instead, two slots keep track of the two possible callbacks, and +;; the "toggled" signal is always connected (even if neither a +;; callback nor a variable is configured). + +(define-class ( (constructor ())) + ( ) + + ;; From (set-callback! checkbutton (lambda () ...)) + (swat-callback define standard initial-value #f) + + ;; From (make-checkbutton -variable ...) + (swat-variable define standard initial-value #f)) + +;; s are actually GtkFrames with no "label", whose GtkBin +;; child is a GtkLabel... so a little confusing. + +(define-class ( (constructor ())) + ( )) + +(define-method initialize-instance ((frame )) + (trace ";((initialize-instance ) "frame")...\n") + (call-next-method frame "") + (gtk-container-add frame (gtk-label-new ""))) + +(define (set-label-relief! label relief) + (let ((gtk-shadow-type (relief->gtk-shadow-type relief))) + (gtk-frame-set-shadow-type label gtk-shadow-type))) + +(define (relief->gtk-shadow-type relief) + (case relief + ((raised) 'out) + ((sunken) 'in) + ((flat) 'none) + ((ridge) 'etched-out) + ((solid) (warn "unimplemented relief" relief)) + ((groove) 'etched-in) + (else (warn "unexpected relief" relief)))) + +;;;; SWAT canvases + +;;; Implemented by a specialized widget whose drawing +;;; consists of s. Swat inks co-operate as "items" in +;;; s. +;;; +;;; The implementation chosen here removes a group's items from the +;;; drawing's display-list, keeping them in the group's item list, and +;;; ensuring that the group's ink-extent encompasses all of its items' +;;; ink-extents. The layout expose handler can then skip entire +;;; groups (assuming they are relatively compact) or descend and, in +;;; the group expose handler, perform a similar search-and-expose +;;; among the group's items, recursively. +;;; +;;; To make the group ink-extent guarantee, all of a group's items +;;; must be s, which update their group's extent +;;; (recursively) whenever their extents change. +;;; +;;; Updating a group's extent generally means computing a new union of +;;; all item ink-extents. This can be expensive for a large group +;;; when items change relative to the rest. This is presumably rare. +;;; Once created, a group is likely only moved or hidden, with +;;; predictable effects on the group ink-extent (and no need to +;;; re-union-all). For large groups of widely scattered objects, a +;;; different group implementation would be more appropriate, e.g. one +;;; that keeps its items in the drawing display-list and perhaps does +;;; not even appear there itself... + +(define-class ( (constructor () (width height))) + ( ) + + ;; An alist of (event-type . modifiers) x SWAT event handler procedures. + (swat-handlers define standard initial-value '())) + +(define-method initialize-instance ((canvas ) width height) + (trace ";((initialize-instance ) "canvas" "width" "height")...\n") + (call-next-method canvas width height) + (set-fix-layout-drawing! canvas (make-fix-drawing) 0 0)) + +(define (set-swat-canvas-handler! canvas type.modifiers handler) + ;; type.modifiers is e.g. (press 3 control), (double-press 1), + ;; or (motion button1). + (let* ((handlers (swat-canvas-swat-handlers canvas)) + (entry (assoc type.modifiers handlers))) + (if entry + (set-cdr! entry handler) + (set-swat-canvas-swat-handlers! + canvas (cons (cons type.modifiers handler) handlers))))) + +(define-method fix-layout-realize-callback ((canvas )) + (call-next-method canvas) + (realize-options canvas) + (for-each + (lambda (type) + (set-fix-layout-button-handler! + canvas type + (named-lambda (canvas-button-handler canvas type button modifiers x y) + (trace ";canvas-button-handler "type" "button" "modifiers + " "x","y" "canvas"\n") + (handle-canvas-event canvas + (append! (list type button) modifiers) x y)))) + '(press release double-press triple-press)) + (set-fix-layout-motion-handler! + canvas + (named-lambda (canvas-motion-handler canvas modifiers x y) + (trace2 ";canvas-motion-handler "modifiers" "x","y" "canvas"\n") + (handle-canvas-event canvas (cons 'motion modifiers) x y)))) + +(define-class () + + ;; A or #f. + (group define standard initial-value #f) + + ;; An alist of (event-type . modifiers) x SWAT event handler procedures. + (swat-handlers define standard initial-value '())) + +(define (set-swat-ink-handler! item type.modifiers handler) + (let* ((handlers (swat-ink-swat-handlers item)) + (entry (assoc type.modifiers handlers))) + (if entry + (set-cdr! entry handler) + (set-swat-ink-swat-handlers! + item (cons (cons type.modifiers handler) handlers))))) + +(define (item-delete! item) + (fix-ink-remove! item) + ;; No hurry here. Expose events are cut off (above). Some + ;; unnecessary drawing damage may occur (if items are changed before + ;; they lose their link to the drawing), but the redraws will still + ;; be correct. + (if (swat-group? item) + (let unset! ((items (swat-group-items item))) + (if (pair? items) + (let ((i (car items))) + (set-fix-ink-drawing! i #f) + (if (swat-group? i) (unset! (swat-group-items i))) + (unset! (cdr items))))))) + +(define (item-move! item dx dy) + (guarantee-fixnum dx 'item-move!) + (guarantee-fixnum dy 'item-move!) + (if (not (and (fix:zero? dx) (fix:zero? dy))) + (without-interrupts + (lambda () + (fix-ink-move! item dx dy) + (let ((group (swat-ink-group item))) + (if group (recache-group-extent! group))))))) + +(define (recache-group-extent! group) + (let ((extent (fix-ink-extent group)) + (items (swat-group-items group))) + (if (null? items) + (set-fix-rect-size! extent 0 0) + (let ((first (car items)) + (rest (cdr items))) + (copy-fix-rect! extent (fix-ink-extent first)) + (for-each (lambda (i) (fix-rect-union! extent (fix-ink-extent i))) + rest)))) + (let ((group (swat-ink-group group))) + (if group (recache-group-extent! group)))) + +(define-class ( (constructor ())) + () + (items define standard initial-value '())) + +(define-method fix-ink-expose-callback ((group ) widget window area) + (for-each (lambda (ink) + (if (fix-ink-in? ink widget area) + (fix-ink-expose-callback ink widget window area))) + (swat-group-items group))) + +(define-method fix-ink-move! ((group ) dx dy) + (without-interrupts + (lambda () + (let ((extent (fix-ink-extent group))) + (fix-rect-move! extent dx dy) + (for-each (lambda (i) (fix-ink-move! i dx dy)) + (swat-group-items group)))))) + +(define (group-add! group item) + (without-interrupts + (lambda () + (let ((items (swat-group-items group)) + (extent (fix-ink-extent group)) + (drawing (fix-ink-drawing group))) + (if (not (eq? drawing (fix-ink-drawing item))) + (error "group-add!: wrong drawing:" item group)) + (set-swat-group-items! group (append! items (list item))) + (if (null? items) + (copy-fix-rect! extent (fix-ink-extent item)) + (fix-rect-union! extent (fix-ink-extent item))) + (set-fix-drawing-display-list! ;AFTER adding to group extent + drawing (delq! item (fix-drawing-display-list drawing))) + (set-swat-ink-group! item group))))) + +(define (group-remove! group item) + (without-interrupts + (lambda () + (let ((items (swat-group-items group))) + (define (topmost group) + (let ((parent (swat-ink-group group))) + (if (not parent) group (topmost parent)))) + (if (memq item items) + (begin + ;; Move ink to canvas? Under the topmost group? + (fix-drawing-add-ink! (fix-ink-drawing group) item (topmost group)) + (set-swat-group-items! group (delq! item items)) + (recache-group-extent! group)) + (error "No such item:" item group)))))) + +;;;; Event handling. + +;;; Tk provides some fancy massaging of the "raw" input event stream. +;;; The handler specified by the pole-zero +;;; example is an abbreviation for "", according +;;; to the Tk::bind manpage. (" is equivalent to +;;; with the extra time and space +;;; requirement. [Tk::bind(3pm)] +;;; +;;; This implementation uses a preview stage to convert the GdkEvent +;;; stream into "SWAT events". Thus a Gdk event stream like this: +;;; +;;; P-1 R-1 2P-1 R-1 +;;; +;;; where P-1 is a GDK_BUTTON_PRESS event whose "button" member = 1, +;;; R-1 is a GDK_BUTTON_RELEASE with button 1, +;;; and 2P-1 is a GDK_2BUTTON_PRESS with button 1 +;;; +;;; within certain time and space constraints, generates the event key +;;; +;;; (double-press 1) +;;; +;;; which is looked up among the handlers of canvasitems under the +;;; point. +;;; +;;; Note that the R-1 event must be ignored, not turned into a +;;; (release 1) event, else the pole-zero example breaks in the +;;; handler of the newly created object (under the +;;; point). +;;; +;;; The state machine doing the conversion is implemented by the Gtk +;;; event handlers. Depending on the state of the machine (the event +;;; prefix seen so far) a Gtk event or timeout handler can generate +;;; a SWAT event, or schedule a timeout. +;;; +;;; An example event stream, with small mouse movements, that should +;;; be recognized as a single (double-press 1), no (release 1): +;;; +;;; P1 R1 Msmall 2P1 Msmall R1 T0 +;;; +;;; where Msmall is any number of GDK_MOTION_NOTIFY events that +;;; stay nearby, and T0 is a timeout scheduled during the handling +;;; of 2P1. +;;; +;;; An example event stream that is actually a double-click-drag: +;;; +;;; P1 Msmall R1 2P1 Msmall Msmall T0 Msmall Msmall R1 +;;; +;;; should produce: +;;; +;;; 2P1 Msmall Msmall R1 +;;; +;;; For now (for pole-zero), the state machine need only ignore button +;;; release (and movement events?) that follow a button press by less +;;; than a fraction of a second, and button presses that are followed +;;; by a double-press within a fraction of a second. +;;; +;;; To handle the latter, it is natural to wait with a timeout for the +;;; double- or triple-press, but sleep-current-thread is inappropriate +;;; in an event handler -- a callback running at "interrupt" level +;;; (within without-interrupts). Instead, the event handlers queue +;;; "input events" that are read (dequeued), with a timeout, by +;;; swat-thread (which can sleep). + +(define (handle-canvas-event canvas event window-x window-y) + (trace2 "; handle-canvas-event "event" "window-x","window-y" "canvas"\n") + (let* ((view (fix-layout-view canvas)) + (x (fix:+ window-x (fix-rect-x view))) + (y (fix:+ window-y (fix-rect-y view)))) + (thread-queue/queue-no-hang! swat-input-queue (list event canvas x y)) + #t)) + +(define swat-input-queue) +(define swat-thread) + +(define (initialize-package!) + (set! swat-input-queue (make-thread-queue 100)) + (set! swat-thread (make-swat-thread))) + +(define (make-swat-thread) + (create-thread + #f + (lambda () + (trace ";swat-thread: "(current-thread)"\n") + + (let main () + + (define-integrable (read!) + (thread-queue/dequeue! swat-input-queue)) + + (define-integrable (peek-until time) + (thread-queue/peek-until swat-input-queue time)) + + (define-integrable (handle event) + (apply handle-event event) + (main)) + + (let* ((event (read!)) + (type (caar event))) + (cond + ((eq? type 'release) + (main)) ; Ignore EVENT. + ((memq type '(press double-press triple-press)) + (let ((quitn-time (+ 500 (real-time-clock)))) + (let wait () + (let ((next-event (peek-until quitn-time))) + (if (not next-event) + (handle event) + (let ((next-type (caar next-event))) + (cond + ((memq next-type '(double-press triple-press)) + (main)) ; Ignore EVENT, read NEXT-EVENT. + ((eq? next-type 'motion) + (read!) ; Ignore NEXT-EVENT, + (wait)) ; and wait some more. + (else + (handle event))))))))) + (else + (handle event))))) + (trace ";swat-thread: done\n") + (stop-current-thread)))) + +(define (handle-event key canvas x y) + (or (let* ((handlers (swat-canvas-swat-handlers canvas)) + (entry (assoc key handlers))) + (trace "; Canvas: "entry"\n") + (and entry ((cdr entry) canvas x y))) + (let ((items (pick-list canvas x y))) + (trace "; Pick list: "items"\n") + (find (lambda (item) + (let* ((handlers (swat-ink-swat-handlers item)) + (entry (assoc key handlers))) + (trace "; "entry" "item"\n") + (and entry ((cdr entry) canvas x y)))) + items)))) + +(define (pick-list canvas x y) + (trace2 "; pick-list "x","y" "canvas"\n") + (let loop ((items (fix-drawing-display-list (fix-layout-drawing canvas))) + (picks '())) + (if (pair? items) + (loop (cdr items) + (let ((item (car items))) + (if (not (fix-ink-in-widget? item canvas)) + (trace2 ";\t"item" not in "canvas"\n") + (begin + (trace2 ";\t"x","y" in "item" ("(fix-ink-extent item)")? ") + (if (point-in-fix-rect? x y (fix-ink-extent item)) + (trace2 "yes!\n") + (trace2 "no\n")))) + (if (and (fix-ink-in-widget? item canvas) + (point-in-fix-rect? x y (fix-ink-extent item))) + (cons item + (if (swat-group? item) + (append! (loop (swat-group-items item) '()) + picks) + picks)) + picks))) + picks))) + +(define-class ( (constructor ())) + ( )) + +(define-class ( (constructor ())) + ( )) + +(define-class ( (constructor ())) + ( )) + +(define-class ( (constructor ())) + ( ) + (anchor define standard initial-value 'nw + modifier set-swat-text-%anchor!)) + +(define (set-swat-text-anchor! text anchor) + (if (not (eq? anchor (swat-text-anchor text))) + (hold-position text + (lambda () (set-swat-text-%anchor! text anchor))))) + +(define (set-swat-text-text! text string) + (guarantee-string string 'set-swat-text-text!) + (if (eq? 'nw (swat-text-anchor text)) + (set-simple-text-ink-text! text string) + (hold-position text (lambda () (set-simple-text-ink-text! text string))))) + +(define-integrable (hold-position text thunk) + (with-swat-text-pos + text + (lambda (old-x old-y) + (thunk) + (with-swat-text-pos + text + (lambda (new-x new-y) + (let ((dx (fix:- new-x old-x)) + (dy (fix:- new-y old-y))) + (if (not (and (fix:zero? dx) (fix:zero? dy))) + (fix-ink-move! text dx dy)))))))) + +(define (with-swat-text-pos text receiver) + ;; Calls RECEIVER with the coordinates of the text's anchor position. + (let ((anchor (swat-text-anchor text))) + (with-fix-rect + (fix-ink-extent text) + (lambda (x y width height) + (define-integrable (top) x) + (define-integrable (left) y) + (define-integrable (right) (fix:+ x width)) + (define-integrable (bottom) (fix:+ y height)) + (define-integrable (mid-right) (fix:+ x (quotient width 2))) + (define-integrable (mid-bottom) (fix:+ y (quotient height 2))) + (case anchor + ((CENTER) (receiver (mid-right) (mid-bottom))) + ((NE) (receiver (right) (top))) + ((SE) (receiver (right) (bottom))) + ((SW) (receiver (left) (bottom))) + ((NW) (receiver (left) (top))) + ((N) (receiver (mid-right) (top))) + ((E) (receiver (right) (mid-bottom))) + ((S) (receiver (mid-right) (bottom))) + ((W) (receiver (left) (mid-bottom))) + (else (error "Unexpected text anchor:" anchor text))))))) + +;;;; Active Variables + +;;; These are tricky. A variable should, in set-active-variable!, +;;; call any SWAT callback (if set). Those variables "connected" to a +;;; widget should ALSO frob the widget (e.g. set a GtkLabel's text, or +;;; toggle a check-button,...). +;;; +;;; Some widgets also SET variables, e.g. in a check-button "toggled" +;;; callback. In these cases, the SWAT callback should be called (if +;;; set), BUT the frobbing of the widget... might be a loop! Thus an +;;; active variable separates the SWAT callback from the widget +;;; frobbing. It always does the former, sometimes the latter. + +(define-structure (active-variable (constructor make-active-variable ())) + + (value '()) + + ;; Could not find anything like SOS slot option "define initpred", + ;; though there seems to be something there... Anyway, this seems + ;; more portable. + (value-initialized? #f) + + ;; User callback -- a thunk. + (swat-callback #f) + + ;; Widget frobbing closure, taking one arg: the new value. + (frob #f)) + +(define-guarantee active-variable "active-variable") + +(define (set-active-variable-callback! variable callback) + (guarantee-active-variable variable 'set-active-variable-callback!) + (guarantee-procedure-of-arity callback 0 'set-active-variable-callback!) + (if (active-variable-swat-callback variable) + (error "Callback already set:" variable callback)) + (set-active-variable-swat-callback! variable callback)) + +(define (set-active-variable! variable value) + (guarantee-active-variable variable 'set-active-variable!) + (frob-active-variable! variable value) + (let ((frob (active-variable-frob variable))) + (if frob (frob value)))) + +(define-integrable (frob-active-variable! variable value) + ;; Used by widgets to frob an active variable without getting + ;; frobbed in return. + (set-active-variable-value-initialized?! variable #t) + (set-active-variable-value! variable value) + (let ((callback (active-variable-swat-callback variable))) + (if callback (callback)))) + +;;;; Widget Configuration + +;;; Options from the examples: +;;; +;;; button -foreground blue +;;; button -background yellow +;;; button -activebackground red +;;; button -text "Push me" +;;; +;;; and from Pole-0: +;;; +;;; button -background ,color +;;; canvas -background ,color +;;; label -background ,color +;;; button -font "CourR12" +;;; label -font "CourR12" +;;; label -relief sunken +;;; button -text ,string +;;; label -textvariable ,active-variable +;;; label -width 13 + +(define (widget-configure! widget options) + (let loop ((opts options)) + (if (pair? opts) + (let ((name (car opts)) + (value (cadr opts))) + (case name + ((-foreground) (set-option! widget 'foreground value)) + ((-background) (set-option! widget 'background value)) + ((-activeforeground) (set-option! widget 'activeforeground value)) + ((-activebackground) (set-option! widget 'activebackground value)) + ((-font) (set-option! widget 'font value)) + + ((-width) (set-width! widget value)) + ((-text) (set-text! widget value)) + ((-textvariable) (set-textvariable! widget value)) + ((-relief) (set-label-relief! widget value)) + (else (warn "unimplemented configure option:" + name value widget))) + (loop (cddr opts)))))) + +(define (set-option! widget name spec) + (let* ((options (swat-widget-options widget)) + (entry (assq name options))) + (if entry + (set-cdr! entry spec) + (set-swat-widget-options! widget (cons (cons name spec) options)))) + (if (swat-widget-realized? widget) (realize-option widget name spec))) + +(define (realize-option widget name spec) + (case name + ((foreground) (set-gtk-widget-fg-color! widget spec 'normal)) + ((background) (set-gtk-widget-bg-color! widget spec 'normal)) + ((activeforeground) (set-gtk-widget-fg-color! widget spec 'active)) + ((activebackground) (set-gtk-widget-bg-color! widget spec 'active)) + ((font) (set-gtk-widget-font! widget spec)) + (else (warn "Cannot realize widget option:" name spec widget)))) + +(define (realize-options widget) + (for-each (lambda (option) + (realize-option widget (car option) (cdr option))) + (swat-widget-options widget))) + +(define-integrable (set-width! widget width) + (if (swat-label? widget) + (gtk-label-set-width-chars (gtk-bin-child widget) width) + (warn "Unimplemented:" '-width widget))) + +(define-generic set-text! (widget string)) + +(define-method set-text! ((button ) string) + (guarantee-string string '(set-text! )) + (let ((label (gtk-bin-child button))) + (if (not label) + (gtk-container-add button (gtk-label-new string)) + (gtk-label-set-text label string)))) + +(define-method set-text! ((label ) string) + (guarantee-string string '(set-text! )) + (gtk-label-set-text (gtk-bin-child label) string)) + +(define-method set-text! ((button ) string) + (guarantee-string string '(set-text! )) + (let ((label (gtk-bin-child button))) + (if (not label) + (gtk-container-add button (gtk-label-new string)) + (gtk-label-set-text label string)))) + +(define-generic set-textvariable! (widget active-variable)) + +(define-method set-textvariable! ((widget ) variable) + (set-active-variable-frob! variable (make-label-frobbery widget)) + (set-active-variable-value! variable + (gtk-label-get-text (gtk-bin-child widget))) + (set-active-variable-value-initialized?! variable #t)) + +(define (make-label-frobbery label) + (named-lambda (label-frobbery value) + (trace ";label-frobbage "label" "value"\n") + (if (string? value) + (gtk-label-set-text (gtk-bin-child label) value) + (warn "Bogus text for swat-label frobbery:" value label)))) + +;;;; Canvas Item Configuration + +;;; Options from pole-zero: +;;; +;;; text -anchor sw +;;; text -anchor e +;;; line -arrow last +;;; line -arrow first +;;; group -fill ,color +;;; oval -fill ,color +;;; text -font "-adobe-symbol-...-fontspecific" +;;; oval -outline "gray" +;;; text -text "p" +;;; group -width 2 +;;; oval -width 2 + +(define (item-configure! item options) + (without-interrupts + (lambda () + (let loop ((opts options)) + (if (pair? opts) + (let ((name (car opts)) + (value (cadr opts))) + (set-item-option! item name value) + (loop (cddr opts)))))))) + +(define (set-item-option! item name value) + (if (swat-group? item) + (for-each (lambda (i) (set-item-option! i name value)) + (swat-group-items item)) + (case name + ((-anchor) (set-item-anchor! item value)) + ((-arrow) (set-item-arrow! item value)) + ((-fill) (set-item-fill! item value)) + ((-font) (set-item-font! item value)) + ((-outline) (set-item-outline! item value)) + ((-text) (set-item-text! item value)) + ((-width) (set-item-width! item value)) + (else (error "Unimplemented option:" name value item))))) + +(define-generic set-item-anchor! (item value)) +(define-method set-item-anchor! ((text ) value) + (if (not (memq value '(N S E W NE SE SW NW))) + (error:wrong-type-argument value "an anchor direction" 'set-item-anchor!)) + (set-swat-text-anchor! text value)) + +(define-generic set-item-arrow! (item first?)) +(define-method set-item-arrow! ((line ) first?) + (warn "Unimplemented:" '(set-item-arrow! ) line first?)) + +(define-generic set-item-fill! (item color)) +(define-method set-item-fill! ((item ) color) + (set-line-ink-color! item color)) +(define-method set-item-fill! ((item ) color) + (set-arc-ink-fill-color! item color)) +(define-method set-item-fill! ((item ) color) + (set-rectangle-ink-fill-color! item color)) +(define-method set-item-fill! ((item ) color) + (set-text-ink-color! item color)) + +(define-generic set-item-font! (item font)) +(define-method set-item-font! ((item ) font) + (set-simple-text-ink-font! item font)) + +(define-generic set-item-outline! (item value)) +(define-method set-item-outline! ((item ) color) + (set-arc-ink-color! item color)) +(define-method set-item-outline! ((item ) color) + (set-rectangle-ink-color! item color)) + +(define-generic set-item-text! (item value)) +(define-method set-item-text! ((text ) string) + (guarantee-string string '(set-item-text! )) + (set-swat-text-text! text string)) + +(define-generic set-item-width! (item value)) +(define-method set-item-width! ((item ) width) + (set-line-ink-width! item width)) +(define-method set-item-width! ((item ) width) + (guarantee-positive-fixnum width '(set-item-width! )) + (set-arc-ink-width! item width)) +(define-method set-item-width! ((item ) width) + (guarantee-positive-fixnum width '(set-item-width! )) + (set-rectangle-ink-width! item width)) + +;;;; SWAT Interface + +;;; Here are the procedures exported to the (swat) package. They are +;;; organized by their original SWAT files, listed in the order they +;;; are loaded. + +;;; * control-floating-errors +;;; +;;; LAP-generating floating-exception-flag-frobing Nerds Gone Wild. + +;;; * structures +;;; +;;; Definitions of structures in Tk. + +;;; * structures2 +;;; +;;; And some more. + +;;; * generics +;;; +;;; Generic operations: +;;; SET-CONTEXT!, assign-screen-area!, +;;; assign-drawing-surface!, handle-event, +;;; get-desired-size, get-desired-size, EVENT-WITHIN? + +(define (add-child! object child . others) + (if (null? others) + (gtk-container-add object child) + (error "unimplemented"))) + +(define (remove-child! object child) + (gtk-container-remove object child)) + +;;; Ask-widget in the examples: +;;; +;;; (ask-widget button-widget '(configure -foreground blue)) +;;; +;;; and in pole-zero.scm: +;;; +;;; (ask-widget oval-item `(configure -outline ,zero-color ...)) +;;; (ask-widget group-item `(configure -fill ,pole-color -width 2)) +;;; (ask-widget button-widget `(configure -text ,(car (list-ref to-switch i)))) +;;; (ask-widget label-widget `(configure -width 13 ...)) +;;; (ask-widget canvas-widget `(configure -background ,canvas-color)) +;;; (ask-widget line-item '(configure -arrow last)) +;;; (ask-widget text-item '(configure -anchor sw ...)) +;;; (ask-widget oval-item `(move ,(- x last-x) ,(- y last-y))) +;;; (ask-widget group-item `(move ,(- x last-x) ,(- y last-y))) +;;; (ask-widget oval-item '(delete)) +;;; (ask-widget group-item '(delete)) +;;; (ask-widget canvas-widget '(delete all)) + +(define (ask-widget object command) + ;; Dispatch on command name and object type (widget or canvas item). + (case (car command) + ((CONFIGURE) + (cond ((swat-widget? object) + (widget-configure! object (cdr command))) + ((swat-ink? object) + (item-configure! object (cdr command))) + (else (warn "Non-SWAT widget:" object)))) + ((MOVE) + (cond ((and (swat-ink? object) + (= 3 (length command))) + (item-move! object (cadr command) (caddr command))) + (else + (warn "Unexpected move command:" object command)))) + ((DELETE) + (cond ((and (equal? command '(DELETE ALL)) + (swat-canvas? object)) + (delete-all! object)) + ((and (equal? command '(DELETE)) + (swat-ink? object)) + (item-delete! object)) + (else + (warn "Unexpected delete command:" object command)))) + (else (warn "Unimplemented ask-widget command:" object command)))) + +(define-generic add-event-handler! (object event-type handler . substitutions)) +;;; Examples: (add-event-handler! button "" (lambda () ...)) +;;; Pole-0: (add-event-handler! item-group "" (lambda (x y) ...) "%x" "%y") +;;; Pole-0: (add-event-handler! item-group "" (lambda (x) ...) "%x") +;;; Pole-0: (add-event-handler! item-group "" (lambda () ...)) +;;; Pole-0: (add-event-handler! item-group "" (lambda (x y) ...) "%x" "%y") +;;; Pole-0: (add-event-handler! item-group "" (lambda (x) ...) "%x") + +(define-method add-event-handler! ((button ) + event-type handler . substitutions) + (cond ((and (string=? event-type "") + (null? substitutions)) + (guarantee-procedure-of-arity handler 0 'add-event-handler!-) + (set-gtk-button-clicked-callback! + button (lambda (button) (declare (ignore button)) (handler)))) + (else + (warn "Unimplemented:" '(add-event-handler! ) + button event-type handler substitutions)))) + +(define-method add-event-handler! ((canvas ) + event-type handler . substitutions) + + (define (unimplemented) + (warn "Unimplemented:" '(add-event-handler! ) + canvas event-type handler substitutions)) + + (cond + ((and (string=? event-type "") + (equal? substitutions '("%x" "%y"))) + (guarantee-procedure-of-arity handler 2 '(add-event-handler! )) + (set-swat-canvas-handler! canvas '(double-press 1) + (lambda (canvas x y) + (declare (ignore canvas)) + (handler x y)))) + (else (unimplemented)))) + +(define-method add-event-handler! ((item ) + event-type handler . substitutions) + + (define (unimplemented) + (warn "Unimplemented:" '(add-event-handler! ) + item event-type handler substitutions)) + + (cond + ((string=? event-type "") + (cond + ((equal? substitutions '("%x" "%y")) + (guarantee-procedure-of-arity handler 2 '(add-event-handler! "" "%x" "%y")) + (set-swat-ink-handler! item '(press 1) + (lambda (item x y) + (declare (ignore item)) + (handler x y)))) + ((equal? substitutions '("%x")) + (guarantee-procedure-of-arity handler 1 '(add-event-handler! "" "%x")) + (set-swat-ink-handler! item '(press 1) + (lambda (item x y) + (declare (ignore item y)) + (handler x)))) + (else (unimplemented)))) + ((string=? event-type "") + (cond + ((equal? substitutions '()) + (guarantee-procedure-of-arity handler 0 '(add-event-handler! "")) + (set-swat-ink-handler! item '(release 1 button1) + (named-lambda (release1 item x y) + (declare (ignore item x y)) + (handler)))) + (else (unimplemented)))) + ((string=? event-type "") + (cond + ((equal? substitutions '("%x" "%y")) + (guarantee-procedure-of-arity handler 2 '(add-event-handler! "" "%x" "%y")) + (set-swat-ink-handler! item '(motion button1) + (named-lambda (motion-button1-x-y item x y) + (declare (ignore item)) + (handler x y)))) + ((equal? substitutions '("%x")) + (guarantee-procedure-of-arity handler 1 '(add-event-handler! "" "%x")) + (set-swat-ink-handler! item '(motion button1) + (named-lambda (motion-button1-x item x y) + (declare (ignore item y)) + (handler x)))) + (else (unimplemented)))) + (else (unimplemented)))) + +(define-generic set-callback! (object callback)) +;;; Examples: (set-callback! button (lambda () ...)) + +(define-method set-callback! ((object ) callback) + (guarantee-procedure-of-arity callback 0 '(set-callback! )) + (set-gtk-button-clicked-callback! + object (lambda (button) (declare (ignore button)) (callback)))) + +(define-method set-callback! ((object ) callback) + (guarantee-procedure-of-arity callback 0 '(set-callback! )) + (set-swat-checkbutton-swat-callback! object callback)) + +(define-method set-callback! ((object rtd:active-variable) callback) + (guarantee-procedure-of-arity callback 1 '(set-callback! active-variable)) + (set-active-variable-callback! object callback)) + +;;; * uitk +;;; +;;; Geometry, Events, Contexts, rectangle=, UIObj-protect-from-gc!... + +#;(define (create-default-context name display) + name display + unspecific) + +(define (on-death! object reason thunk) + (let ((old (swat-widget-on-death object))) + (if old (warn "Swat-widget already has an on-death! callback:" + object reason thunk old))) + (set-swat-widget-on-death! object (cons reason thunk))) + +;;; * xlibCONSTANTS +;;; +;;; xlib constants: enums, masks, + +;;; * mit-xlib +;;; +;;; The SCXL library for interfacing with X. E.g. XClearArea, +;;; initialize-scxl!. + +;;; * tk-mit +;;; +;;; tk-init, %tkKillApplication, TK Callback handling. + +;;; * mit-xhooks +;;; +;;; UITK main loop, make-uitk-thread, when-idle, after-delay, +;;; ClearArea, initialize-uitk!. + +(define (after-delay seconds thunk) + (guarantee-index-fixnum seconds 'after-delay) + (guarantee-procedure-of-arity thunk 0 'after-delay) + (create-thread + #f + (lambda () + (trace ";after-delay "seconds", sleeping "(current-thread)"\n") + (sleep-current-thread (* seconds 1000)) + (thunk) + (stop-current-thread)))) + +;;; * widget-mit +;;; +;;; tk-make-menu, initialize-mit-widgets!. + +;;; * baseobj +;;; +;;; Basic objects for the Scheme User Interface Tool Kit. +;;; E.g. make-application, swat-open, swat-close. + +(define (swat-open . options) + (let loop ((options options) + (objects '())) + (if (pair? options) + (if (eq? '-title (car options)) + (if (and (pair? (cdr options)) (string? (cadr options))) + (let ((window (%open (reverse! objects) (cadr options)))) + (cons window (loop (cddr options) '()))) + (error "No title after -title keyword:" options)) + (loop (cdr options) (cons (car options) objects))) + (if (null? objects) + '() + (list (%open (reverse! objects) "SWAT")))))) + +(define (%open children title) + (let ((window (gtk-window-new 'toplevel)) + (box (gtk-hbox-new #f 5))) + (for-each (lambda (child) (gtk-container-add box child)) children) + (gtk-window-set-title window title) + (gtk-container-add window box) + (gtk-widget-show-all window) + window)) + +(define (swat-close child) + (let ((parent (gtk-widget-parent child))) + (if parent (swat-close parent) + (if (gtk-window? child) + (gtk-object-destroy child) + (error "unexpected top-level widget" child))))) + +;;; * widget +;;; +;;; TkWidget-add-event-handler!, TkWidget-ask-widget, make-listbox, +;;; make-active-variable, initialize-widgets!. + +(define (make-button #!optional options) + (let ((button (make-swat-button))) + (if (not (default-object? options)) + (widget-configure! button options)) + button)) + +(define (make-label #!optional options) + (let ((label (make-swat-label))) + (if (not (default-object? options)) + (widget-configure! label options)) + label)) + +(define (make-checkbutton options) + (let ((button (make-swat-checkbutton))) + (set-gtk-check-button-toggled-callback! button checkbutton-toggled-callback) + (let ((active (find-option options '-variable #f))) + (if active + (begin + (set-swat-checkbutton-swat-variable! button active) + (set-active-variable-frob! + active (make-checkbutton-frobbery button))))) + (widget-configure! button (delete-option! '-variable options)) + button)) + +(define (make-checkbutton-frobbery button) + (named-lambda (checkbutton-frobbery value) + (trace ";checkbutton-frobbery: setting "button" to "value"\n") + (gtk-check-button-set-active button value))) + +(define (checkbutton-toggled-callback button) + (let ((variable (swat-checkbutton-swat-variable button)) + (callback (swat-checkbutton-swat-callback button))) + (if (or variable callback) + (let ((state (gtk-check-button-get-active button))) + (if variable + (begin + (trace ";checkbutton-toggled-callback:" + " setting "variable" to "state" for "button"\n") + (frob-active-variable! variable state))) + (if callback + (begin + (trace ";checkbutton-toggled-callback:" + " calling "callback" for "button"\n") + (callback)))) + (trace ";checkbutton-toggled-callback: noop\n")))) + +(define (checkbutton-variable-on? active) + (active-variable-value active)) + +;;; * geometry +;;; +;;; make-hbox, make-array-box. + +(define (make-hbox . kids) + (let ((box (gtk-hbox-new #f 0))) + (for-each (lambda (kid) (gtk-container-add box kid)) kids) + box)) + +(define (make-vbox . kids) + (let ((box (gtk-vbox-new #f 0))) + (for-each (lambda (kid) (gtk-container-add box kid)) kids) + box)) + +(define (box-children box) + (gtk-container-children box)) + +;;; * simple +;;; +;;; make-shape, make-rect, make-oval, make-line. + +;;; * canvas +;;; +;;; make-scrollable-canvas, ..., make-bitmap-on-canvas... + +(define (make-canvas options) + (let ((width (find-option options '-width #f)) + (height (find-option options '-height #f))) + (let ((canvas (make-swat-canvas width height))) + (trace ";(make-canvas "options") configuring "canvas"\n") + (widget-configure! canvas (delete-options! '(-width -height) options)) + (trace ";(make-canvas "options") => "canvas"\n") + canvas))) + +(define (make-canvas-item-group canvas items) + (let ((group (make-swat-group))) + (fix-drawing-add-ink! (fix-layout-drawing canvas) group) + (for-each (lambda (item) (group-add! group item)) items) + group)) + +(define (delete-all! canvas) + (let ((drawing (fix-layout-drawing canvas))) + (for-each fix-ink-remove! (fix-drawing-display-list drawing)))) + +(define (make-line-on-canvas canvas x1 y1 x2 y2) + (guarantee-fixnum x1 'make-line-on-canvas) + (guarantee-fixnum y1 'make-line-on-canvas) + (guarantee-fixnum x2 'make-line-on-canvas) + (guarantee-fixnum y2 'make-line-on-canvas) + (let ((item (make-swat-line))) + (set-line-ink! item x1 y1 x2 y2) + (fix-drawing-add-ink! (fix-layout-drawing canvas) item) + item)) + +(define (make-rectangle-on-canvas canvas x y width height) + (guarantee-fixnum x 'make-rectangle-on-canvas) + (guarantee-fixnum y 'make-rectangle-on-canvas) + (guarantee-positive-fixnum width 'make-rectangle-on-canvas) + (guarantee-positive-fixnum height 'make-rectangle-on-canvas) + (let ((item (make-swat-rectangle))) + (set-rectangle-ink! item x y width height) + (fix-drawing-add-ink! (fix-layout-drawing canvas) item) + item)) + +(define (make-oval-on-canvas canvas x1 y1 x2 y2) + (guarantee-fixnum x1 'make-oval-on-canvas) + (guarantee-fixnum y1 'make-oval-on-canvas) + (guarantee-fixnum x2 'make-oval-on-canvas) + (guarantee-fixnum y2 'make-oval-on-canvas) + (let ((x (fix:min x1 x2)) + (y (fix:min y1 y2)) + (width (fix:abs (fix:- x2 x1))) + (height (fix:abs (fix:- y2 y1))) + (item (make-swat-oval))) + (set-arc-ink! item x y width height) + (set-arc-ink-start-angle! item 0) + (set-arc-ink-sweep-angle! item 360) + (fix-drawing-add-ink! (fix-layout-drawing canvas) item) + item)) + +(define (make-text-on-canvas canvas x y options) + (let ((text (find-option options '-text "")) + (anchor (find-option options '-anchor 'center)) + (ink (make-swat-text))) + (guarantee-string text 'make-text-on-canvas) + (set-simple-text-ink-text! ink canvas text) + (set-text-ink-position! ink x y) + (set-swat-text-anchor! ink anchor) + (fix-drawing-add-ink! (fix-layout-drawing canvas) ink) + (item-configure! ink (delete-options! '(-text -anchor) options)) + ink)) + +;;; * menu +;;; +;;; find-menu-record, delete-menuitem! add-to-menu. + +;;; * text +;;; +;;; make-scrollable-text, make-text-tag, texttag-add-event-handler! + +(define (find-option options name default) + (let loop ((opts options)) + (if (pair? opts) + (if (eq? (car opts) name) + (cadr opts) + (loop (cddr opts)) + ;; If multiple values can follow an option keyword: + #;(let collect ((opts (cdr opts)) + (sgra '())) + (if (or (null? opts) + (and (symbol? (car opts)) + (char=? #\- + (string-ref (symbol-name (car opts)) 0)))) + ;; Return a list only if multiple values followed. + (if (and (not (null? sgra)) + (null? (cdr sgra))) + (car sgra) + (reverse! sgra)) + (collect (cdr opts) (cons (car opts) sgra)))) + ) + default))) + +(define (option-names options) + (let loop ((opts options)) + (if (null? opts) + '() + (cons (car opts) (loop (cddr opts)))))) + +(define (delete-options! names options) + (let loop ((names names) + (options options)) + (if (pair? names) + (loop (cdr names) + (delete-option! (car names) options)) + options))) + +(define (delete-option! name options) + + (define (trim options) + (if (pair? options) + (if (eq? (car options) name) + (cddr options) + (begin + (splice! (cdr options) (cddr options)) + options)) + '())) + + (define (splice! previous options) + (if (pair? options) + (if (eq? name (car options)) + (set-cdr! previous (cddr options)) + (splice! (cdr options) (cddr options))))) + + (trim options)) + +(define trace? #f) + +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(define trace2? #f) + +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) + +(initialize-package!) \ No newline at end of file diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 3b35fc1ce..c9aefac23 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -32,6 +32,11 @@ USA. ;;; should no longer use wait-for-io, nor need to signal ;;; condition-type:no-thread! +;;; Note that GC daemons cannot be allowed to run during a callback. +;;; After-gc interrupts are currently serviced with +;;; interrupt-mask/timer-ok!, which might allow a switch to a +;;; different thread, which might return from a different callback. + (define (create-gtk-thread) (if gtk-thread (error "A GTk thread already exists.")) (set! gtk-thread @@ -49,7 +54,10 @@ USA. (set! done-tick gc-tick)))))) (without-interrupts (lambda () - (let ((time (time-limit self))) + (let ((time (if (thread/next self) + 0 + (or next-scheduled-timeout + (no-threads-nor-timers))))) (trace ";run-gtk until "time"\n") ((ucode-primitive run-gtk 2) (select-registry-handle io-registry) time) @@ -58,15 +66,8 @@ USA. (yield-current-thread) (gtk-thread-loop))))))) -(define (time-limit self) - (if (thread/next self) - 0 - (if (integer? next-scheduled-timeout) - next-scheduled-timeout - (begin - (outf-console - "\n;Warning: bogus timeout: "next-scheduled-timeout"\n") - (+ (real-time-clock) 1000))))) +(define (no-threads-nor-timers) + (error "gtk-thread: no threads, no timers: "next-scheduled-timeout)) (define (kill-gtk-thread) (let ((thread gtk-thread)) diff --git a/src/microcode/achost.ac b/src/microcode/achost.ac index f61ea2ad9..019fd797e 100644 --- a/src/microcode/achost.ac +++ b/src/microcode/achost.ac @@ -217,3 +217,28 @@ if test "${DO_GCC_TESTS}" = yes; then ], [AC_MSG_RESULT([no])]) fi + +AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) +AC_MSG_CHECKING([for gtk]) +if test "${with_gtk}" = "yes"; then + AC_MSG_RESULT([by request: yes]) +fi +if test "${with_gtk}" = "auto"; then + if test "${PKG_CONFIG}" != yes; then + AC_MSG_RESULT([no pkg-config: no]) + with_gtk=no + elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \ + /dev/null 2>&1; then + AC_MSG_RESULT([no FFI in ${MIT_SCHEME_EXE}: no]) + with_gtk=no + elif ! pkg-config --exists gtk+-2.0; then + AC_MSG_RESULT([! pkg-config --exists gtk+-2.0: no]) + with_gtk=no + else + AC_MSG_RESULT([yes]) + with_gtk=yes + fi +fi +if test "${with_gtk}" = "yes"; then + MODULE_TARGETS="${MODULE_TARGETS} prgtkio.so" +fi diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index ff59d0b06..a9654c073 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -795,21 +795,6 @@ if test ${enable_valgrind_mode} != no; then M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1" fi -AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) -if test ${with_gtk} = yes; then - AC_MSG_CHECKING([for gtk]) - if test "${PKG_CONFIG}" != yes; then - AC_MSG_RESULT([no, no pkg-config]) - else - if pkg-config --exists gtk+-2.0; then - AC_MSG_RESULT([yes]) - MODULE_TARGETS="${MODULE_TARGETS} prgtkio.so" - else - AC_MSG_RESULT([no, ! pkg-config --exists gtk+-2.0]) - fi - fi -fi - OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl" case ${mit_scheme_native_code} in diff --git a/src/microcode/prgtkio.c b/src/microcode/prgtkio.c index 8e50cc82e..11a84501d 100644 --- a/src/microcode/prgtkio.c +++ b/src/microcode/prgtkio.c @@ -31,7 +31,6 @@ USA. #include "osenv.h" #include "ux.h" #include "uxio.h" -#include "uxselect.h" #include "uxproc.h" #include diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 2ab9c878d..5e5fada3b 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -140,26 +140,24 @@ USA. (set-%alien/ctype! alien ctype)) alien) -(define (guarantee-alien operator object #!optional ctype) - (let loop ((object object)) - (if (and (alien? object) - (or (default-object? ctype) - (equal? (%alien/ctype object) ctype))) - object - (loop - (call-with-current-continuation - (lambda (continuation) - (with-restart - 'USE-VALUE ;name - "Continue with an alien." ;reporter - continuation ;effector - (lambda () ;interactor - (values - (prompt-for-evaluated-expression - "New alien (an expression to be evaluated)"))) - (lambda () ;thunk - (error:wrong-type-argument - object "an alien" operator))))))))) +(declare (integrate-operator guarantee-alien)) +(define (guarantee-alien object operator) + (if (not (alien? object)) + (error:not-alien object operator))) + +(define (error:not-alien object operator) + (call-with-current-continuation + (lambda (continuation) + (with-restart + 'USE-VALUE ;name + "Continue with an alien." ;reporter + continuation ;effector + (lambda () ;interactor + (values + (prompt-for-evaluated-expression + "New alien (an expression to be evaluated)"))) + (lambda () ;thunk + (error:wrong-type-argument object "an alien" operator)))))) ;;; Alien Functions @@ -198,6 +196,14 @@ USA. ;; Band ID band-id) +(declare (integrate-operator guarantee-alien-function)) +(define (guarantee-alien-function object operator) + (if (not (alien-function? object)) + (error:not-alien-function object operator))) + +(define (error:not-alien-function object operator) + (error:wrong-type-argument object "an alien function" operator)) + (define (make-alien-function name library return-type params filename) (%make-alien-function 0 0 (string-append "Scm_" name) library return-type params filename #f)) @@ -281,8 +287,7 @@ USA. (loop (cdr consts))))))) (define (call-alien alien-function . args) - (if (not (alien-function? alien-function)) - (error:bad-range-argument alien-function 'call-alien)) + (guarantee-alien-function alien-function 'call-alien) (alien-function-cache! alien-function) (for-each (lambda (arg) @@ -313,6 +318,7 @@ USA. (define malloced-aliens '()) (define (free-malloced-aliens) + (trace ";free-malloced-aliens: "(length malloced-aliens)" at start\n") (let loop ((aliens malloced-aliens) (prev #f)) (if (pair? aliens) @@ -327,7 +333,8 @@ USA. (begin ((ucode-primitive c-free 1) copy) (alien-null! copy))) - (loop next prev)))))) + (loop next prev))))) + (trace ";free-malloced-aliens: "(length malloced-aliens)" at end\n")) (define (reset-malloced-aliens!) (let loop ((aliens malloced-aliens)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e142f2dd7..68c51f2ec 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -558,6 +558,21 @@ USA. queue-map! queue->list)) +(define-package (runtime thread-queue) + (files "thread-queue") + (parent (runtime)) + (export () + make-thread-queue + thread-queue/empty? + thread-queue/empty! + thread-queue/queue! + thread-queue/queue-no-hang! + thread-queue/push! + thread-queue/dequeue! + thread-queue/peek-no-hang + thread-queue/peek-until + thread-queue/peek)) + (define-package (runtime simple-file-ops) (files "sfile") (parent (runtime)) @@ -3242,6 +3257,9 @@ USA. alien-byte-increment alien-byte-increment! guarantee-alien + error:not-alien + guarantee-alien-function + error:not-alien-function c-peek-cstring c-peek-cstring! c-peek-cstringp diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm new file mode 100644 index 000000000..b9ffa9945 --- /dev/null +++ b/src/runtime/thread-queue.scm @@ -0,0 +1,268 @@ +#| -*-Scheme-*- + +Copyright (C) 2005, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Thread-blocking Queues +;;; package: (runtime thread-queue) + +(declare (usual-integrations)) + +;;; These queues are like the simple queues provided by the (runtime +;;; simple-queue) package, EXCEPT that they will, when empty, block a +;;; thread attempting to dequeue an item. Also, a maximum size can be +;;; specified so that the queue will, when full, block a thread +;;; attempting to queue an item. Note that #F should not be used as +;;; an item. Thread-queue/peek-no-hang returns #F if the queue is +;;; empty. +;;; +;;; If multiple threads block on a thread-queue, bad mojo is afoot. +;;; They are ALL restarted whenever an item becomes available and, +;;; depending on the thread timer interrupts, ANY ONE of them may be +;;; able to dequeue the item. + +(define-structure (thread-queue (constructor %make-thread-queue) + (conc-name %thread-queue/) + (print-procedure + (standard-unparser-method + 'thread-queue + (lambda (queue port) + (print-thread-queue queue port))))) + first-pair + last-pair + element-count + max-elements + waiting-queuers + waiting-dequeuers) + +(define-guarantee thread-queue "a thread-queue") + +(define (print-thread-queue queue port) + (write-string " elements:" port) + (write-string (number->string + (%thread-queue/element-count queue)) port) + (let ((max (%thread-queue/max-elements queue))) + (if max + (begin + (write-string " max:" port) + (write-string (number->string max) port))))) + +(define (make-thread-queue #!optional max-size) + (let ((max (cond ((default-object? max-size) #f) + ((integer? max-size) max-size) + (else (error "Max-size must be an integer:" max-size))))) + (%make-thread-queue #f #f 0 max '() '()))) + +(define (thread-queue/empty? queue) + (%empty? queue)) + +(define-integrable (%empty? queue) + (zero? (%thread-queue/element-count queue))) + +(define (thread-queue/empty! queue) + (without-interrupts + (lambda () + (if (not (%empty? queue)) + (begin + (set-%thread-queue/first-pair! queue #f) + (set-%thread-queue/last-pair! queue #f) + (set-%thread-queue/element-count! queue 0) + (%resume-queuers queue))))) + unspecific) + +(define (thread-queue/queue! queue item) + (if (not item) (error "Cannot queue #F:" queue)) + (without-interrupts + (lambda () + (do () + ((%queue-no-hang! queue item)) + (set-%thread-queue/waiting-queuers! + queue (append! (%thread-queue/waiting-queuers queue) + (list (current-thread)))) + (suspend-current-thread))))) + +(define (thread-queue/queue-no-hang! queue item) + ;; Returns #F when QUEUE is maxed out. + (if (not item) (error "Cannot queue #F:" queue)) + (without-interrupts + (lambda () + (%queue-no-hang! queue item)))) + +(define (%queue-no-hang! queue item) + (let ((max (%thread-queue/max-elements queue))) + (if max + (if (< (%thread-queue/element-count queue) max) + (%queue! queue item) + #f) + (%queue! queue item)))) + +(define (thread-queue/dequeue! queue) + (without-interrupts + (lambda () + (do () + ((and (not (%empty? queue)) + (%dequeue! queue))) + (set-%thread-queue/waiting-dequeuers! + queue (append! (%thread-queue/waiting-dequeuers queue) + (list (current-thread)))) + (suspend-current-thread))))) + +(define (thread-queue/peek-no-hang queue #!optional timeout) + (guarantee-thread-queue queue 'thread-queue/peek-no-hang) + (if (not (default-object? timeout)) + (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang)) + (let ((timeout (if (default-object? timeout) 0 timeout)) + (time (real-time-clock))) + (thread-queue/peek-until queue (+ time timeout)))) + +(define (thread-queue/peek-until queue time) + (guarantee-thread-queue queue 'thread-queue/peek-until) + (guarantee-integer time 'thread-queue/peek-until) + (without-interrupts + (lambda () + (let loop () + (if (not (%empty? queue)) + (car (%thread-queue/first-pair queue)) + (let ((now (real-time-clock))) + (if (<= time now) + #f + (begin + (register-timer-event (- time now) (lambda () unspecific)) + (suspend-current-thread) + (loop))))))))) + +(define (thread-queue/peek queue) + (without-interrupts + (lambda () + (do () + ((and (not (%empty? queue)) + (car (%thread-queue/first-pair queue)))) + (set-%thread-queue/waiting-dequeuers! + queue (append! (%thread-queue/waiting-dequeuers queue) + (list (current-thread)))) + (suspend-current-thread))))) + + +(define (%queue! queue item) + (let ((last (%thread-queue/last-pair queue)) + (new (cons item '()))) + (if last (set-cdr! last new)) + (set-%thread-queue/last-pair! queue new) + (if (not (%thread-queue/first-pair queue)) + (set-%thread-queue/first-pair! queue new))) + (set-%thread-queue/element-count! + queue (1+ (%thread-queue/element-count queue))) + (%resume-dequeuers queue) + item) + +(define (%dequeue! queue) + (let* ((first (%thread-queue/first-pair queue)) + (item (car first))) + (if (eq? first (%thread-queue/last-pair queue)) + (begin + (set-%thread-queue/first-pair! queue #f) + (set-%thread-queue/last-pair! queue #f)) + (set-%thread-queue/first-pair! queue (cdr first))) + (set-%thread-queue/element-count! + queue (-1+ (%thread-queue/element-count queue))) + (%resume-queuers queue) + item)) + +(define (%resume-queuers queue) + (do ((queuers (%thread-queue/waiting-queuers queue) + (cdr queuers))) + ((null? queuers) + unspecific) + (signal-thread-event (car queuers) (lambda () unspecific))) + (set-%thread-queue/waiting-queuers! queue '())) + +(define (%resume-dequeuers queue) + (do ((dequeuers (%thread-queue/waiting-dequeuers queue) + (cdr dequeuers))) + ((null? dequeuers) + unspecific) + (signal-thread-event (car dequeuers) (lambda () unspecific))) + (set-%thread-queue/waiting-dequeuers! queue '())) + +(define (thread-queue/push! queue item) + ;; Place ITEM at the head of the queue, instead of the end. + (if (not item) (error "Cannot queue #F:" queue)) + (without-interrupts + (lambda () + (let ((max (%thread-queue/max-elements queue))) + (if max + (if (< (%thread-queue/element-count queue) max) + (%push! queue item) + (let ((last (%thread-queue/last-pair queue)) + (first (%thread-queue/first-pair queue))) + (let ((new-last + (let before-last ((list first)) + ;; Assume LIST is always a pair, thus that + ;; max > 0, and LAST is in FIRST. + (if (eq? (cdr list) last) + list + (before-last (cdr list)))))) + (set-cdr! new-last '()) + (set-%thread-queue/last-pair! queue new-last) + (set-car! last item) ;Clobber most recently queued item! + (set-cdr! last first) + (set-%thread-queue/first-pair! queue last)) + item)) + (%push! queue item)))))) + +(define (%push! queue item) + (let* ((first (%thread-queue/first-pair queue)) + (new (cons item first))) + (set-%thread-queue/first-pair! queue new) + (if (not (%thread-queue/last-pair queue)) + (set-%thread-queue/last-pair! queue new)) + (set-%thread-queue/element-count! queue + (1+ (%thread-queue/element-count queue))) + (%resume-dequeuers queue) + item)) + +(define (test) + ;; Sets up a "producer" thread that puts the letters of the alphabet + ;; into a thread-queue, one each 2-3 seconds. A "consumer" thread + ;; waits on the queue, printing what it reads. + (outf-console ";Thread Queue Test\n") + (let ((queue (make-thread-queue))) + (create-thread + #f + (lambda () + (outf-console "; Consumer: "(current-thread)"\n") + (let loop () + (outf-console "; Consumer reads.\n") + (let ((item (thread-queue/dequeue! queue))) + (outf-console "; Consumer read "item"\n") + (loop))))) + (create-thread + #f + (lambda () + (outf-console "; Producer: "(current-thread)"\n") + (for-each (lambda (item) + (outf-console "; Producer: sleeping...\n") + (sleep-current-thread 2000) + (outf-console "; Producer: queuing "item"...\n") + (thread-queue/queue! queue item) + (outf-console "; Producer: queued "item"\n")) + '(#\a #\b #\c #\d #\e)) + (outf-console "; Producer done.\n"))))) \ No newline at end of file diff --git a/src/sf/butils.scm b/src/sf/butils.scm index 62285591c..cfcef7df1 100644 --- a/src/sf/butils.scm +++ b/src/sf/butils.scm @@ -134,6 +134,73 @@ USA. (write-char #\space) (write (enough-namestring reason))) reasons))) + (let ((com (pathname-new-type file "com")) + (bci (pathname-new-type file "bci"))) + (if (file-exists? com) (delete-file com)) + (if (file-exists? bci) (delete-file bci))) (fluid-let ((sf/default-syntax-table env)) - (sf file)))))) - (if (pair? sources) sources (list sources))))) \ No newline at end of file + (sf file)) + #t) + #f))) + (if (pair? sources) sources (list sources))))) + +(define (sf-package-set filename) + (let* ((os-type microcode-id/operating-system) + (pmodel (read-package-model filename os-type)) + (pathname (pmodel/pathname pmodel))) + + (define (environment file) + (->environment + (let loop ((cps (pmodel/cref-packages pmodel))) + (if (pair? cps) + (if (find (lambda (f) (pathname=? f file)) + (cref-package/files (car cps))) + (cref-package/name (car cps)) + (loop (cdr cps))) + (error "No cref-package for file:" file))))) + + (define (dependencies file) + (cref-package/depends-on + (find (lambda (p) + (find (lambda (f) (pathname=? f file)) (cref-package/files p))) + (pmodel/cref-packages pmodel)))) + + (let ((pmodel-decls (pmodel/declarations pmodel))) + (with-working-directory-pathname (directory-pathname pathname) + (lambda () + + (define (deps->decls deps) + (let ((decls + (append-map! + (lambda (dep) + (if (equal? "ext" (pathname-type dep)) + `((integrate-external ,(pathname-new-type dep #f))) + '())) + deps))) + (append pmodel-decls decls))) + + (define (process-file file) + (let ((deps (dependencies file)) + (env (environment file))) + (fluid-let ((sf/default-declarations + (append (deps->decls deps) sf/default-declarations))) + (sf-with-dependencies file deps env) + (load file env)))) + + (define (make-packages) + (let ((existing + (let loop ((packages (pmodel/cref-packages pmodel))) + (if (pair? packages) + (or (name->package (cref-package/name (car packages))) + (loop (cdr packages))) + #f)))) + (if existing + (warn "Package already exists:" (package/name existing)) + ;; Build an empty package for use at syntax-time. + (construct-packages-from-file + (construct-external-descriptions pmodel))))) + + (make-packages) + (for-each process-file + (append-map cref-package/files + (pmodel/cref-packages pmodel)))))))) \ No newline at end of file diff --git a/src/sf/make.scm b/src/sf/make.scm index f1d6b2681..a9db29e38 100644 --- a/src/sf/make.scm +++ b/src/sf/make.scm @@ -27,6 +27,7 @@ USA. (declare (usual-integrations)) +(load-option 'CREF) (with-loader-base-uri (system-library-uri "sf/") (lambda () (load-package-set "sf") diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index 8660c2bc7..d6fe75d06 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -26,6 +26,7 @@ USA. ;;;; SF Packaging (global-definitions "../runtime/runtime") +(global-definitions "../cref/cref") (define-package (scode-optimizer) (files "pthmap" @@ -175,10 +176,20 @@ USA. (define-package (scode-optimizer build-utilities) (files "butils") (parent ()) + (import (cross-reference) + construct-external-descriptions + (cref-package/depends-on package/depends-on) + (cref-package/files package/files) + (cref-package/name package/name) + (pmodel/cref-packages pmodel/packages) + pmodel/declarations + pmodel/pathname + read-package-model) (export () compile-directory compile-directory? sf-conditionally sf-with-dependencies sf-directory - sf-directory?)) \ No newline at end of file + sf-directory? + sf-package-set)) \ No newline at end of file -- 2.25.1