Commit 20082d48 authored by Erick's avatar Erick

Big cleaning

parent 8d61b852
......@@ -2,11 +2,11 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 3-May-2008 19:58 (eg)
# Last file update: 26-Sep-2009 00:31 (eg)
EXTRA_DIST =
SUBDIRS = @PCRE@ @GC@ @GMP@ @LIBFFI@ src utils lib @GTKLOS@ \
@EXAMPLES@ pkgman extensions tests doc
SUBDIRS = @PCRE@ @GC@ @GMP@ @LIBFFI@ src utils lib \
examples pkgman tests doc
SVN_URL = @SVN_URL@/STklos
VERSION_TAG = @PACKAGE@-@VERSION@
VERSION_BETA = $(VERSION_TAG)-beta
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -2,7 +2,7 @@ dnl configure.in for STklos
dnl
dnl Author: Erick Gallesio [eg@unice.fr]
dnl Creation date: 28-Dec-1999 21:19 (eg)
dnl Last file update: 18-May-2008 22:28 (eg)
dnl Last file update: 26-Sep-2009 00:32 (eg)
AC_INIT(src/stklos.c)
......@@ -228,42 +228,42 @@ fi
# HAVE_LDAP="undef" && LDAP_LIB="")
dnl
dnl GTK support
dnl
AC_ARG_ENABLE(gtk,
[ --disable-gtk disable gtk support],
USE_GTK="no", USE_GTK="yes")
AC_PATH_PROG(GTK_CONFIG, gtk-config, "no")
AC_ARG_WITH(gtk-config,
[ --with-gtk-config=<path> full pathname of gtk-config script],
GTK_CONFIG=$withval)
if test "$GTK_CONFIG" = "no" ;then
USE_GTK=no
fi
dnl
dnl GNOME support
dnl
AC_ARG_ENABLE(gnome,
[ --disable-gnome disable gnome support],
USE_GNOME="no", USE_GNOME="yes")
AC_PATH_PROG(GNOME_CONFIG, gnome-config, "no")
AC_ARG_WITH(gnome-config,
[ --with-gnome-config=<path> full pathname of gnome-config script],
GNOME_CONFIG=$withval)
if test "$GNOME_CONFIG" = "no" ;then
USE_GNOME=no
fi
#1.0
#1.0 dnl
#1.0 dnl GTK support
#1.0 dnl
#1.0 AC_ARG_ENABLE(gtk,
#1.0 [ --disable-gtk disable gtk support],
#1.0 USE_GTK="no", USE_GTK="yes")
#1.0
#1.0 AC_PATH_PROG(GTK_CONFIG, gtk-config, "no")
#1.0
#1.0 AC_ARG_WITH(gtk-config,
#1.0 [ --with-gtk-config=<path> full pathname of gtk-config script],
#1.0 GTK_CONFIG=$withval)
#1.0
#1.0 if test "$GTK_CONFIG" = "no" ;then
#1.0 USE_GTK=no
#1.0 fi
#1.0
#1.0
#1.0 dnl
#1.0 dnl GNOME support
#1.0 dnl
#1.0 AC_ARG_ENABLE(gnome,
#1.0 [ --disable-gnome disable gnome support],
#1.0 USE_GNOME="no", USE_GNOME="yes")
#1.0
#1.0
#1.0 AC_PATH_PROG(GNOME_CONFIG, gnome-config, "no")
#1.0
#1.0 AC_ARG_WITH(gnome-config,
#1.0 [ --with-gnome-config=<path> full pathname of gnome-config script],
#1.0 GNOME_CONFIG=$withval)
#1.0
#1.0 if test "$GNOME_CONFIG" = "no" ;then
#1.0 USE_GNOME=no
#1.0 fi
dnl Checks for typedefs, structures, and compiler characteristics.
AC_C_INLINE
......@@ -446,34 +446,34 @@ OS_NAME=$OS
dnl Place version number in VERSION file
dnl echo "VERSION=${VERSION}">VERSION
dnl GTK+/GNOME support
HAVE_GNOME="undef"
if test "$USE_GTK" = "no" ;then
USE_GNOME="no"
fi
if test "$USE_GTK" = "yes"
then
GTKLOS=gtklos
EXAMPLES="examples examples/images"
if test "$USE_GNOME" = "yes"
then
HAVE_GNOME="define"
GTK_CONFIG_LIBS=`$GNOME_CONFIG --libs gnomecanvaspixbuf`
GTK_CONFIG_CFLAGS=`$GNOME_CONFIG --cflags gnomeui gnomecanvaspixbuf`
else
GTK_CONFIG_LIBS=`$GTK_CONFIG --libs`
GTK_CONFIG_CFLAGS=`$GTK_CONFIG --cflags`
fi
else
GTKLOS=
EXAMPLES=
GTK_CONFIG_LIBS=
GTK_CONFIG_CFLAGS=
fi
#1.0 dnl GTK+/GNOME support
#1.0 HAVE_GNOME="undef"
#1.0
#1.0 if test "$USE_GTK" = "no" ;then
#1.0 USE_GNOME="no"
#1.0 fi
#1.0
#1.0
#1.0 if test "$USE_GTK" = "yes"
#1.0 then
#1.0 GTKLOS=gtklos
#1.0 EXAMPLES="examples examples/images"
#1.0
#1.0 if test "$USE_GNOME" = "yes"
#1.0 then
#1.0 HAVE_GNOME="define"
#1.0 GTK_CONFIG_LIBS=`$GNOME_CONFIG --libs gnomecanvaspixbuf`
#1.0 GTK_CONFIG_CFLAGS=`$GNOME_CONFIG --cflags gnomeui gnomecanvaspixbuf`
#1.0 else
#1.0 GTK_CONFIG_LIBS=`$GTK_CONFIG --libs`
#1.0 GTK_CONFIG_CFLAGS=`$GTK_CONFIG --cflags`
#1.0 fi
#1.0 else
#1.0 GTKLOS=
#1.0 EXAMPLES=
#1.0 GTK_CONFIG_LIBS=
#1.0 GTK_CONFIG_CFLAGS=
#1.0 fi
dnl
dnl display some informations for the user
......@@ -540,10 +540,10 @@ AC_SUBST(SH_MAIN_LOAD_FLAGS)
AC_SUBST(COMPOBJ)
AC_SUBST(COMPSRC)
AC_SUBST(STACK_DIRECTION)
AC_SUBST(GTKLOS)
AC_SUBST(GTK_CONFIG_LIBS)
AC_SUBST(GTK_CONFIG_CFLAGS)
AC_SUBST(EXAMPLES)
#1.0 AC_SUBST(GTKLOS)
#1.0 AC_SUBST(GTK_CONFIG_LIBS)
#1.0 AC_SUBST(GTK_CONFIG_CFLAGS)
#1.0 AC_SUBST(EXAMPLES)
AC_SUBST(HAVE_GNOME)
AC_SUBST(HAVE_LDAP)
AC_SUBST(LDAP_LIB)
......@@ -559,14 +559,11 @@ AC_SUBST(CALLCC_STK)
AC_SUBST(LIBFFI)
AC_OUTPUT(Makefile src/Makefile src/extraconf.h doc/Makefile
lib/Makefile gtklos/Makefile gtklos/gtklosconf.h
utils/Makefile lib/boot-callcc.stk
lib/Makefile utils/Makefile lib/boot-callcc.stk
utils/stklos-config utils/stklos-script
extensions/Makefile examples/Makefile
examples/images/Makefile lib/Match.d/Makefile
examples/Makefile lib/Match.d/Makefile
lib/SILex.d/Makefile lib/Lalr.d/Makefile lib/Lurc.d/Makefile
lib/ScmPkg.d/Makefile
tests/Makefile extensions/extconf.h
lib/ScmPkg.d/Makefile tests/Makefile
doc/stklos.1 doc/stklos-config.1 doc/stklos-compile.1
doc/stklos-genlex.1 doc/stklos-install.1 doc/stklos-pkg.1
doc/skb/stklos-version.stk
......@@ -586,9 +583,9 @@ echo " Compilation flags: " $CFLAGS
echo " Bignum library: " $biglib
echo " Regexp library: " $pcrelib
echo " GC library: " $gclib
echo " LDAP support: " $USE_LDAP
echo " GTK+ support: " $USE_GTK
echo " GNOME support: " $USE_GNOME
#1.0 echo " LDAP support: " $USE_LDAP
#1.0 echo " GTK+ support: " $USE_GTK
#1.0 echo " GNOME support: " $USE_GNOME
echo " FFI support: " $FFI
echo " Thread support: " $THREADS
echo " "
......
This diff is collapsed.
schemedemodir = $(prefix)/share/@PACKAGE@/@VERSION@/Demos.d
schemedemo_DATA = button.stk canvas.stk checkbutton.stk \
colorselector.stk combobox.stk dialog.stk \
entry1.stk entry2.stk event.stk \
fileselector.stk fontselector.stk frame.stk \
gauge.stk grid1.stk grid1 grid2.stk gtklos-demo.stk \
handle.stk image1.stk image2.stk label.stk listbox.stk \
menu.stk radiobutton.stk scale.stk sedit.stk \
scroll1.stk scroll2.stk text.stk toolbar.stk \
\
schemedemo_DATA = fork-test.stk hello.stk secho.stk \
socket-server.stk socket-client.stk
schemedemo_SCRIPTS = button canvas checkbutton colorselector combobox dialog \
entry1 entry2 event fileselector fontselector frame \
gauge grid1 grid2 handle image1 image2 label listbox \
menu radiobutton scale sedit scroll1 scroll2 text \
toolbar \
\
fork-test socket-server socket-client
schemedemo_SCRIPTS = fork-test hello secho \
socket-server socket-client
SUFFIXES = .stk
......
This diff is collapsed.
;;;;
;;;; button.stk -- GTK demo using buttons
;;;;
;;;; Copyright © 2001 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 24-Jul-2001 16:31 (eg)
;;;; Last file update: 26-Nov-2001 22:14 (eg)
;;;;
(include "gtklos-demo.stk")
(define (main args)
(let* ((win (make <demo-window> :title "Buttons Demo" :x 100 :y 100
:file "button" :border-width 5
:message "
This is a demo showing a bunch of buttons with various reliefs.
The last button show a button with an associated tool-tip.
Note that, depending of your current theme, difference between
various relief can be hardly visible.
"))
(b1 (make <button> :parent win :text "Normal" :border-width 5))
(b2 (make <button> :parent win :text "Half" :border-width 5
:relief 'half))
(b3 (make <button> :parent win :text "None" :border-width 5
:relief 'none))
(b4 (make <button> :parent win :text "Tooltip" :border-width 5
:tooltip (string-append "A long tool-tip using\n"
"several lines\n"
"..."))))
0))
;;;;
;;;; canvas.stk -- GTKlos Canvas Demo
;;;;
;;;; Copyright 2002-2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Feb-2002 10:57 (eg)
;;;; Last file update: 6-Jul-2003 11:23 (eg)
;;;;
(include "gtklos-demo.stk")
(define canvas-msg "
This is a demo of the GTklos Canvas Widget.
This is very incomplete for now.
Canvases will be fully implemented in a
next release.
")
(define (polish-diamond c)
(let ((vertices 10)
(radius 60.0)
(pi (* 4 (atan 1)))
(posx 100)
(posy 100))
(do ((i 0 (+ i 1)))
((>= i vertices))
(let* ((a (/ (* 2 pi i) vertices))
(x1 (+ posx (* radius (cos a))))
(y1 (+ posy (* radius (sin a)))))
(do ((j (+ i 1) (+ j 1)))
((>= j vertices))
(let* ((a (/ (* 2 pi j) vertices))
(x2 (+ posx (* radius (cos a))))
(y2 (+ posy (* radius (sin a)))))
(make <canvas-line> :parent c :points (list x1 y1 x2 y2))))))))
(define (main args)
(let* ((win (make <demo-window> :title "Canvas Demo" :x 100 :y 100
:file "canvas" :border-width 5
:padding 20 :message canvas-msg))
(c (make <canvas> :parent win))
(poly (make <canvas-polygon> :parent c
:points '(270 330 270 430 390 430 390
330 310 330 310 390 350 390
350 370 330 370 330 350 370
350 370 410 290 410 290 330)))
(rect (make <canvas-rectangle> :parent c :fill-color "Goldenrod"
:x1 200 :y1 200 :x2 300 :y2 300)))
(polish-diamond c)
rect))
;;;;
;;;; colorselector.stk -- GTK Color Selector Window
;;;;
;;;; Copyright © 2000-2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 6-Nov-2000 18:59 (eg)
;;;; Last file update: 16-Feb-2002 11:58 (eg)
;;;;
(include "gtklos-demo.stk")
(define color-msg "
This is a demo of the Color selector Widget.
The button \"Selector Dialog\" show how to use the
function make-color-selector-dialog for a modal
selection window.
")
(define (make-color initial-color)
(let ((r (make-color-selector-dialog :opacity #t :value initial-color)))
(if r
(format #t "You choose the color ~S\n" r)
(format #t "No color chosen\n"))))
(define (main args)
(let* ((win (make <demo-window> :title "Color Selector Demo" :x 100 :y 100
:file "colorselector" :border-width 5
:message color-msg))
(col (make <color-selector> :value #(128/255 2/3 0.5 0) :parent win))
(but (make <button> :text "Selector Dialog" :parent win
:command (lambda (e) (make-color (value col))))))
0))
;;;;
;;;; combobox.stk -- GTKlos combobox demo
;;;;
;;;; Copyright © 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Jan-2002 20:20 (eg)
;;;; Last file update: 13-Feb-2002 18:22 (eg)
;;;;
(include "gtklos-demo.stk")
(define msg "
This is a demonstration of the <combobox> widget.
Nothing very fancy here.
")
(define (main args)
(let* ((window (make <demo-window>
:title "STklos Combobox"
:file "combobox"
:width 400
:message msg))
(combo (make <combobox> :parent window
:items '("One" "Two" "Three" "Four"))))
;; return 0 for this script
0))
;;;;
;;;; dialog.stk -- Dialog box
;;;;
;;;; Copyright © 2001-2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 11-Mar-2001 12:33 (eg)
;;;; Last file update: 7-Apr-2002 23:57 (eg)
;;;;
(include "gtklos-demo.stk")
;; Change the image-path to allow execution of the demo without installation
(set-image-path! (cons "./images" (image-path)))
(define *dialog-msg* "
Simple dialog with several buttons. All the demos
use the make-simple-dialog procedure to create the dialog
")
(define (make-dialog parent str img)
(make <button> :parent parent
:text (format #f "~A dialog" str)
:command (lambda (_)
(let ((val (make-simple-dialog
:title (string-append str " ...")
:image img
:text (format #f
"\n\n~A:\n Hi, I'm a dialog\n\n"
str)
:texts '("Ok" "Cancel" "Help"))))
(format #t "You have choose ~S on the ~S dialog\n"
val str)))))
(define (main args)
(let* ((win (make <demo-window> :title "Dialog Demo" :x 100 :y 100
:file "dialog" :border-width 10 :padding 10
:message *dialog-msg*))
(b1 (make-dialog win "Error" "gnome-error"))
(b2 (make-dialog win "Info" "gnome-info"))
(b3 (make-dialog win "Question" "gnome-question"))
(b4 (make-dialog win "Warning" "gnome-warning")))
0))
;;;;
;;;; entry1.stk -- GTklos Entry Demo
;;;;
;;;; Copyright © 2000-2001 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 25-Aug-2000 11:25 (eg)
;;;; Last file update: 10-Dec-2001 15:27 (eg)
;;;;
(include "gtklos-demo.stk")
(define (main args)
(let* ((window (make <demo-window>
:title "STklos Entry"
:file "entry1"
:width 400
:message "
This is a demonstration of the <entry> widget. In this demo,
you can use the two check buttons as toggles. The first one
allows/forbids entry edition. The second one, makes the text
in the entry visible/invisible
"))
(entry (make <entry>
:max-length 50
:value "Hello, world"
:sensitive #f
:parent window))
(hbox (make <box>
:orientation 'horizontal
:parent window))
(check1 (make <check-button>
:text "Editable"
:value #f
:parent hbox
:command (lambda (e)
(let ((self (event-widget e)))
(set! (sensitive entry) (value self))))))
(check2 (make <check-button>
:text "Visible"
:value #t
:parent hbox
:command (lambda (e)
(let ((self (event-widget e)))
(set! (text-visibility entry) (value self)))))))
'nothing))
;;;;
;;;; entry2.stk -- Another GTK+ Entry Demo
;;;;
;;;; Copyright © 2001 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 24-Jul-2001 21:54 (eg)
;;;; Last file update: 11-Nov-2003 16:40 (eg)
;;;;
(include "gtklos-demo.stk")
(define (main args)
(let* ((window (make <demo-window>
:title "STklos Entry and Events"
:width 400
:file "entry2"
:message "
This is a demonstration of the <entry> widget. In this demo,
an event handler is associated to the widget. This event handler
manages the \"Enter\" and \"Control-q\" keys. The former prints
a message and the second exits the demonstration.
"))
(entry (make <entry>
:max-length 50
:value "This is an entry"
:parent window
:event (make <event-handler> :key
(lambda (e)
(let ((ch (event-char e)))
(cond
((char=? ch #\newline)
(format #t "entry value: ~S\n"
(value (event-widget e))))
((char=? ch #\q)
(when (memq 'control (event-modifiers e))
(format #t "Quit\n")
(exit 0))))))))))
'nothing))
;;;;
;;;; event.stk -- Demo showing event management in GTklos
;;;;
;;;; Copyright © 2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 8-Apr-2002 19:33 (eg)
;;;; Last file update: 8-Apr-2002 21:19 (eg)
;;;;
(include "gtklos-demo.stk")
(define *event-msg* "
In this demo, some handler have been placed on the buttons.
If you iconify, deiconify, or resize this window, a message is printed.
Try to fire them and see what is printed on the standard
output.
")
(define (main args)
(let* ((win (make <demo-window> :title "Event Management Demo" :x 100 :y 100
:file "event" :border-width 10 :padding 10
:message *event-msg*
:event (make <event-handler>
:unmap (lambda (e)
(let ((w (event-widget e)))
(format #t "Unmap: ~S\n" (title w))))
:map (lambda (e)
(let ((w (event-widget e)))
(format #t "Map: ~S\n" (title w))))
:configure (lambda (e)
(let ((w (event-widget e)))
(format #t "Configure x: ~A y: ~A\n"
(event-x e)
(event-y e)))))))
(b1 (make <button> :text "Enter/Leave Button" :parent win
:event (make <event-handler>
:enter (lambda (e)
(let ((w (event-widget e)))
(format #t "Entering: ~S\n" (text w))))
:leave (lambda (e)
(let ((w (event-widget e)))
(format #t "Leaving: ~S\n" (text w)))))))
(b2 (make <button> :text "Mouse Press/Release Button":parent win
:event (make <event-handler>
:press (lambda (e)
(let ((w (event-widget e)))
(format #t "Press: [~A] ~S\n"
(event-button e)
(text w))))
:release (lambda (e)
(let ((w (event-widget e)))
(format #t "Release: [~A] ~S\n"
(event-button e)
(text w)))))))
(b3 (make <text> :text "Mouse Motion" :parent win