Commit of 3.1.1 version
This commit is contained in:
Erick Gallesio
commit
831a9f5c47
|
|
@ -0,0 +1,31 @@
|
|||
Binary distributions are available at ftp://kaolin.unice.fr/pub/Binary.
|
||||
If you succeed in compiling a version for which no binary is available
|
||||
on the previous site, you can probably help other people by sharing
|
||||
your binary.
|
||||
To make a machine-specific binary:
|
||||
|
||||
1. Type 'make binary-release' in the main distribution directory.
|
||||
2. Create a README file for your distribution which indicates
|
||||
the options you chose. A model of the README file is given below.
|
||||
3. Place the binary archive (the .tar.gz) and the README file in
|
||||
ftp://kaolin.unice.fr/pub/Incoming/
|
||||
|
||||
Thanks
|
||||
|
||||
______________________________________________________________________________
|
||||
|
||||
Sample README file for binary-release
|
||||
-------------------------------------
|
||||
|
||||
|
||||
Author: <place here your name>
|
||||
Email: <and your email here>
|
||||
Creation date: <insert date here>
|
||||
X11 version used: X11R<???>
|
||||
--------------------------------------------------
|
||||
Comments:
|
||||
|
||||
--------------------------------------------------
|
||||
Configuration:
|
||||
<insert here the content of the file config.make>
|
||||
|
||||
|
|
@ -0,0 +1,243 @@
|
|||
09/26/96 Release 3.1.1
|
||||
----------------------
|
||||
|
||||
This release is a bug correction release. It corrects a lot bugs.
|
||||
A lot of theses bugs prevent to install it on some architectures.
|
||||
Apart bugs:
|
||||
|
||||
- Version of Tk is now at Tk4.1p1 level (last stable version)
|
||||
|
||||
- a MS VC makefile is now provided for Win 32 thanks to
|
||||
Caleb Deupree <cdeupree@erinet.com> (I have changed some things
|
||||
from the Caleb file but cannot test them, I hope this is correct)
|
||||
|
||||
- Support for sockets on Win32 was done by Caleb Deupree on MS
|
||||
VC. This should also work on BC++ but I'm not able to test it.
|
||||
|
||||
|
||||
07/24/96 Release 3.1
|
||||
--------------------
|
||||
|
||||
- Version of Tk is now at Tk4.1 level.
|
||||
|
||||
- STk run now on Win32!!!
|
||||
Some details need a little more work (some oddities on file names
|
||||
due to difference conventions between Unix and DOS, and things like
|
||||
that). No socket support and no dynamic loading on Win32
|
||||
|
||||
- A complete documentation of STk widgets pages (both in nroff
|
||||
and HTML format). The help command really allow you to browse
|
||||
man pages now. Man pages are prefixed by "stk_" now to avoid confusion
|
||||
with original Tk manual pages.
|
||||
|
||||
- STklos is now integrated to STk (it was dynamically loaded before).
|
||||
This simplify its implementation and speed up generic functions:
|
||||
o gf are now 2-4 time faster
|
||||
o gf are now tail recursive
|
||||
o the MOP for gf is now "public" (i.e. you can change the way
|
||||
gf are called in Scheme -- it was not possible with previous
|
||||
versions without using C).
|
||||
|
||||
- Port implementation is different: A port contains now its
|
||||
input and output handler. New primitives to access the handler:
|
||||
when-port-readable and when-port-writable.
|
||||
BTW, The Tk function fileevent function is no more useful
|
||||
(it is written in Scheme now for compatibility, but its usage
|
||||
is deprecated). It may not be supported in a future release.
|
||||
|
||||
- New composite widgets: <Multiple-window> and <Inner-window>
|
||||
which allow to have embedded windows. A multiple window
|
||||
has a task bar below and allow to iconify inner-windows.
|
||||
Some people think it looks like Win95 desktop ;-)
|
||||
|
||||
- pixmap extension doesn't require anymore the Xpm library. Code
|
||||
is stolen from the Tix Library.
|
||||
|
||||
- New socket code which allow multiple concurrent connection
|
||||
|
||||
- Extended types can now have a compare function which is called
|
||||
when eqv? or equal? is called. This modification should be
|
||||
compatible with the previous extensions (I hope so)
|
||||
|
||||
- STklos: Two new methods: object-eqv? and object-equal? which are
|
||||
called when applying eqv? or equal? to instances.
|
||||
|
||||
- A rewriting of bind-for-dragging canvas method. You can now specify
|
||||
a :before-motion, which if it returns #f, forbid to move the selected
|
||||
canvas item.
|
||||
|
||||
- New primitives:setenv!, posix-host-name, posix-domain-name,
|
||||
posix-uname
|
||||
|
||||
- Option separator "--" allows to pass reserved keyword (sush as -help)
|
||||
to a script. Option and parameter cannot be mixed anymore
|
||||
(i.e. calling stk xyz -help ==> *argv* = ("xyz" "-help")
|
||||
|
||||
- HTML browser enhancement (support of the <FONT> tag with SIZE
|
||||
and COLOR sub-tags. This must be compatible with the HTML spec.
|
||||
|
||||
- and of course many many bug corrections.
|
||||
|
||||
|
||||
01/22/96 Release 3.0 (also called 3.0b2 by error)
|
||||
~~~~~~~~~~~~~~~~~~~~
|
||||
- Version of Tk is now at Tk4.0p2 level
|
||||
|
||||
- Support Pixmap images
|
||||
|
||||
- Strings can now contain null charters (printing of strings is more
|
||||
friendly now in write mode
|
||||
|
||||
- Executable is now position independant(i.e. no path coded in hard in
|
||||
the interpreter). STK_LIBRARY shell variable is no more necessary. We
|
||||
can now make binary distributions.
|
||||
|
||||
- Signal can now be redirected to Scheme closures. The end of a GC
|
||||
is seen as a signal.
|
||||
|
||||
- Trace on variable are changed (and re-work now): the associated trace
|
||||
must be a thunk now.
|
||||
|
||||
- New option for buttons, checkbuttons, radiobuttons and entries:
|
||||
:stringvalue.
|
||||
This options tells if the value must be stringified or not.
|
||||
For instance, with
|
||||
(radiobutton '.c :text "Try" :variable 'x :stringvalue #f :value 100)
|
||||
will set the "x" var to "100" whereas with
|
||||
(radiobutton '.c :text "Try" :variable 'x :stringvalue #t :value 100)
|
||||
value is set to the integer value 100
|
||||
Default value for :stringvalue is #t for entries and #f for check and
|
||||
radio buttons.
|
||||
|
||||
- stk-wtour demo is updated for STk 3.0
|
||||
|
||||
- In STklos, if a method M is defined and if it is already bound to
|
||||
a procedure, the old procedure is called when no method is applicable.
|
||||
Example:
|
||||
(define-method car ((x <integer>)) (- x 1))
|
||||
(car 10) ==> 9
|
||||
(car (cons 'a 'b)) ==> a
|
||||
As a consequence, this kind of method cannot call no-applicable-method
|
||||
if parameters are not valid:
|
||||
(car (vector 1 2)) ==> error car: wrong type of argument: #(1 2)
|
||||
|
||||
- Small change in the STklos hierarchy. <widget> is now a subclass of
|
||||
<procedure> and its meta class is <procedure-metaclass>.
|
||||
|
||||
|
||||
10/07/95 Release 3.0b1
|
||||
~~~~~~~~~~~~~~~~~~~~~~
|
||||
A lot of modifications. Briefly,
|
||||
- Support of Tk4.0
|
||||
- Closures are fully supported by Tk. That means that a callback can be
|
||||
now a Scheme closure with its environment. GC problems with closures
|
||||
and usage of the dirty "address-of" are definitively gone.
|
||||
- HTML support (a browser is provided, should be extended to support
|
||||
all HTML2.0)
|
||||
- Documentation is now in HTML for the Tk commands (only a few commands
|
||||
are ready for now, but they will be all defined in a near future).
|
||||
- ....
|
||||
|
||||
|
||||
07/15/95 Release 2.2
|
||||
~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
This is the last release with Tk 3.6. Next release will integrate Tk 4.0
|
||||
|
||||
- Bug corrections
|
||||
- Changing Makefiles and configure files for better dynamic loading
|
||||
integration.
|
||||
- Adding support for BLT-1.7. This library can be loaded dynamically
|
||||
on system which support it
|
||||
- New option which permit to change the initial amount of cells
|
||||
- Uses really LESS memory.
|
||||
- New GC. Now we have a set of heaps and a new heap is allocated as
|
||||
soon as the global space is "nearly" filled.
|
||||
- SLIB support (just type (require "slib") and after that process as
|
||||
indicated in SLIB documentation
|
||||
- Integration of the Suresh Srinivas STk-wtour demo.
|
||||
- Adding support for Text in STklos: Definition of the <Text> class
|
||||
(and companion <Text-tag> class).
|
||||
- call/cc is now tail recursive. (Alas, methods and dynamic-wind are
|
||||
not yet tail recursive).
|
||||
- Better support for autoloading files
|
||||
- Adding support for an exec function a` la Tcl (i.e. execute of a
|
||||
unix process and keep its output in a Scheme string)
|
||||
- General run-process for running Unix process were std{in,out,err}
|
||||
can be redirected in files or in pipes.
|
||||
- Some code has been rewritten to ease STk porting
|
||||
- Adding support for regular expression pattern matching and
|
||||
replacement
|
||||
- There is now a light interpreter, called snow (for Scheme
|
||||
NO Window); this is in fact the STk interpreter without Tk support.
|
||||
This interpreter is an independant executable. It can be called
|
||||
with the `snow' shell-script or by unsetting the DISPLAY variable.
|
||||
- New organisation of intalled file to permit co-existence of
|
||||
several version of STk or multi-architecture file sharing
|
||||
- Dynamic loading support for NetBSD-1.0
|
||||
- Dynamic loading support for HP
|
||||
- Dynamic loading and dump support for FreeBsd.
|
||||
- Dynamic loading for Linux (using ELF format or the DLD package)
|
||||
- A mini interface builder (very simplistic, but usable)
|
||||
- New contributions: A true Tetris game, a 8 queens simulation and
|
||||
a demo of composite widgets.
|
||||
- Every exported identifier now starts with the string "STk_" to
|
||||
avoid name clashes when embedding the interpreter in an application.
|
||||
- BSD sockets support
|
||||
- Better integration with Emacs
|
||||
- AMIB (A Mini Interface Builder)
|
||||
- A lot of improvement in STklos
|
||||
- .....
|
||||
|
||||
See the ChangeLog file for more information
|
||||
|
||||
==============================================================================
|
||||
??/??/?? Release 2.1
|
||||
~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
This is a major release version.
|
||||
|
||||
- STklos (the object layer) is now written in C. It is more than 150
|
||||
times faster than before and it uses less memory (~ 1/100)!!!!
|
||||
- Improvement of STklos
|
||||
- STklos classes have been written for all the Tk library widgets
|
||||
- Composites widgets can be easily defined in STklos. Access to those
|
||||
widgets is identical to C written one.
|
||||
- bindings can be now true lambda expression with their own
|
||||
environment (rather than list which are evaluated in the global
|
||||
environment).
|
||||
- Hash tables have been added.
|
||||
- Small constants are coded on a pointer rather than a cell
|
||||
- Support for dynamic loading on SunOs (4 and 5). Dynamic loading
|
||||
uses shared objects (it should work also on OSF1)
|
||||
- Dump creates now smaller images.
|
||||
- Modification of configure and Makefiles to correct of a lot
|
||||
of installation problems.
|
||||
- Runs on Solaris 2.3
|
||||
- Bugs corrections
|
||||
- Some modification to the error notifier
|
||||
- Support of dynamic loading of shared objects on Solaris 1 & 2 (it
|
||||
should work also on OSF1).
|
||||
- ...
|
||||
|
||||
94/01/03 Release 2.0
|
||||
~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
STk 2.0 contains a completly rewritten Scheme interpreter. This new
|
||||
interpreter is
|
||||
- R4RS
|
||||
- faster than previous release (~ 3 or 4 times)
|
||||
- less bugged (I hope :-) )
|
||||
- implements integers (32 bits and bignum) and floats
|
||||
- cleaner with macros
|
||||
|
||||
This version contains also a prototype of a graphical inspector which
|
||||
permits to see/modify a variable value. For widgets variables it permits
|
||||
to modify interactively their behaviour. However, it doesn't yet contain
|
||||
a C rewritting of the object layer as it was planned. This will be done
|
||||
in a (probably the) next release.
|
||||
|
||||
93/09/02 Release 1.00 (first public release)
|
||||
~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
Forget it :)
|
||||
|
|
@ -0,0 +1,261 @@
|
|||
This File contains a set of hints for compiling STk and the things
|
||||
which have been reported about installation of STk. This file is very
|
||||
incomplete and I hope to be able to make it growing.
|
||||
|
||||
If you experience a new port or confirm/infirm/add informations which are
|
||||
specified here please send a mail to 'eg@unice.fr' (there is a blank form
|
||||
at the end of this file)
|
||||
|
||||
If you succeed in compiling STk on an architecture for which there is no
|
||||
binary release, please read the file BINARY_DISTRIB
|
||||
|
||||
|
||||
______________________________________________________________________________
|
||||
SunOs 4.1.x
|
||||
______________________________________________________________________________
|
||||
Compilation:
|
||||
CC=gcc
|
||||
CFLAGS=-O2
|
||||
|
||||
X11:
|
||||
R5 and R6
|
||||
|
||||
Dynamic loading:
|
||||
I was not able to make a version using dynamic loading and the gnu
|
||||
loader. If your version of gcc use gld, you'll have probably to use the
|
||||
--disable-dynload option during configuration. (Note: I said probably
|
||||
since a lot of things don't work on this system which has a gcc with
|
||||
gld. Everything seems very poorly installed on this system)
|
||||
|
||||
No problem with gcc and Sun ld.
|
||||
Who:
|
||||
Erick Gallesio (eg@unice.fr)
|
||||
Tested:
|
||||
Yes :)
|
||||
|
||||
Remarks:
|
||||
The main system used for developping STk
|
||||
|
||||
______________________________________________________________________________
|
||||
SunOs 5.3
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=gcc
|
||||
CFLAGS=-O2
|
||||
X11:
|
||||
OpenWindows
|
||||
|
||||
Dynamic loading:
|
||||
Should work. At least it seems to be conform to documentation :->
|
||||
Must be
|
||||
Who:
|
||||
Erick Gallesio (eg@unice.fr)
|
||||
|
||||
Tested:
|
||||
just make widget-demo
|
||||
|
||||
Remarks:
|
||||
Some people have reported that they use dynamic loading but I can
|
||||
remember who (and it was on 2.1).
|
||||
|
||||
______________________________________________________________________________
|
||||
Linux 1.0.9 -> 2.0.0
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=gcc
|
||||
CFLAGS=-O2
|
||||
X11:
|
||||
XFree3.1.2
|
||||
|
||||
Dynamic loading:
|
||||
Dynamic loading is supported for DLD and ELF. (however DLD hqs not
|
||||
been tested since a long time, I'm not sure it continues to work).
|
||||
The configure script try to figure what type of dynamic loading
|
||||
works for you and enable dynamic loading by default. With recent
|
||||
kernels, it will probably be ELF.
|
||||
|
||||
Who:
|
||||
Erick Gallesio (eg@unice.fr)
|
||||
|
||||
Tested:
|
||||
yes
|
||||
|
||||
Remarks:
|
||||
The other system used for developping STk.
|
||||
|
||||
______________________________________________________________________________
|
||||
DEC Alpha OSF1 V2.0
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=cc Dont't use gcc 2.6 !!!!!!
|
||||
CFLAGS=-O2
|
||||
X11:
|
||||
X11 R5
|
||||
|
||||
Dynamic loading:
|
||||
Erik Ostrom <eostrom@radon.ccs.neu.edu> told me to use ld for
|
||||
makeing the .so file. I quote him below:
|
||||
"If SH_LOADER is "ld", you get a huge warning about all the
|
||||
undefined symbols; but if it's "cc", ld just won't make the
|
||||
.so file. I assume there's a way to get better results, but
|
||||
this at least produced a working system."
|
||||
|
||||
Who:
|
||||
Erick Gallesio (eg@unice.fr)
|
||||
|
||||
Tested:
|
||||
Not a lot. Only the widget demo and some bignum tests.
|
||||
No more core dump on undefined variable
|
||||
|
||||
Remarks:
|
||||
Don't use gcc. STk worked with gcc prior 2.6. It doesn't work anymore
|
||||
with this version of gcc. I have not investigated a lot with it but it seems
|
||||
that gcc 2.6 is unable to compile the bignum stuff (it yields warning during
|
||||
compilation whereas tthe code seems correct). Tests includes in the GMP
|
||||
packages dont pass anymore. Consequently, all computation
|
||||
which involve a bignum will be false (and could sometimes conduct to a core
|
||||
dump).
|
||||
|
||||
I don't use this system.
|
||||
______________________________________________________________________________
|
||||
Dec 5xxx Ultix 4.2
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=gcc
|
||||
CFLAGS=-O2
|
||||
X11:
|
||||
X11 R5
|
||||
|
||||
Dynamic loading:
|
||||
Not supported
|
||||
|
||||
Who:
|
||||
Erick Gallesio (eg@unice.fr)
|
||||
|
||||
Tested:
|
||||
Widget demo work.
|
||||
|
||||
Remarks:
|
||||
I don't use this sytem.
|
||||
|
||||
______________________________________________________________________________
|
||||
HP 9000/735 (HP-UX 9.01)
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=cc
|
||||
CFLAGS='-Ae -O'
|
||||
|
||||
X11:
|
||||
????
|
||||
|
||||
Dynamic loading:
|
||||
Dynamic loading is supported (support is due to Dipankar Gupta
|
||||
<dg@hplb.hpl.hp.com>). This support has been sent to me as a patch
|
||||
file over 2.1. It must be extended for newer versions (the only file
|
||||
to modify is Src/dynload.c). Furthermore, options needed for
|
||||
compilation dosen't seems clear for me. I have guessed some of them
|
||||
but I may be wrong.
|
||||
Who:
|
||||
ottl@informatik.uni-muenchen.de
|
||||
|
||||
Tested:
|
||||
Widget demo only (I think)
|
||||
|
||||
Remarks:
|
||||
Other people have reported that STk work on HP. I don't know if they
|
||||
have used it a lot. Every info is welcome.
|
||||
|
||||
______________________________________________________________________________
|
||||
SCO
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
???
|
||||
|
||||
X11:
|
||||
???
|
||||
|
||||
Dynamic loading:
|
||||
???
|
||||
|
||||
Who:
|
||||
markd@grizzly.com
|
||||
|
||||
Tested:
|
||||
???
|
||||
|
||||
Remarks:
|
||||
|
||||
Use ptar (pax tar) to untar the distribution rather than standard tar. It
|
||||
seems that the standard tar doesn't handle correctly symbolic links.
|
||||
|
||||
______________________________________________________________________________
|
||||
NetBSD 1.0
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
???
|
||||
X11:
|
||||
XFree ????
|
||||
|
||||
Dynamic loading:
|
||||
Yes. Contribution of Franke Ruediger (Ruediger.Franke@rz.tu-ilmenau.de)
|
||||
|
||||
Who:
|
||||
Franke Ruediger
|
||||
|
||||
Tested:
|
||||
???
|
||||
|
||||
Remarks:
|
||||
????
|
||||
|
||||
______________________________________________________________________________
|
||||
SGI Irix 5.3
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
CC=gcc CFLAGS=-O2
|
||||
X11:
|
||||
X11R6
|
||||
|
||||
Dynamic loading:
|
||||
Dynamic loading is supported
|
||||
|
||||
Who:
|
||||
tiemann@cygnus.com
|
||||
|
||||
Tested:
|
||||
compiled, ran all demos (stk and stklos)
|
||||
|
||||
Remarks:
|
||||
|
||||
______________________________________________________________________________
|
||||
A new system (Mail this form to eg@unice.fr if you have made a new port)
|
||||
______________________________________________________________________________
|
||||
|
||||
Compilation:
|
||||
Indicate here the values of CC and CFLAGS you used
|
||||
X11:
|
||||
Indicate here the X11 version you used
|
||||
|
||||
Dynamic loading:
|
||||
Indicate here if dynamic loading is supported and all info that seems
|
||||
necessary for loading a file in a running interpreter.
|
||||
|
||||
Who:
|
||||
your email or "Anonymous" if you don't want to bother yourself
|
||||
with that anymore.
|
||||
|
||||
Tested:
|
||||
How much you have tested STk (just compiled it, tested only the
|
||||
demos, ...)
|
||||
|
||||
Remarks:
|
||||
Everythink you think is relevant.
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
Since I'm not a lawyer, I don't know where to put copyrigth notices
|
||||
and permission notices of softwares I use. Consequently I put them here in
|
||||
hope it's sufficient....
|
||||
|
||||
Note:
|
||||
STk licence seems not to be as clear as I hope. The main idea is
|
||||
that you can do what you want with STk. You can even use it in
|
||||
commercial products. The only restriction is that you must prevent me
|
||||
if you intend to use it in a commercial product (so I can send you a
|
||||
"written permission" for efectively using it). The goal is not to
|
||||
restrict commercial applications but only to count them. If someone,
|
||||
fluent in english and which like those aspects, can help me to make
|
||||
things clearer...
|
||||
|
||||
==============================================================================
|
||||
|
||||
TK/TCL Copyright
|
||||
----------------
|
||||
Copyright (c) 1987-1993 The Regents of the University of California.
|
||||
Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
|
||||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., and other parties. The following
|
||||
terms apply to all files associated with the software unless explicitly
|
||||
disclaimed in individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
RESTRICTED RIGHTS: Use, duplication or disclosure by the government
|
||||
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
|
||||
of the Rights in Technical Data and Computer Software Clause as DFARS
|
||||
252.227-7013 and FAR 52.227-19.
|
||||
|
||||
|
||||
Siod Copyright
|
||||
--------------
|
||||
|
||||
/* Scheme In One Defun, but in C this time.
|
||||
|
||||
* COPYRIGHT (c) 1988-1992 BY *
|
||||
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
|
||||
* ALL RIGHTS RESERVED *
|
||||
|
||||
Permission to use, copy, modify, distribute and sell this software
|
||||
and its documentation for any purpose and without fee is hereby
|
||||
granted, provided that the above copyright notice appear in all copies
|
||||
and that both that copyright notice and this permission notice appear
|
||||
in supporting documentation, and that the name of Paradigm Associates
|
||||
Inc not be used in advertising or publicity pertaining to distribution
|
||||
of the software without specific, written prior permission.
|
||||
|
||||
PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
|
||||
ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
|
||||
PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
|
||||
ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
|
||||
WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
|
||||
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
|
||||
SOFTWARE.
|
||||
|
||||
*/
|
||||
|
||||
Tiny CLOS copyright
|
||||
-------------------
|
||||
|
||||
;;; Copyright (c) 1992 Xerox Corporation.
|
||||
;;;; All Rights Reserved.
|
||||
;;;
|
||||
;;; Use, reproduction, and preparation of derivative works are permitted.
|
||||
;;; Any copy of this software or of any derivative work must include the
|
||||
;;; above copyright notice of Xerox Corporation, this paragraph and the
|
||||
;;; one after it. Any distribution of this software or derivative works
|
||||
;;; must comply with all applicable United States export control laws.
|
||||
;;;
|
||||
;;; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
|
||||
;;; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
|
||||
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
;;; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
|
||||
;;; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
|
||||
;;; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
|
||||
;;; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
|
||||
;;; OF THE POSSIBILITY OF SUCH DAMAGES.
|
||||
|
||||
|
||||
|
||||
and finally
|
||||
|
||||
STk Copyright
|
||||
-------------
|
||||
|
||||
/*
|
||||
* Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
||||
*
|
||||
*
|
||||
* Permission to use, copy, and/or distribute this software and its
|
||||
* documentation for any purpose and without fee is hereby granted, provided
|
||||
* that both the above copyright notice and this permission notice appear in
|
||||
* all copies and derived works. Fees for distribution or use of this
|
||||
* software or derived works may only be charged with express written
|
||||
* permission of the copyright holder.
|
||||
* This software is provided ``as is'' without express or implied warranty.
|
||||
*
|
||||
* This software is a derivative work of other copyrighted softwares; the
|
||||
* copyright notices of these softwares are placed in the file COPYRIGHTS
|
||||
*
|
||||
*/
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This directory contains contributions which have been sent to me.
|
||||
|
||||
Inspect
|
||||
The STk-inspector (contributor Erick Fintzel -- fintzel@kaolin.unice.fr)
|
||||
Pretty
|
||||
A pretty printer (contributor Martine Follen -- mf@unice.fr)
|
||||
|
||||
Process
|
||||
A set of new primitives to deal with Unix processes. This contribution will
|
||||
be included in the core interpreter in the next release (contributors
|
||||
Alexander Taranov, Grygory Niconov and David Tolpin -- tay@jet.msk.su,
|
||||
gn@jet.msk.su and Dvd@CIM.Msk.SU)
|
||||
|
||||
Python
|
||||
A patch which permits to communicate with a Python interpreter
|
||||
(contibutor jredford@lehman.com)
|
||||
|
||||
Socket
|
||||
An implementation of BSD-INET sockets and is known to run on
|
||||
Solaris 1 and Linux. This is the starting point of current implementation.
|
||||
Contributor: David Tolpin (dvd@pizza.msk.su)
|
||||
|
||||
Stetris
|
||||
This is a falling block game not unlike tetris(tm) :). It is
|
||||
implemented in STk just to prove it can be done, and as a challenge to
|
||||
TCLers. (contributor Harvey J. Stein -- hjstein@math.huji.ac.il)
|
||||
|
||||
STk-wtour
|
||||
A rewritting of the Andrew Payne Tcl/Tk wtour for STk.
|
||||
This is excellent for learning basics od STk programming
|
||||
(contributor Suresh Srinivas -- ssriniva@cs.indiana.edu)
|
||||
|
||||
Trace
|
||||
A trace procedure (contributor Martine Follen -- mf@unice.fr)
|
||||
|
||||
|
||||
|
||||
Another contribution, called XS, (a Scheme graphical debugger) is also available
|
||||
as a separate file on kaolin.unice.fr in the file ~ftp/pub/xscheme0.2.gz.
|
||||
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
This directory contains the STk graphical Inspector. It is a first step toward
|
||||
a true debugger (able to set breakpoints, to see the stack, ...).
|
||||
This work is due to Eric Fintzel (fintzel@kaolin.unice.fr).
|
||||
|
||||
Hacked by Erick Gallesio (eg@unice.fr) for version 2 integration.
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/inspect-detail.stk
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/inspect-help.stk
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/inspect-main.stk
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/inspect-misc.stk
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/inspect-view.stk
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../Lib/pp.stk
|
||||
|
|
@ -0,0 +1,628 @@
|
|||
#include "stk.h"
|
||||
#include <fcntl.h>
|
||||
#include <errno.h>
|
||||
#include <sys/param.h>
|
||||
#include <sys/wait.h>
|
||||
#include <unistd.h>
|
||||
#include <signal.h>
|
||||
|
||||
|
||||
#define MAX_PROC_NUM 256 /*enough eh?*/
|
||||
#define MAX_ARGS_NO 256
|
||||
|
||||
#define NO_REDIRECTION 0
|
||||
#define REDIRECTION_BY_FILE 1
|
||||
#define REDIRECTION_BY_STREAM 2
|
||||
|
||||
|
||||
/******** SIGUSR1 handler *******/
|
||||
static void su1_handler(){
|
||||
/* printf("SIGUSR1 arrived\n"); */
|
||||
}
|
||||
/*********************************/
|
||||
|
||||
/**** Registering processes ****/
|
||||
static SCM proc_arr[MAX_PROC_NUM];
|
||||
|
||||
|
||||
static init_proc_table(){
|
||||
int i;
|
||||
for(i = 0; i<MAX_PROC_NUM; i++)
|
||||
proc_arr[i] = ntruth;
|
||||
}
|
||||
|
||||
static int find_process(SCM prc){
|
||||
int i;
|
||||
int ret = -1;
|
||||
for(i = 0; i<MAX_PROC_NUM; i++){
|
||||
if(prc==proc_arr[i]){
|
||||
ret = i;
|
||||
break;
|
||||
}
|
||||
}
|
||||
return ret;
|
||||
}
|
||||
|
||||
static int reg_process(SCM prc){
|
||||
int i;
|
||||
/* find slot */
|
||||
i = find_process(ntruth);
|
||||
if(i<0){
|
||||
gc_for_newcell();
|
||||
i = find_process(ntruth);
|
||||
}
|
||||
if (i < 0){
|
||||
err("Too many processes", NIL);
|
||||
return -1;
|
||||
}
|
||||
proc_arr[i] = prc;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static
|
||||
int find_slot(){
|
||||
int i;
|
||||
/* find slot */
|
||||
i = find_process(ntruth);
|
||||
if(i<0){
|
||||
gc_for_newcell();
|
||||
i = find_process(ntruth);
|
||||
}
|
||||
if (i < 0){
|
||||
err("Too many processes", NIL);
|
||||
return -1;
|
||||
}
|
||||
return i;
|
||||
}
|
||||
|
||||
static int remove_process(SCM prc){
|
||||
int i;
|
||||
/* find slot */
|
||||
i = find_process(prc);
|
||||
if(i<0){
|
||||
err("unregistered process", prc);
|
||||
return -1;
|
||||
}
|
||||
proc_arr[i] = ntruth;
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
/**** gc-helpers *****/
|
||||
static void free_process( SCM process );
|
||||
static void mark_process( SCM process );
|
||||
|
||||
|
||||
|
||||
static int tc_process;
|
||||
|
||||
static extended_scheme_type process_type = {
|
||||
"process", /* name */
|
||||
0, /* is_procp */
|
||||
mark_process, /* gc_mark_fct */
|
||||
free_process, /* gc_sweep_fct */
|
||||
NULL, /* apply_fct */
|
||||
NULL /* display_fct */
|
||||
};
|
||||
|
||||
|
||||
|
||||
struct process_info {
|
||||
int pid; /* pid */
|
||||
char *commandLine; /* Cmdline used to start process */
|
||||
char redirection[3]; /* Types of redirection */
|
||||
struct obj *stream[3];
|
||||
};
|
||||
|
||||
#define PROCESS(x) ((struct process_info *)(x->storage_as.extension.data))
|
||||
#define PROCESSP(x) (TYPEP (x, tc_process))
|
||||
#define NPROCESSP(x) (NTYPEP (x, tc_process))
|
||||
#define PROCPID(x) PROCESS(x)->pid
|
||||
|
||||
|
||||
extern char **sys_errlist;
|
||||
|
||||
static char *stdStreams[3] = {
|
||||
"standard input", "standard output", "standard error",
|
||||
};
|
||||
|
||||
static char *strName[3] = {
|
||||
"stdin", "stdout", "stderr",
|
||||
};
|
||||
|
||||
static PRIMITIVE
|
||||
fork_process( SCM command, SCM args, SCM redirection, int run_async );
|
||||
|
||||
PRIMITIVE
|
||||
run_process( SCM command, SCM args, SCM redirection ) {
|
||||
return fork_process(command, args, redirection, 1);
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
run_sync( SCM command, SCM args, SCM redirection ) {
|
||||
return fork_process(command, args, redirection, 0);
|
||||
}
|
||||
|
||||
static PRIMITIVE
|
||||
fork_process( SCM command, SCM args, SCM redirection, int run_async ) {
|
||||
SCM pinfo, arg, pnames, ptypes;
|
||||
char *argv[MAX_ARGS_NO], msg[256], *files[3];
|
||||
int argc, pid, i;
|
||||
long flag;
|
||||
int pipes[3][2];
|
||||
int redirectionType[3];
|
||||
struct process_info *info;
|
||||
void *old_chld_sig_action;
|
||||
int svMask, usermask; int ok;
|
||||
int svMask1, mypid;
|
||||
usermask = (sigmask(SIGUSR1));
|
||||
|
||||
/* Checking arguments and creating UNIX-style */
|
||||
/* arguments list */
|
||||
|
||||
if( NSTRINGP( command ) )
|
||||
err("run-process: bad program name", command);
|
||||
i = find_slot();
|
||||
if( i < 0)
|
||||
return ntruth;
|
||||
|
||||
NEWCELL(pinfo, tc_process);
|
||||
proc_arr[i] = pinfo;
|
||||
|
||||
info = (struct process_info *) malloc( sizeof( struct process_info ) );
|
||||
PROCESS(pinfo) = info;
|
||||
/*
|
||||
*
|
||||
* Initializing info structure
|
||||
*
|
||||
*/
|
||||
|
||||
info->commandLine = strdup(CHARS( command ) );
|
||||
|
||||
for( i = 0; i < 3; i++ ) {
|
||||
info->redirection[i] = NO_REDIRECTION;
|
||||
info->stream[i] = NIL;
|
||||
}
|
||||
|
||||
argv[0] = CHARS( command );
|
||||
|
||||
for( argc = 1; argc < MAX_ARGS_NO && NNULLP( args ); ++argc ) {
|
||||
if( NCONSP( args ) )
|
||||
err("run-process: bad arguments list", args);
|
||||
|
||||
arg = CAR( args );
|
||||
args = CDR( args );
|
||||
|
||||
if( NSTRINGP( arg ) ) {
|
||||
/* In future, may be I implement conversion from */
|
||||
/* non-string argument to the string, but today */
|
||||
/* I don't want to do that :) */
|
||||
|
||||
err("run-process: bad argument -- must be string", arg);
|
||||
}
|
||||
|
||||
argv[argc] = CHARS( arg );
|
||||
}
|
||||
|
||||
if( argc == MAX_ARGS_NO )
|
||||
err("run-process: too many arguments (limit is 256)", args);
|
||||
|
||||
argv[argc] = NULL;
|
||||
|
||||
|
||||
/* Parsing redirection's list and creating communication */
|
||||
|
||||
if( NNULLP( redirection ) ) {
|
||||
|
||||
for( i = 0; i < 3; ++i ) {
|
||||
if( NCONSP( redirection ) )
|
||||
err("run-process: wrong redirection's list", redirection);
|
||||
|
||||
if( STRINGP( CAR( redirection ) ) ) {
|
||||
|
||||
info->redirection[i] = REDIRECTION_BY_FILE;
|
||||
info->stream[i] = string_copy( CAR( redirection ) );
|
||||
|
||||
/* redirectionType[i] = REDIRECTION_BY_FILE;
|
||||
files[i] = CHARS( CAR( redirection ) ); */
|
||||
|
||||
pipes[i][0] = open(CHARS( CAR( redirection ) ),
|
||||
i == 0 ? O_RDONLY : O_WRONLY);
|
||||
if( pipes[i][0] < 0 ) {
|
||||
sprintf(msg, "run-process: can't redirect %s to file %s",
|
||||
stdStreams[i], CHARS( CAR( redirection ) ));
|
||||
|
||||
err( msg, NIL );
|
||||
}
|
||||
|
||||
redirection = CDR( redirection );
|
||||
continue;
|
||||
}
|
||||
|
||||
if( BOOLEANP( CAR( redirection ) ) ) {
|
||||
|
||||
if( CAR( redirection ) == truth ) {
|
||||
if( pipe( pipes[i] ) < 0 ) {
|
||||
|
||||
sprintf(msg, "run-process: can't create stream for %s\n",
|
||||
stdStreams[i]
|
||||
|
||||
);
|
||||
perror("Process");
|
||||
err( msg, NIL );
|
||||
}
|
||||
|
||||
/* redirectionType[i] = REDIRECTION_BY_STREAM; */
|
||||
|
||||
info->redirection[i] = REDIRECTION_BY_STREAM;
|
||||
}
|
||||
|
||||
redirection = CDR( redirection );
|
||||
continue;
|
||||
}
|
||||
|
||||
err("run-process: bad redirection type", CAR( redirection ));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* set handler to catch SIGUSR1 */
|
||||
signal(SIGUSR1,su1_handler);
|
||||
|
||||
/* block user1 signal till parent will be ready */
|
||||
svMask1 = sigblock(usermask);
|
||||
mypid = getpid();
|
||||
|
||||
/* Now, forking and catching the errors */
|
||||
pid = fork();
|
||||
|
||||
if( pid < 0 ) {
|
||||
char msg[256];
|
||||
|
||||
sprintf(msg,
|
||||
"run-process: can't create child process because of (see stderr)"
|
||||
);
|
||||
perror("CHILD process");
|
||||
err( msg, NIL );
|
||||
}
|
||||
|
||||
/* Processing child's behavior */
|
||||
|
||||
if( pid == 0 ) {
|
||||
if(run_async){
|
||||
svMask = sigblock(usermask);
|
||||
signal(SIGUSR1,su1_handler);
|
||||
/* send notification to parent that I'm ready */
|
||||
ok = kill(mypid,SIGUSR1);
|
||||
if(ok < 0) perror( "Sending to parent");
|
||||
sigpause(0);
|
||||
sigsetmask(svMask);
|
||||
/*
|
||||
* fprintf(stderr, "Mask: %x\n", usermask);
|
||||
* fprintf(stderr, "Child continues...");
|
||||
* perror("Child:");
|
||||
*/
|
||||
|
||||
setsid();
|
||||
}
|
||||
|
||||
for( i = 0; i < 3; ++i ) {
|
||||
switch( info->redirection[i] ) {
|
||||
|
||||
case REDIRECTION_BY_FILE:
|
||||
dup2( pipes[i][0], i );
|
||||
close( pipes[i][0] );
|
||||
break;
|
||||
|
||||
case REDIRECTION_BY_STREAM:
|
||||
dup2( pipes[i][ i == 0 ? 0 : 1], i );
|
||||
close( pipes[i][0] );
|
||||
close( pipes[i][1] );
|
||||
break;
|
||||
|
||||
default:
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
for( i = 3; i < NOFILE; ++i )
|
||||
close( i );
|
||||
|
||||
|
||||
/* And then, EXEC'ing... */
|
||||
|
||||
execvp( argv[0], argv );
|
||||
|
||||
/* Unfortunatelly, we can't exec this process -- but */
|
||||
/* we can't tell 'bout this fact to our daddy. :( */
|
||||
|
||||
fprintf(stderr, "Can't exec!");
|
||||
exit( 1 );
|
||||
}
|
||||
|
||||
/* Ok, guys, we are still in the parent process. Making redirection */
|
||||
/* and filling-up PROCESS structure */
|
||||
PROCPID( pinfo ) = pid;
|
||||
if(!run_async) waitpid(pid);
|
||||
else {
|
||||
for( i = 0; i < 3; ++i ) {
|
||||
switch( info->redirection[i] ) {
|
||||
case REDIRECTION_BY_FILE:
|
||||
close( pipes[i][0] );
|
||||
break;
|
||||
|
||||
case REDIRECTION_BY_STREAM:
|
||||
close( pipes[i][ i == 0 ? 0 : 1 ] );
|
||||
|
||||
flag = no_interrupt(1);
|
||||
|
||||
NEWCELL( info->stream[i], i == 0 ? tc_oport : tc_iport );
|
||||
|
||||
if( (info->stream[i]->storage_as.port.f =
|
||||
fdopen( pipes[i][ i == 0 ? 1 : 0],
|
||||
i == 0 ? "w" : "r" )) == NULL )
|
||||
err("process-input: can't FDOPEN stream", pinfo);
|
||||
|
||||
sprintf(msg, "*%s-%d*", strName[i], pid);
|
||||
|
||||
info->stream[i]->storage_as.port.name = must_malloc( strlen( msg ) + 1 );
|
||||
strcpy( info->stream[i]->storage_as.port.name, msg );
|
||||
|
||||
no_interrupt( flag );
|
||||
break;
|
||||
|
||||
default:
|
||||
break;
|
||||
}
|
||||
}
|
||||
/** all house keeping is done... notyfy child to go ***/
|
||||
#if 1
|
||||
sigpause(0); /* wait for child notification */
|
||||
sigsetmask(svMask1);
|
||||
/* notify child */
|
||||
ok = kill(pid,SIGUSR1);
|
||||
if(ok < 0) perror("Parent sigusr");
|
||||
/* else fprintf(stderr, "Parent sending SIGUSR1 to %d\n",pid); */
|
||||
#endif
|
||||
}
|
||||
PROCESS( pinfo ) = info;
|
||||
return pinfo;
|
||||
}
|
||||
|
||||
|
||||
/*** INTERFACE ****/
|
||||
|
||||
PRIMITIVE
|
||||
processp( SCM process ) {
|
||||
return PROCESSP( process ) ? truth : ntruth;
|
||||
}
|
||||
|
||||
|
||||
PRIMITIVE
|
||||
process_alivep( SCM process ) {
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-alive?: wrong argument type", process);
|
||||
|
||||
return kill( PROCPID( process ), 0 ) == 0 ? truth : ntruth;
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_pid( SCM process ) {
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-pid: wrong argument type", process);
|
||||
|
||||
return makeinteger( PROCPID( process ) );
|
||||
}
|
||||
|
||||
static char *rtFile = "*File*";
|
||||
static char *rtStream = "*Stream*";
|
||||
static char *rtNone = "*None*";
|
||||
|
||||
static PRIMITIVE
|
||||
get_internal_redirection( SCM process, int i ) {
|
||||
SCM rType, rName;
|
||||
struct process_info *info;
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-stream-type: wrong argument type", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
|
||||
switch( info->redirection[i] ) {
|
||||
|
||||
case REDIRECTION_BY_FILE:
|
||||
rType = makestrg( strlen( rtFile ), rtFile );
|
||||
rName = string_copy( info->stream[i] );
|
||||
break;
|
||||
|
||||
case NO_REDIRECTION:
|
||||
rType = makestrg( strlen( rtNone ), rtNone );
|
||||
rName = NIL;
|
||||
break;
|
||||
|
||||
default: /* REDIRECTION_BY_STREAM */
|
||||
rType = makestrg( strlen( rtStream ), rtStream );
|
||||
rName = makestrg( strlen( stdStreams[i] ), stdStreams[i] );
|
||||
break;
|
||||
}
|
||||
|
||||
return cons( rType, rName );
|
||||
}
|
||||
|
||||
|
||||
/*** enumerate ***/
|
||||
PRIMITIVE
|
||||
process_list(){
|
||||
int i;
|
||||
SCM lst = NIL;
|
||||
for(i = 0; i<MAX_PROC_NUM; i++)
|
||||
if(proc_arr[i] != ntruth)
|
||||
lst = cons(proc_arr[i],lst);
|
||||
return lst;
|
||||
}
|
||||
|
||||
|
||||
|
||||
PRIMITIVE
|
||||
process_input_info( SCM process ) {
|
||||
|
||||
return get_internal_redirection( process, 0 );
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_output_info( SCM process ) {
|
||||
|
||||
return get_internal_redirection( process, 1 );
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_error_info( SCM process ) {
|
||||
|
||||
return get_internal_redirection( process, 2 );
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_command( SCM process ) {
|
||||
struct process_info *info;
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-command: wrong argument type", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
|
||||
return makestrg( strlen( info->commandLine ), info->commandLine );
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Creating and returning ports to opened streams
|
||||
*/
|
||||
|
||||
PRIMITIVE
|
||||
process_input( SCM process ) {
|
||||
struct process_info *info;
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-input: wrong argument type", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
|
||||
if( info->redirection[0] != REDIRECTION_BY_STREAM ) {
|
||||
return NIL;
|
||||
}
|
||||
|
||||
return info->stream[0];
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_output( SCM process ) {
|
||||
struct process_info *info;
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-input: wrong argument type", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
|
||||
if( info->redirection[1] != REDIRECTION_BY_STREAM ) {
|
||||
return NIL;
|
||||
}
|
||||
|
||||
return info->stream[1];
|
||||
}
|
||||
|
||||
PRIMITIVE
|
||||
process_error( SCM process ) {
|
||||
struct process_info *info;
|
||||
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-input: wrong argument type", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
|
||||
if( info->redirection[2] != REDIRECTION_BY_STREAM ) {
|
||||
return NIL;
|
||||
}
|
||||
|
||||
return info->stream[2];
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
mark_process( SCM process ){
|
||||
struct process_info *info;
|
||||
int i;
|
||||
info = PROCESS(process);
|
||||
for(i=0; i<3 ; i++)
|
||||
gc_mark(info->stream[i]);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
free_process( SCM process ) {
|
||||
int i;
|
||||
struct process_info *info;
|
||||
info = PROCESS( process );
|
||||
i = remove_process(process);
|
||||
if(i < 0)
|
||||
err("cannot unregister process", process);
|
||||
if( info->commandLine )
|
||||
free( info->commandLine );
|
||||
|
||||
for( i = 0; i < 3; ++i ) {
|
||||
if( info->redirection[i] == REDIRECTION_BY_STREAM && info->stream[i] != NIL ) {
|
||||
freeport( info->stream[i] );
|
||||
}
|
||||
}
|
||||
free(info); /* A.T. ++ */
|
||||
}
|
||||
|
||||
|
||||
PRIMITIVE
|
||||
process_kill( SCM process ) {
|
||||
struct process_info *info;
|
||||
int i;
|
||||
if( NPROCESSP( process ) )
|
||||
err("process-kill: wrong argument", process);
|
||||
|
||||
info = PROCESS( process );
|
||||
#if 1
|
||||
for( i = 0; i < 3; ++i ) {
|
||||
if( info->redirection[i] == REDIRECTION_BY_STREAM &&
|
||||
info->stream[i] != NIL ) {
|
||||
freeport( info->stream[i] );
|
||||
info->stream[i]=NIL;
|
||||
}
|
||||
}
|
||||
#endif
|
||||
kill( PROCPID( process ), 15 );
|
||||
return truth;
|
||||
}
|
||||
|
||||
|
||||
/******* run-time initialization ********/
|
||||
void init_process(void)
|
||||
{
|
||||
tc_process = add_new_type(&process_type);
|
||||
init_proc_table();
|
||||
|
||||
add_new_primitive("run-process", tc_subr_3, run_process); /* + */
|
||||
add_new_primitive("run-sync", tc_subr_3, run_sync); /* + */
|
||||
add_new_primitive("process?", tc_subr_1, processp); /* + */
|
||||
add_new_primitive("process-alive?", tc_subr_1, process_alivep); /* + */
|
||||
add_new_primitive("process-input-info", tc_subr_1, process_input_info); /* + */
|
||||
add_new_primitive("process-output-info", tc_subr_1, process_output_info); /* + */
|
||||
add_new_primitive("process-error-info", tc_subr_1, process_error_info); /* + */
|
||||
add_new_primitive("process-command", tc_subr_1, process_command); /* + */
|
||||
add_new_primitive("process-pid", tc_subr_1, process_pid); /* + */
|
||||
add_new_primitive("process-input", tc_subr_1, process_input); /* + */
|
||||
add_new_primitive("process-output", tc_subr_1, process_output); /* + */
|
||||
add_new_primitive("process-error", tc_subr_1, process_error); /* + */
|
||||
add_new_primitive("process-kill", tc_subr_1,process_kill); /* + */
|
||||
add_new_primitive("process-list", tc_subr_0,process_list); /* + */
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
/**
|
||||
* Process.h - LISP implementation of UNIX processes
|
||||
*
|
||||
* Copyright (c) 1994 by Gregory Nickonov.
|
||||
*
|
||||
* Permission to use, copy, and/or distribute this software and its
|
||||
* documentation for any purpose and without fee is hereby granted, provided
|
||||
* that both the above copyright notice and this permission notice appear in
|
||||
* all copies and derived works. Fees for distribution or use of this
|
||||
* software or derived works may only be charged with express written
|
||||
* permission of the copyright holder.
|
||||
* This software is provided ``as is'' without express or implied warranty.
|
||||
*
|
||||
* This software is a derivative work of other copyrighted softwares; the
|
||||
* copyright notices of these softwares are placed in the file COPYRIGHTS
|
||||
*
|
||||
*
|
||||
* Author: Gregory Nickonov, [gn@jet.msk.su]
|
||||
* Creation date: 15-Jan-1994 11:40
|
||||
* Last file update: 11-Jun-1994 22:07
|
||||
*
|
||||
* Made working by David Tolpin Dvd@CIM.Msk.SU
|
||||
* Port to Dynaload STk2.1b,
|
||||
* synchronization and registration
|
||||
* mechanism by A.Taranov tay@jet.msk.su
|
||||
*
|
||||
*/
|
||||
|
||||
#ifndef __PROCESS_H__
|
||||
#define __PROCESS_H__
|
||||
|
||||
PRIMITIVE processp( SCM process );
|
||||
PRIMITIVE process_alivep( SCM process );
|
||||
|
||||
PRIMITIVE run_process( SCM command, SCM args, SCM redirection );
|
||||
PRIMITIVE run_sync( SCM command, SCM args, SCM redirection );
|
||||
PRIMITIVE process_kill( SCM process );
|
||||
|
||||
PRIMITIVE process_input( SCM process );
|
||||
PRIMITIVE process_output( SCM process );
|
||||
PRIMITIVE process_error( SCM process );
|
||||
|
||||
PRIMITIVE process_input_info( SCM process );
|
||||
PRIMITIVE process_output_info( SCM process );
|
||||
PRIMITIVE process_error_info( SCM process );
|
||||
|
||||
PRIMITIVE process_command( SCM process );
|
||||
PRIMITIVE process_pid( SCM process );
|
||||
|
||||
#endif /* __PROCESS_H__ */
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
Herafter is an excerpt of a mail of jredford@lehman.com about Python/STk mail
|
||||
I hope it will suffice to build a running system (I had no time to test it).
|
||||
------------------
|
||||
|
||||
|
||||
This is the file I added.. python-stk.c:
|
||||
|
||||
|
||||
#include <stk.h>
|
||||
#include <Py/allobjects.h>
|
||||
#include <Py/pythonrun.h>
|
||||
#include <Py/import.h>
|
||||
|
||||
PRIMITIVE python_init(void)
|
||||
{
|
||||
initall();
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
PRIMITIVE python(SCM string)
|
||||
{
|
||||
run_command(CHARS(string));
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
SCM convert(object *o)
|
||||
{
|
||||
if is_intobject(o) {
|
||||
return makeinteger(getintvalue(o));
|
||||
} else {
|
||||
if is_floatobject(o) {
|
||||
return makenumber(getfloatvalue(o));
|
||||
} else {
|
||||
if is_stringobject(o) {
|
||||
return makestrg(getstringsize(o),getstringvalue(o));
|
||||
} else {
|
||||
if is_tupleobject(o) {
|
||||
int i,j = gettuplesize(o);
|
||||
SCM vec;
|
||||
vec = makevect(j,makeinteger(0));
|
||||
for (i = 0; i < j; i++) {
|
||||
vector_set(vec, makeinteger(i), convert(gettupleitem(o,i)));
|
||||
}
|
||||
return vector2list(vec);
|
||||
} else {
|
||||
if is_listobject(o) {
|
||||
int i,j = getlistsize(o);
|
||||
SCM vec;
|
||||
vec = makevect(j,makeinteger(0));
|
||||
for (i = 0; i < j; i++) {
|
||||
vector_set(vec, makeinteger(i), convert(getlistitem(o,i)));
|
||||
}
|
||||
return vector2list(vec);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
PRIMITIVE python_value(SCM dict, SCM var)
|
||||
{
|
||||
object *m, *d, *v;
|
||||
m = add_module(CHARS(dict));
|
||||
if (m == NULL)
|
||||
return UNDEFINED;
|
||||
d = getmoduledict(m);
|
||||
v = dictlookup(d,CHARS(var));
|
||||
return convert(v);
|
||||
}
|
||||
|
||||
char *
|
||||
getprogramname()
|
||||
{
|
||||
return "stk";
|
||||
}
|
||||
|
||||
|
||||
END of file python-stk.c
|
||||
|
||||
The initall() should be done in init_python-stk(). You might know of a
|
||||
better way to convert the data types, or to more efficiently make
|
||||
lists. These were the calls that I found easilly. I also didnt know
|
||||
how to typecheck the arguments passed. They should all be strings.
|
||||
|
||||
|
||||
This is the summary of what I added to primitives.c
|
||||
/*
|
||||
*
|
||||
* p r i m i t i v e s . c -- List of STk subrs
|
||||
*/
|
||||
|
||||
#ifdef USE_PYTHON
|
||||
extern PRIMITIVE python_init(void);
|
||||
extern PRIMITIVE python(SCM string);
|
||||
extern PRIMITIVE python_value(SCM dict, SCM var);
|
||||
#endif
|
||||
|
||||
static struct Primitive Scheme_primitives[] = {
|
||||
.
|
||||
.
|
||||
.
|
||||
|
||||
#ifdef USE_PYTHON
|
||||
{"python-init", tc_subr_0, python_init},
|
||||
{"python", tc_subr_1, python},
|
||||
{"python-value", tc_subr_2, python_value},
|
||||
#endif
|
||||
.
|
||||
.
|
||||
.
|
||||
|
||||
|
||||
|
||||
|
||||
An example.. well, I never used Tk before Stk, so Im not gonna do
|
||||
anything too pretty.
|
||||
|
||||
#!/opt/stk/bin/stk -file
|
||||
|
||||
(python-init) ;This should really be (require "python") or (require "python-stk")
|
||||
(python "import posix") ;Python is a module based language
|
||||
|
||||
(button ".b" :text "Press me" :borderwidth 2 :background "slate gray" :foreground "gold"
|
||||
:command '(begin
|
||||
(python "a = posix.listdir('.')")
|
||||
(for-each (lambda (a) (.f.lb 'insert 99999 a))
|
||||
(python-value "__main__" "a"))))
|
||||
|
||||
(frame ".f")
|
||||
(listbox ".f.lb" :foreground "grey40" :background "grey70" :yscroll ".f.s 'set")
|
||||
(scrollbar ".f.s" :relief "sunken" :command ".f.lb 'yview")
|
||||
|
||||
(pack .f.lb .f.s :side "right" :fill "y")
|
||||
(pack .b .f)
|
||||
|
||||
|
||||
|
||||
Where this would populate a listbox with the filenames in the current
|
||||
directory, everytime the button was pushed. posix.listdir() returns a
|
||||
python 'list' type. __main__ is the name/alias of the primary module.
|
||||
If I could figure out STk calling enough to use variable args, I'd
|
||||
have made (python-value "a") assume a value of "__main__" for the
|
||||
dict..
|
||||
|
||||
|
||||
|
||||
Makefile modifications:
|
||||
|
||||
# This isnt the default python dir, just what I use. should be a
|
||||
# configure option.. --with-python=/opt/python
|
||||
PYTHONDIR = /opt/python
|
||||
PYTHONLIBPATH = $(PYTHONDIR)/lib/python/lib
|
||||
PYTHONCFLAGS = -I$(PYTHONDIR)/include -I$(PYTHONDIR)/include/Py
|
||||
PYTHONOBJ = python-stk.o
|
||||
PYTHONLIB = $(PYLIBPATH)/libModules.a \
|
||||
$(PYLIBPATH)/libPython.a \
|
||||
$(PYLIBPATH)/libParser.a \
|
||||
$(PYLIBPATH)/libObjects.a
|
||||
PYTHONLIBS = -lreadline -ltermcap
|
||||
LIBS = -lnsl -ldl $(PYTHONLIBS) -lm
|
||||
|
||||
|
||||
|
||||
...
|
||||
/bin/rm -f primitives.o
|
||||
make CFLAGS="$(CFLAGS) -DUSE_PYTHON" primitives.o
|
||||
$(CC) -o stkp-bin -DUSE_PYTHON $(OBJ) $(PYTHONOBJ) -I$(PYTHONDIR)/include/Py -DNO_MAIN $(PYTHONLIBPATH)/config.c userinit.c $(ALLIBS) $(XLIBSW) $(PYTHONLIB) $(LIBS)
|
||||
/bin/rm -f primitives.o
|
||||
|
||||
|
||||
Removing primitives.c to recompile with -DUSE_PYTHON is a horrible
|
||||
kludge, as I am sure you agree. The key thing is to also compile in
|
||||
-DNO_MAIN $(PYLIBPATH)/config.c
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
Version 0.2 -- minor bug fixes and new lessons by Erick Gallesio (eg@unice.fr)
|
||||
Version 0.1 -- original writing by Suresh Srinivas (ssriniva@cs.indiana.edu)
|
||||
|
||||
|
||||
TODO
|
||||
----
|
||||
Integrate STklos lessons
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
Scheme/STk Widget Tour 0.2
|
||||
--------------------------
|
||||
|
||||
This is a rewrite of the Tcl/Tk wtour2.0 in Scheme/STk. I wrote it
|
||||
while I was learning the nuances of STk. I also avoided using the send
|
||||
mechanisms to make it quicker/easier to learn (I had to set up all the
|
||||
authentication stuff to have the Tcl/Tk wtour working).
|
||||
|
||||
Installing and Running
|
||||
----------------------
|
||||
|
||||
To start the tour assume that the locations of the STk binary and library
|
||||
in "stk-wtour" are correct. Once this is done, just type
|
||||
% ./stk-wtour
|
||||
|
||||
Use the menus to navigate through different lessons. You can make changes
|
||||
to the lesson source code; click on the Apply button to see the results of
|
||||
the changes.
|
||||
|
||||
Acknowledgements and Notes
|
||||
--------------------------
|
||||
The original,excellent, tour of Tcl/Tk was due to Andrew Payne
|
||||
(payne@crl.dec.com). I hope you enjoy the Scheme version
|
||||
(Adding some STklos lessons is next in the set of things to do).
|
||||
I've tested it on Silicon Graphics running IRIX 5.2 (They are
|
||||
the coolest machines around, look them up).
|
||||
|
||||
Suresh Srinivas,
|
||||
Graduate Student,
|
||||
Parallel Computing Group,
|
||||
Indiana University,
|
||||
(ssriniva@cs.indiana.edu)
|
||||
|
||||
Thesis: Investigating large scale parallel programs.
|
||||
Interests: Parallel Computing, Visualization, Scheming.
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; Event binding
|
||||
|
||||
(entry '.e1 :relief "sunken")
|
||||
(pack .e1 :expand #t :fill "x")
|
||||
|
||||
(bind .e1 "<Tab>" (lambda ()
|
||||
(display "You pressed Tab!\n")))
|
||||
(bind .e1 "<ButtonPress-2>" (lambda ()
|
||||
(display "You pressed Button 2!\n")))
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
;; More event binding
|
||||
|
||||
(entry '.e1 :relief "sunken")
|
||||
(pack .e1 :expand #t :fill "x")
|
||||
|
||||
(bind .e1 "<Enter>" (lambda () (display "ENTERED\n")))
|
||||
(bind .e1 "<Leave>" (lambda () (display "EXITED\n")))
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;; Even more event binding: accessing the event parameters
|
||||
|
||||
(entry '.e1 :relief "sunken")
|
||||
(pack .e1 :expand #t :fill "x")
|
||||
(bind .e1 "<ButtonPress-1>" (lambda (x y)
|
||||
(format #t "button down at ~a,~a\n" x y)))
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
;; A basic button widget
|
||||
|
||||
(button '.hello :text "Hello World!" :command (lambda () (display "hello\n")))
|
||||
(pack .hello)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
;; A button widget, with options
|
||||
|
||||
(button '.hello :text "Hello World!" :relief "raised" :state "disabled")
|
||||
(pack .hello)
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
;;; Animation!
|
||||
|
||||
(pack (canvas '.c1) :expand #t :fill "both")
|
||||
|
||||
(.c1 'create 'rectangle 10 10 40 40 :fill "red" :tag "item")
|
||||
|
||||
(let do-update ()
|
||||
(.c1 'move 'item 1 1)
|
||||
(after 50 (lambda ()
|
||||
(catch (do-update)))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
;;; Moving an object on a canvas
|
||||
;;; (drag the circle around)
|
||||
|
||||
(define last-x 0)
|
||||
(define last-y 0)
|
||||
|
||||
(define (item-start-drag c x y)
|
||||
(set! last-x (c 'canvasx x))
|
||||
(set! last-y (c 'canvasy y)))
|
||||
|
||||
(define (item-drag c x y)
|
||||
(set! x (c 'canvasx x))
|
||||
(set! y (c 'canvasy y))
|
||||
(c 'move 'current (- x last-x) (- y last-y))
|
||||
(set! last-x x)
|
||||
(set! last-y y))
|
||||
|
||||
(pack (canvas '.c1) :expand #t :fill "both")
|
||||
|
||||
(.c1 'create 'oval 150 150 170 170 :fill "skyblue" :tag "oval")
|
||||
|
||||
;;; Bindings
|
||||
(.c1 'bind "oval" "<Any-Enter>" (lambda ()
|
||||
(.c1 'itemconfig 'current :fill "red")))
|
||||
(.c1 'bind "oval" "<Any-Leave>" (lambda ()
|
||||
(.c1 'itemconfig 'current :fill "SkyBlue2")))
|
||||
(.c1 'bind "oval" "<1>" (lambda (x y)
|
||||
(item-start-drag .c1 x y)))
|
||||
(.c1 'bind "oval" "<B1-Motion>" (lambda (x y)
|
||||
(item-drag .c1 x y)))
|
||||
(.c1 'bind "oval" "<ButtonRelease-1>"
|
||||
(lambda ()
|
||||
(.c1 'dtag 'selected)))
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
;;; Drawing in a Canvas
|
||||
;;; (draw with mousebutton 1)
|
||||
|
||||
(pack (canvas '.c1)
|
||||
:fill "both"
|
||||
:expand "yes")
|
||||
|
||||
(bind .c1 "<B1-Motion>" (lambda (x y)
|
||||
(.c1 'create 'rectangle x y x y :width 5)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
;;; Drawing in a Canvas (funky version)
|
||||
;;; (draw with mousebutton 1)
|
||||
|
||||
(define wid 0)
|
||||
|
||||
(pack (canvas '.c1) :expand #t :fill "both")
|
||||
|
||||
(bind .c1 "<ButtonPress-1>" (lambda ()
|
||||
(set! wid 0)))
|
||||
|
||||
(bind .c1 "<B1-Motion>" (lambda (x y)
|
||||
(.c1 'create 'rectangle x y x y :width wid)
|
||||
(set! wid (1+ wid))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
;;; Rubber banding
|
||||
;;; (stroke out a box with mousebutton 1)
|
||||
|
||||
(define x1 0)
|
||||
(define y1 0)
|
||||
|
||||
(define (item-delete c)
|
||||
(c 'delete 'area))
|
||||
|
||||
(define (item-mark c x y)
|
||||
(set! x1 (c 'canvasx x))
|
||||
(set! y1 (c 'canvasy y))
|
||||
(item-delete c))
|
||||
|
||||
(define (item-stroke c x y)
|
||||
(set! x (c 'canvasx x))
|
||||
(set! y (c 'canvasy y))
|
||||
(unless (and (= x1 x) (= y1 y))
|
||||
(item-delete c)
|
||||
(c 'addtag 'area 'withtag (c 'create 'rectangle x1 y1 x y))))
|
||||
|
||||
|
||||
(pack (canvas '.c1) :fill "both" :expand #t)
|
||||
|
||||
(bind .c1 "<ButtonPress-1>" (lambda (x y) (item-mark .c1 x y)))
|
||||
(bind .c1 "<B1-Motion>" (lambda (x y) (item-stroke .c1 x y)))
|
||||
(bind .c1 "<ButtonRelease-1>" (lambda () (item-delete .c1)))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;;; Basic canvas widget
|
||||
|
||||
(canvas '.c1)
|
||||
(pack .c1)
|
||||
|
||||
(.c1 'create 'line 10 10 200 200)
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
;; Canvas item types
|
||||
;; We use here the fact that "wtour-lessondir" contains the path of the
|
||||
;; wtour demo
|
||||
|
||||
(canvas '.c2)
|
||||
(pack .c2 :fill "both" :expand #t)
|
||||
|
||||
(.c2 'create 'arc 10 10 50 50 :fill "red")
|
||||
(.c2 'create 'line 10 100 40 140 :fill "blue")
|
||||
(.c2 'create 'oval 150 150 170 200 :fill "yellow")
|
||||
(.c2 'create 'polygon 200 10 210 50 280 20 :fill "green")
|
||||
(.c2 'create 'rectangle 10 200 30 250 :fill "cyan")
|
||||
(.c2 'create 'text 100 220 :text "Some random text")
|
||||
(.c2 'create 'bitmap 120 70 :bitmap (string-append "@"
|
||||
wtour-lessondir
|
||||
"/../lib/iu.seal.small.xbm"))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
;;; Canvas event bindings
|
||||
;;; (click on the bitmap)
|
||||
|
||||
(canvas '.c1)
|
||||
(pack '.c1 :fill "both" :expand #t)
|
||||
|
||||
(define i (.c1 'create 'bitmap 120 100
|
||||
:bitmap (string-append "@"
|
||||
wtour-lessondir
|
||||
"/../lib/iu.seal.small.xbm")
|
||||
:background "grey"))
|
||||
|
||||
(.c1 'bind i "<Button-1>" (lambda () (display "CLICK\n")))
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
;; Canvas item stacking
|
||||
;; Use mouse button 1 to put a square on top of stack
|
||||
(canvas '.c3)
|
||||
(pack .c3 :fill "both" :expand #t)
|
||||
|
||||
(define r1 (.c3 'create 'rectangle 20 20 80 80 :fill "red"))
|
||||
(define r2 (.c3 'create 'rectangle 60 60 120 120 :fill "green"))
|
||||
(define r3 (.c3 'create 'rectangle 40 40 100 100 :fill "blue"))
|
||||
|
||||
(.c3 'bind r1 "<Button-1>" (lambda () (.c3 'raise r1)))
|
||||
(.c3 'bind r2 "<Button-1>" (lambda () (.c3 'raise r2)))
|
||||
(.c3 'bind r3 "<Button-1>" (lambda () (.c3 'raise r3)))
|
||||
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
;;; Canvas tags
|
||||
|
||||
(pack (canvas '.c1)
|
||||
:fill "both" :expand #t)
|
||||
|
||||
(.c1 'create 'rectangle 20 20 80 80 :fill "red" :tag "cats")
|
||||
(.c1 'create 'rectangle 60 60 120 120 :fill "green" :tag "cats")
|
||||
(.c1 'create 'rectangle 40 40 100 100 :fill "blue" :tag "dogs")
|
||||
|
||||
(.c1 'move 'cats 100 0)
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
;; Canvases with scrollbars
|
||||
|
||||
(canvas '.c4 :scrollregion '(-10c -10c 50c 20c)
|
||||
:xscrollcommand (lambda l (apply .s2 'set l))
|
||||
:yscrollcommand (lambda l (apply .s1 'set l)))
|
||||
|
||||
(.c4 'create 'rectangle 100 100 400 400 :fill "red")
|
||||
(.c4 'create 'rectangle 300 300 600 600 :fill "green")
|
||||
(.c4 'create 'rectangle 200 200 500 500 :fill "blue")
|
||||
|
||||
(scrollbar '.s1 :orient "vert" :relief "sunken"
|
||||
:command (lambda l (apply .c4 'yview l)))
|
||||
(scrollbar '.s2 :orient "hor" :relief "sunken"
|
||||
:command (lambda l (apply .c4 'xview l)))
|
||||
|
||||
(pack .s2 :side "bottom" :fill "x")
|
||||
(pack .s1 :side "right" :fill "y")
|
||||
(pack .c4 :expand "yes" :fill "both")
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
;;; Widgets embedded in a canvas
|
||||
|
||||
(pack (canvas '.c1)
|
||||
:expand #t
|
||||
:fill "both")
|
||||
|
||||
(button '.c1.b1 :text "Embedded button")
|
||||
|
||||
(.c1 'create 'rectangle 20 20 80 80 :fill "red")
|
||||
(.c1 'create 'rectangle 60 60 120 120 :fill "green")
|
||||
(.c1 'create 'rectangle 40 40 100 100 :fill "blue")
|
||||
(.c1 'create 'window 100 75 :window .c1.b1)
|
||||
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; A checkbutton widget
|
||||
|
||||
(checkbutton '.c1 :text "Select me" :anchor "w")
|
||||
(pack .c1 :fill "x")
|
||||
|
||||
;; Shorter ...
|
||||
(pack
|
||||
(checkbutton '.c2 :text "Select me too" :anchor "w")
|
||||
:fill "x")
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
;; A Dialog box
|
||||
|
||||
(define do-dialog
|
||||
(lambda ()
|
||||
(let ([i (stk:make-dialog :title "A Dialog Box"
|
||||
:text "What do you want to do?"
|
||||
:bitmap "question"
|
||||
:grab #t
|
||||
:defaults 0
|
||||
:buttons
|
||||
(list
|
||||
`("Ok" ,(lambda () (display "Ok\n")))
|
||||
`("Cancel" ,(lambda () (display "Cancel\n")))
|
||||
`("Abort" ,(lambda () (display "Abort\n")))
|
||||
`("Retry" ,(lambda () (display "Retry\n"))
|
||||
`("Help" ,(lambda () (display "Help\n"))))))])
|
||||
|
||||
(format #t "You pressed button #~s\n" i))))
|
||||
|
||||
(button '.b :text "Press Me" :width 40 :command (lambda () (do-dialog)))
|
||||
(pack .b :ipadx 10 :ipady 10)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
;;A basic entry widget
|
||||
|
||||
(pack (entry '.e1 :relief "sunken" :background "Light Sky Blue"))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
;; An entry widget with options
|
||||
|
||||
(entry '.e2 :relief "sunken" :font "-*-helvetica-*-r-*-*-*-240-*-*-*-*-*-*")
|
||||
(pack .e2)
|
||||
(.e2 'insert 0 "I'm here!!")
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
;; Basic frames
|
||||
|
||||
(pack [frame '.f1 :background "red" :width 100 :height 100]
|
||||
[frame '.f2 :background "blue" :width 100 :height 100]
|
||||
:side "top"
|
||||
:expand #t
|
||||
:fill "both")
|
||||
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
;; Frames with options
|
||||
|
||||
(frame '.f1 :relief "raised" :borderwidth 3 :width 100 :height 100)
|
||||
(frame '.f2 :relief "sunken" :borderwidth 3 :width 100 :height 100)
|
||||
(pack .f1 .f2 :side "top" :expand #t)
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;; Frames with different options
|
||||
|
||||
(pack
|
||||
[frame '.f1 :relief "ridge" :borderwidth 3 :width 100 :height 30]
|
||||
[frame '.f2 :relief "groove" :borderwidth 3 :width 100 :height 30]
|
||||
:side "top" :expand #t :fill "both" :padx 20 :pady 20)
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; Using frames to group widgets
|
||||
|
||||
(frame '.f1 :relief "ridge" :borderwidth 2)
|
||||
(pack .f1)
|
||||
|
||||
(label '.f1.lab :text "Filename")
|
||||
(entry '.f1.e1 :relief "sunken")
|
||||
|
||||
(pack .f1.lab .f1.e1 :side "left" :padx 10 :pady 10)
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
(lesson "Widgets" "Labels" "label1.stk")
|
||||
(lesson "Widgets" "... options" "label2.stk")
|
||||
(lesson "Widgets" "... with bitmaps" "label3.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Messages" "message.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Basic buttons" "button1.stk")
|
||||
(lesson "Widgets" "... options" "button2.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Checkbuttons" "checkbutton.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Radiobuttons" "radiobutton.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Basic entries" "entry1.stk")
|
||||
(lesson "Widgets" "... options" "entry2.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Basic scales" "scale1.stk")
|
||||
(lesson "Widgets" "... options" "scale2.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Basic listboxes" "listbox1.stk")
|
||||
(lesson "Widgets" "... with scrollbars" "listbox2.stk")
|
||||
(lesson "Widgets" "" "")
|
||||
(lesson "Widgets" "Basic Menu" "menu1.stk")
|
||||
(lesson "Widgets" "... options" "menu2.stk")
|
||||
|
||||
(lesson "Geometry" "Basic Packer" "pack1.stk")
|
||||
(lesson "Geometry" "... with options" "pack2.stk")
|
||||
(lesson "Geometry" "... more options" "pack3.stk")
|
||||
(lesson "Geometry" "" "")
|
||||
(lesson "Geometry" "Basic Frames" "frame1.stk")
|
||||
(lesson "Geometry" "... with options" "frame2.stk")
|
||||
(lesson "Geometry" "... more options" "frame3.stk")
|
||||
(lesson "Geometry" "" "")
|
||||
(lesson "Geometry" "Grouping widgets" "grouping.stk")
|
||||
|
||||
(lesson "Events" "Binding events" "bind1.stk")
|
||||
(lesson "Events" "Binding events #2" "bind2.stk")
|
||||
(lesson "Events" "Binding events #3" "bind3.stk")
|
||||
|
||||
(lesson "Canvas" "Basic canvas" "canvas1.stk")
|
||||
(lesson "Canvas" "... item types" "canvas2.stk")
|
||||
(lesson "Canvas" "... events" "canvas3.stk")
|
||||
(lesson "Canvas" "... item stacking" "canvas4.stk")
|
||||
(lesson "Canvas" "... tags" "canvas5.stk")
|
||||
(lesson "Canvas" "... with scrollbars" "canvas6.stk")
|
||||
(lesson "Canvas" "... with widgets" "canvas7.stk")
|
||||
(lesson "Canvas" "" "")
|
||||
(lesson "Canvas" "Drawing" "canvas-draw.stk")
|
||||
(lesson "Canvas" "Funky drawing" "canvas-funky.stk")
|
||||
(lesson "Canvas" "Rubber banding" "canvas-rubber.stk")
|
||||
(lesson "Canvas" "Animation" "canvas-animate.stk")
|
||||
(lesson "Canvas" "Drag and Drop" "canvas-drag.stk")
|
||||
|
||||
(lesson "Text" "Basic \"Text\"" "text1.stk")
|
||||
(lesson "Text" "... with scrollbars" "text2.stk")
|
||||
(lesson "Text" "... wrap modes" "text3.stk")
|
||||
(lesson "Text" "... basic tags" "text4.stk")
|
||||
(lesson "Text" "... tags with bindings" "text5.stk")
|
||||
|
||||
(lesson "Misc" "New toplevel windows" "misc.stk")
|
||||
(lesson "Misc" "Dialog boxes" "dialogbox.stk")
|
||||
|
||||
;; find a better way to do the options (so that they can be cleared)
|
||||
;; (lesson "Misc" "Widget options" "options.stk")
|
||||
|
||||
(lesson "Misc" "X selection" "selection.stk")
|
||||
(lesson "Misc" "Tk wait" "tkwait.stk")
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
(label '.lab :text "This is a label")
|
||||
(pack .lab)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(pack
|
||||
(label '.lab1 :text "This is a label1" :relief "sunken"))
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
;; A label widget, with a bitmap instead of text
|
||||
;; We use here the fact that "wtour-lessondir" contains the path of the
|
||||
;; wtour demo
|
||||
|
||||
|
||||
(label '.lab2 :bitmap (string-append "@" wtour-lessondir "/../lib/iu.ridge.xbm")
|
||||
:relief "raised"
|
||||
:borderwidth 2)
|
||||
(pack .lab2)
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
;; Basic listbox widget
|
||||
|
||||
(pack (listbox '.list))
|
||||
|
||||
(.list 'insert 'end "First list item"
|
||||
"Second list item"
|
||||
"Third list item")
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
;; Listbox with a scrollbar
|
||||
|
||||
(scrollbar '.scroll :relief "groove" :command (lambda l
|
||||
(apply .list 'yview l)))
|
||||
(listbox '.list :yscroll (lambda l
|
||||
(apply .scroll 'set l)))
|
||||
|
||||
(pack .scroll :side "right" :fill "y")
|
||||
(pack .list :side "left" :expand #t :fill "both")
|
||||
|
||||
(.list 'insert 'end "First list item"
|
||||
"Second list item"
|
||||
"Third list item"
|
||||
"Fourth list item"
|
||||
"Fifth list item"
|
||||
"Sixth list item"
|
||||
"Seventh list item"
|
||||
"Eighth list item"
|
||||
"Ninth list item"
|
||||
"Tenth list item"
|
||||
"Eleventh list item"
|
||||
"Twelfth list item"
|
||||
"Thirteenth list item"
|
||||
"Fourteenth list item"
|
||||
"Fifteenth list item"
|
||||
"Sixteenth list item"
|
||||
"Seventeenth list item"
|
||||
"Eighteenth list item"
|
||||
"Ninteenth list item")
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; Basic drop down menu
|
||||
|
||||
(pack (menubutton '.mbutton :text "Menu Button" :menu ".mbutton.menu"))
|
||||
|
||||
(menu '.mbutton.menu)
|
||||
(.mbutton.menu 'add 'command :label "Open")
|
||||
(.mbutton.menu 'add 'command :label "Close")
|
||||
(.mbutton.menu 'add 'separator)
|
||||
(.mbutton.menu 'add 'command :label "Exit")
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
;; Menu options
|
||||
|
||||
(pack (menubutton '.mbutton :text "Menu Button1" :menu '.mbutton.menu))
|
||||
|
||||
(menu '.mbutton.menu)
|
||||
(.mbutton.menu 'add 'command :label "Open" :command (lambda ()
|
||||
(display "open\n")))
|
||||
(.mbutton.menu 'add 'command :label "Close" :state "disabled")
|
||||
(.mbutton.menu 'add 'cascade :label "More -->" :menu '.mbutton.menu.more)
|
||||
(.mbutton.menu 'add 'separator)
|
||||
(.mbutton.menu 'add 'command :label "Exit" :command (lambda ()
|
||||
(display "exit\n")))
|
||||
|
||||
(menu '.mbutton.menu.more)
|
||||
(.mbutton.menu.more 'add 'command :label "Get" :command (lambda ()
|
||||
(display "get\n")))
|
||||
(.mbutton.menu.more 'add 'command :label "Put" :command (lambda ()
|
||||
(display "put\n")))
|
||||
(.mbutton.menu.more 'add 'command :label "Rename" :command (lambda ()
|
||||
(display "rename\n")))
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
;; A message widget
|
||||
|
||||
(message '.m :text "This is a message. Note how the lines wrap"
|
||||
:aspect 200
|
||||
:justify "center")
|
||||
(pack .m)
|
||||
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
;; New toplevel window
|
||||
|
||||
(toplevel '.new)
|
||||
(wm 'geometry .new "200x200")
|
||||
(wm 'title .new "A new window")
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; Widget options
|
||||
|
||||
(option 'add "*background" "red")
|
||||
(option 'add "*Button.foreground" "white")
|
||||
|
||||
(button '.a :text "Press Me!")
|
||||
(button '.b :text "And Me Too!")
|
||||
(pack .a .b)
|
||||
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
;; Basic geometry management with the packer
|
||||
|
||||
(label '.l1 :text "Label #1" :background "red")
|
||||
(label '.l2 :text "Label #2" :background "blue")
|
||||
(label '.l3 :text "Label #3" :background "green")
|
||||
|
||||
(pack .l1 :side "top")
|
||||
(pack .l2 :side "left")
|
||||
(pack .l3 :side "bottom")
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
;; Basic geometry management with the packer (fill and expand options)
|
||||
|
||||
(label '.l4 :text "Label #4" :background "red")
|
||||
(label '.l5 :text "Label #5" :background "blue")
|
||||
(label '.l6 :text "Label #6" :background "green")
|
||||
|
||||
(pack .l4 :side "top" :fill "both")
|
||||
(pack .l5 :side "left" :fill "both")
|
||||
(pack .l6 :side "bottom" :fill "both")
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
;; Basic geometry management with the packer (fill and expand options)
|
||||
|
||||
(label '.l4 :text "Label #4" :background "red")
|
||||
(label '.l5 :text "Label #5" :background "blue")
|
||||
(label '.l6 :text "Label #6" :background "green")
|
||||
|
||||
|
||||
(pack .l4 :side "top" :fill "both" :padx 20 :pady 20)
|
||||
(pack .l5 :side "left" :fill "both" :padx 20 :pady 20)
|
||||
(pack .l6 :side "bottom" :fill "both" :padx 20 :pady 20)
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
;; A set of radio button widgets
|
||||
|
||||
(define color-var1 #f) ;; The variable to which radiobuttons are "connected"
|
||||
|
||||
(radiobutton '.b1 :text "Red" :variable 'color-var1 :value "R" :anchor "w")
|
||||
(radiobutton '.b2 :text "Green" :variable 'color-var1 :value "G" :anchor "w")
|
||||
(radiobutton '.b3 :text "Blue" :variable 'color-var1 :value "B" :anchor "w")
|
||||
(pack .b1 .b2 .b3 :fill "x")
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
;; A basic scale widget
|
||||
|
||||
(pack (scale '.s1))
|
||||
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
;; A scale widget with options
|
||||
|
||||
(define (display-value n)
|
||||
(format #t "Flow 1 = ~A\n" n))
|
||||
|
||||
(scale '.s1 :label "Flow 1" :from -1000 :to 1000 :orient "horizontal"
|
||||
:command display-value)
|
||||
(pack .s1)
|
||||
|
||||
;; We could avoid the display-value definition by doing
|
||||
(scale '.s2 :label "Flow 2" :from -1000 :to 1000 :orient "horizontal"
|
||||
:command (lambda (n)
|
||||
(format #t "Flow 2 = ~A\n" n)))
|
||||
(pack .s2)
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
;; X Selection
|
||||
|
||||
(pack
|
||||
[label '.lab :text "Selection is:" :anchor "w"]
|
||||
[text '.t :relief "raised" :bd 1 :height 15]
|
||||
[button '.b1 :text "Get Selection"
|
||||
:command (lambda ()
|
||||
;; Clear text buffer
|
||||
(.t 'delete "1.0" "end")
|
||||
;; Insert selection if it exists
|
||||
(unless (catch (selection 'get))
|
||||
(.t 'insert "1.0" (selection 'get))))])
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;;; Basic text widget
|
||||
|
||||
(pack (text '.text))
|
||||
|
||||
(.text 'insert "current" "This is a text widget, displaying some text.\n")
|
||||
(.text 'insert "current" "Try editing the text in the widget.\n")
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
;;; A basic text widget, with scrollbars
|
||||
|
||||
(text '.text :yscroll (lambda l (apply .scroll 'set l)))
|
||||
(scrollbar '.scroll :relief "flat" :command (lambda l (apply .text 'yview l)))
|
||||
|
||||
(pack .scroll :side "right" :fill "y")
|
||||
(pack .text :expand "yes" :fill "both")
|
||||
|
||||
(.text 'insert "current"
|
||||
"This is a text widget, with an attached scrollbar.\n")
|
||||
(.text 'insert "current"
|
||||
"\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nTry scrolling me.")
|
||||
(.text 'insert "current" "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nBoo!")
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
;;; A basic text widget, with word wrapping
|
||||
|
||||
(pack (text '.text :wrap "word"))
|
||||
|
||||
(.text 'insert "current" "This is a text widget, displaying some text. ")
|
||||
(.text 'insert "current" "Notice how lines are broken at words.\n")
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
;;; A basic text widget, with basic text tagging
|
||||
|
||||
(text '.text :yscrollcommand (lambda l (apply .scroll 'set l)) :wrap "word")
|
||||
(scrollbar '.scroll :relief "flat" :command (lambda l (apply l .text 'yview l)))
|
||||
|
||||
(pack .scroll :side "right" :fill "y")
|
||||
(pack .text :expand #t :fill "both")
|
||||
|
||||
(.text 'insert 'current
|
||||
"This is a text widget, with some tagged text:\n\n\n\n
|
||||
Some tagged text.")
|
||||
|
||||
(.text 'tag 'configure 'footag :relief "raised" :borderwidth 3 :background "white")
|
||||
(.text 'tag 'add 'footag "end-1l linestart" "end-1c")
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
;;; A basic text widget, with tag bindings
|
||||
|
||||
(text '.text :yscrollcommand (lambda l (apply .scroll 'set l)) :wrap "word")
|
||||
(scrollbar '.scroll :relief "flat" :command (lambda l (apply l .text 'yview l)))
|
||||
|
||||
(pack .scroll :side "right" :fill "y")
|
||||
(pack .text :expand #t :fill "both")
|
||||
|
||||
|
||||
(.text 'insert 'current
|
||||
"This is a text widget, with some tagged text:\n\n\n\n
|
||||
Press me!!!")
|
||||
|
||||
(.text 'tag 'configure 'footag :relief "raised" :borderwidth 3 :background "bisque")
|
||||
(.text 'tag 'add 'footag "end-1l linestart" "end-1c")
|
||||
|
||||
(.text 'tag 'bind 'footag "<ButtonPress-1>" (lambda () (display "Gotcha!\n")))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
;; tkwait, used for waiting for dialog input
|
||||
|
||||
(define tkwait-label #f)
|
||||
|
||||
(define make-panel
|
||||
(lambda ()
|
||||
(toplevel '.top)
|
||||
(button '.top.ok
|
||||
:text "OK"
|
||||
:command (lambda ()
|
||||
(set! tkwait-label "ok")
|
||||
(destroy .top)))
|
||||
(button '.top.cancel
|
||||
:text "Cancel"
|
||||
:command (lambda ()
|
||||
(set! tkwait-label "cancel")
|
||||
(destroy .top)))
|
||||
|
||||
(pack .top.ok .top.cancel :side "left" :padx "10" :pady "10")
|
||||
(grab 'set .top)
|
||||
(tkwait 'window .top)
|
||||
tkwait-label))
|
||||
|
||||
(button '.b
|
||||
:text "Try pressing me!"
|
||||
:command (lambda ()
|
||||
(let ([x (make-panel)])
|
||||
(format #t "You pressed ~a\n" x))))
|
||||
|
||||
(pack .b)
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
#define iu_width 88
|
||||
#define iu_height 124
|
||||
static char iu_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0xff, 0xff, 0x1f,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x10, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0xc0, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0xe0, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0,
|
||||
0x0f, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f,
|
||||
0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00,
|
||||
0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00,
|
||||
0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x10, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0x01, 0xc0, 0x1f, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0xe0, 0xff, 0x01, 0xc0, 0x1f, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0xe0, 0xff, 0x01, 0xc0, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xe0, 0xff, 0x01, 0xc0, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0xe0, 0xff, 0x01, 0xc0, 0x03, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff,
|
||||
0xff, 0x01, 0xc0, 0x81, 0xff, 0xff, 0xff, 0x60, 0x00, 0x00, 0x80, 0xfd,
|
||||
0x01, 0xc0, 0xc0, 0x00, 0x00, 0x80, 0x70, 0x00, 0x00, 0x80, 0xfd, 0x01,
|
||||
0xc0, 0xe0, 0x00, 0x00, 0x80, 0x78, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0,
|
||||
0xf0, 0x00, 0x00, 0x80, 0x7c, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xf8,
|
||||
0x00, 0x00, 0x80, 0x7e, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00,
|
||||
0x00, 0x80, 0x7f, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00,
|
||||
0x80, 0x7f, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80,
|
||||
0x7f, 0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f,
|
||||
0x00, 0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f, 0x00,
|
||||
0x00, 0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00,
|
||||
0x80, 0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x80,
|
||||
0xfd, 0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x80, 0xfd,
|
||||
0x01, 0xc0, 0xfc, 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x80, 0xfd, 0x01,
|
||||
0xc0, 0xfc, 0x00, 0x00, 0x80, 0xff, 0x1f, 0x00, 0xfc, 0xfd, 0x01, 0xc0,
|
||||
0xfc, 0x3f, 0x00, 0xfc, 0xff, 0x1f, 0x00, 0xfc, 0xfc, 0x01, 0xc0, 0xfc,
|
||||
0x3f, 0x00, 0xfc, 0xff, 0x1f, 0x00, 0x7c, 0xfc, 0x01, 0xc0, 0xfc, 0x3f,
|
||||
0x00, 0x7c, 0xff, 0x1f, 0x00, 0x3c, 0xfc, 0x01, 0xc0, 0xfc, 0x3f, 0x00,
|
||||
0x3c, 0xff, 0x1f, 0x00, 0x1c, 0xfc, 0x01, 0xc0, 0xfc, 0x3f, 0x00, 0x1c,
|
||||
0xff, 0x1f, 0x00, 0x0c, 0xfc, 0x01, 0xc0, 0xfc, 0x3f, 0x00, 0x0c, 0xff,
|
||||
0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xfc, 0x3f, 0x00, 0x0c, 0xff, 0x1f,
|
||||
0x00, 0x04, 0xfc, 0x01, 0xc0, 0xfc, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00,
|
||||
0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04,
|
||||
0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc,
|
||||
0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01,
|
||||
0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0,
|
||||
0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0,
|
||||
0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f,
|
||||
0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00,
|
||||
0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c,
|
||||
0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0,
|
||||
0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f,
|
||||
0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00,
|
||||
0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04,
|
||||
0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc,
|
||||
0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01,
|
||||
0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0,
|
||||
0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0,
|
||||
0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f,
|
||||
0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00,
|
||||
0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c,
|
||||
0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0,
|
||||
0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f,
|
||||
0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00,
|
||||
0x04, 0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04,
|
||||
0xfc, 0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc,
|
||||
0x01, 0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01,
|
||||
0xc0, 0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0,
|
||||
0xc0, 0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0x04, 0xfc, 0x01, 0xc0, 0xc0,
|
||||
0x3f, 0x00, 0x0c, 0xc0, 0x1f, 0x00, 0xfc, 0xff, 0x01, 0xc0, 0xff, 0x3f,
|
||||
0x00, 0x0c, 0xc0, 0x1f, 0x00, 0xfc, 0xff, 0x01, 0xc0, 0xff, 0x3f, 0x00,
|
||||
0x0c, 0xc0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c,
|
||||
0xc0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c, 0xc0,
|
||||
0x1f, 0x00, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c, 0xc0, 0x3f,
|
||||
0x00, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c, 0xc0, 0x7f, 0x00,
|
||||
0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c, 0xc0, 0xff, 0x00, 0x00,
|
||||
0xfc, 0x01, 0xc0, 0x00, 0x00, 0x00, 0x0c, 0xc0, 0xff, 0x01, 0x00, 0xfc,
|
||||
0x01, 0xc0, 0x00, 0x00, 0x00, 0x0e, 0x00, 0xff, 0x03, 0x00, 0xfc, 0x01,
|
||||
0xc0, 0x00, 0x00, 0x80, 0x0f, 0x00, 0xfc, 0x07, 0x00, 0xfc, 0x01, 0xc0,
|
||||
0x00, 0x00, 0xc0, 0x07, 0x00, 0xf8, 0x0f, 0x00, 0xfc, 0x01, 0xc0, 0x00,
|
||||
0x00, 0xe0, 0x01, 0x00, 0xf0, 0x1f, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00,
|
||||
0xf0, 0x00, 0x00, 0xe0, 0x3f, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x38,
|
||||
0x00, 0x00, 0xc0, 0x7f, 0x00, 0xfc, 0x01, 0xc0, 0x00, 0x00, 0x1e, 0x00,
|
||||
0x00, 0x80, 0xff, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x0f, 0x00, 0x00,
|
||||
0x00, 0xff, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x07, 0x00, 0x00, 0x00,
|
||||
0xfe, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xfc,
|
||||
0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0xf8, 0xff,
|
||||
0xff, 0x01, 0xc0, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xf0, 0xff, 0xff,
|
||||
0x01, 0xc0, 0xff, 0x3f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x01,
|
||||
0xc0, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0f, 0x00, 0x00,
|
||||
0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x30,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x0f, 0x00, 0x00, 0x30, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0xe0, 0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0,
|
||||
0x0f, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f,
|
||||
0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00,
|
||||
0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00,
|
||||
0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x00, 0x30,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0xff, 0x3f, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0xff, 0x1f, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0xe0, 0xff, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xe0, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0xe0, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00};
|
||||
|
|
@ -0,0 +1,136 @@
|
|||
#define iu_width 124
|
||||
#define iu_height 124
|
||||
static char iu_bits[] = {
|
||||
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
|
||||
0xf0,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0x03,0x00,0x00,0x00,0x00,
|
||||
0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0xff,0x3f,0x00,0x00,0x00,
|
||||
0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0x3f,0xff,0xff,0x03,0x00,
|
||||
0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0xff,0x0f,0x00,0x00,0xfe,0x1f,
|
||||
0x00,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0xc0,0xff,0x00,0x00,0x00,0xc0,
|
||||
0x7f,0x00,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0xf0,0x0f,0x00,0xf8,0x38,
|
||||
0x00,0xfe,0x01,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0xfc,0x03,0xcc,0x08,
|
||||
0xe8,0x00,0xf0,0x07,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0x7f,0x80,0xc9,
|
||||
0x08,0x88,0x70,0xc0,0x1f,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0xc0,0x1f,0x80,
|
||||
0xd9,0x78,0xd8,0xd8,0x00,0x7f,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0xe0,0x07,
|
||||
0x88,0xd1,0x08,0x7c,0x98,0x00,0xfc,0x01,0x00,0x00,0xf0,0x00,0x00,0x00,0xf8,
|
||||
0x81,0x19,0x71,0x08,0xcc,0x30,0x58,0xf0,0x03,0x00,0x00,0xf0,0x00,0x00,0x00,
|
||||
0xfc,0x80,0x1b,0x63,0xf8,0x4c,0x64,0xc8,0xc1,0x07,0x00,0x00,0xf0,0x00,0x00,
|
||||
0x00,0x3e,0x88,0x37,0x63,0x00,0xc0,0xcc,0x8c,0x87,0x1f,0x00,0x00,0xf0,0x00,
|
||||
0x00,0x80,0x0f,0x08,0x3f,0x02,0x00,0x00,0x78,0x84,0x05,0x3e,0x00,0x00,0xf0,
|
||||
0x00,0x00,0xc0,0x07,0x18,0x33,0x00,0xc0,0x00,0x00,0xc6,0x00,0x7c,0x00,0x00,
|
||||
0xf0,0x00,0x00,0xe0,0x83,0x31,0x22,0xe0,0x3f,0xff,0x00,0xc6,0x60,0xf8,0x00,
|
||||
0x00,0xf0,0x00,0x00,0xf0,0x00,0x23,0x06,0x1e,0x00,0x00,0x0f,0x60,0xf0,0xe0,
|
||||
0x01,0x00,0xf0,0x00,0x00,0x78,0x00,0x63,0xc0,0x01,0x00,0x00,0x70,0x20,0x58,
|
||||
0xc0,0x03,0x00,0xf0,0x00,0x00,0x3c,0x00,0x26,0x70,0x00,0x00,0x00,0x80,0x01,
|
||||
0x6e,0x80,0x07,0x00,0xf0,0x00,0x00,0x1e,0x00,0x1c,0x0c,0x00,0x00,0x00,0x00,
|
||||
0x06,0x7e,0x08,0x0f,0x00,0xf0,0x00,0x00,0x0f,0x00,0x00,0x03,0x00,0x02,0x18,
|
||||
0x00,0x18,0x30,0x18,0x1e,0x00,0xf0,0x00,0x80,0x07,0x00,0xc0,0x00,0x00,0x06,
|
||||
0x14,0x00,0x60,0x30,0x38,0x3c,0x00,0xf0,0x00,0xc0,0x03,0x00,0x20,0x00,0x00,
|
||||
0x09,0x22,0x00,0x80,0x21,0x4c,0x78,0x00,0xf0,0x00,0xc0,0x01,0x00,0x18,0xc0,
|
||||
0x81,0x10,0x42,0x60,0x00,0x03,0x06,0xf0,0x00,0xf0,0x00,0xe0,0x01,0x00,0x0c,
|
||||
0x40,0x86,0x50,0x02,0x98,0x00,0x04,0x03,0xe1,0x00,0xf0,0x00,0xf0,0x00,0x00,
|
||||
0x02,0x40,0x24,0xb0,0x22,0x80,0x00,0x18,0x81,0xe1,0x01,0xf0,0x00,0x78,0x38,
|
||||
0x00,0x01,0x00,0xc8,0x11,0xe3,0x85,0x00,0x30,0xc0,0xc0,0x03,0xf0,0x00,0x38,
|
||||
0x8c,0x80,0x00,0x40,0x98,0x11,0x23,0x86,0x00,0x60,0x60,0x80,0x07,0xf0,0x00,
|
||||
0x3c,0xec,0x61,0xe0,0x40,0x18,0x11,0x21,0x82,0x80,0xc1,0x38,0x0e,0x07,0xf0,
|
||||
0x00,0x1e,0x3c,0x21,0x20,0xb3,0x10,0x31,0x21,0x42,0x33,0x81,0x01,0x1b,0x0f,
|
||||
0xf0,0x00,0x0e,0x18,0x11,0x20,0x94,0x10,0x31,0x31,0x43,0x0a,0x01,0xc3,0x12,
|
||||
0x0e,0xf0,0x00,0x0f,0xe1,0x08,0x20,0x88,0x31,0x33,0x11,0x61,0x06,0x01,0x46,
|
||||
0x1a,0x1e,0xf0,0x00,0x07,0x47,0x04,0x20,0x18,0x21,0x22,0x11,0x21,0x06,0x01,
|
||||
0xc4,0x06,0x3c,0xf0,0x80,0x07,0x0e,0x02,0x40,0x10,0x23,0x00,0x80,0x31,0x83,
|
||||
0x00,0x88,0x03,0x38,0xf0,0x80,0x03,0x38,0x02,0x80,0x30,0x62,0x00,0x80,0x10,
|
||||
0x41,0x00,0x10,0x01,0x38,0xf0,0xc0,0x03,0x20,0x01,0xe0,0x61,0x46,0x51,0x8a,
|
||||
0x98,0xe1,0x01,0x30,0x00,0x70,0xf0,0xc0,0x61,0x80,0xc0,0x17,0x43,0x44,0x51,
|
||||
0xce,0xc8,0x30,0xf8,0x20,0x00,0x70,0xf0,0xe0,0x31,0x87,0x40,0x18,0xc2,0xcc,
|
||||
0x51,0x44,0x4c,0x18,0x84,0x40,0x00,0xe0,0xf0,0xe0,0x90,0x45,0x40,0x30,0x84,
|
||||
0x89,0x51,0x4e,0x66,0x08,0x83,0x40,0x00,0xe0,0xf0,0xf0,0xf0,0x24,0x40,0x60,
|
||||
0x08,0x91,0x67,0x4a,0x26,0x84,0x41,0x80,0x00,0xe0,0xf1,0xf0,0x40,0x26,0x80,
|
||||
0xc0,0x10,0x93,0x00,0x00,0x13,0xc2,0x60,0x80,0x00,0xc0,0xf1,0x70,0x00,0x03,
|
||||
0x00,0x83,0x21,0x26,0xa9,0x25,0x1b,0x63,0x10,0x00,0x01,0xc0,0xf1,0x78,0x00,
|
||||
0x10,0x80,0x07,0x63,0x24,0xa9,0xb5,0x89,0x31,0x3c,0x00,0x01,0xc0,0xf3,0x38,
|
||||
0x1c,0x10,0x00,0x1c,0xc6,0x4c,0xfb,0x97,0xc5,0x18,0x4e,0x00,0x02,0x86,0xf3,
|
||||
0x38,0xf0,0x08,0x90,0x70,0xff,0xff,0xff,0xff,0xff,0xbf,0x43,0x02,0x42,0x8f,
|
||||
0xf3,0x38,0xc0,0x09,0xe7,0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0x19,0x66,
|
||||
0x8b,0xf7,0x3c,0x7e,0x0c,0x81,0x83,0x19,0x00,0x40,0x00,0x00,0x66,0x70,0x10,
|
||||
0x24,0x0b,0xf7,0x1c,0x1e,0x04,0x02,0x0e,0x19,0x00,0x00,0x00,0x00,0x26,0x1c,
|
||||
0x00,0x64,0x0b,0xf7,0x1c,0xf8,0x04,0x04,0x38,0x19,0x00,0x00,0x00,0x00,0x26,
|
||||
0x07,0x08,0xc8,0x01,0xf7,0x1c,0xc0,0x04,0x1c,0xe0,0x99,0xfb,0x1e,0x3e,0x3f,
|
||||
0xe6,0x01,0x06,0x08,0x00,0xff,0x1e,0x00,0x02,0xe0,0x80,0x99,0xfb,0x1e,0x3e,
|
||||
0x3f,0x66,0xc0,0x01,0x08,0x00,0xfe,0x0e,0x01,0x02,0x98,0x07,0x19,0x00,0x00,
|
||||
0x00,0x00,0x26,0x78,0x02,0x08,0x3e,0xfe,0x0e,0x49,0x02,0x08,0x3c,0x19,0x00,
|
||||
0x00,0x00,0x00,0xa6,0x07,0x02,0xd0,0x07,0xfe,0x0e,0x49,0x02,0x00,0xe0,0x99,
|
||||
0xe7,0x1f,0xfe,0x33,0xe6,0x00,0x02,0x10,0x00,0xfe,0x0e,0x4d,0x02,0x7f,0x00,
|
||||
0x19,0x00,0x00,0x00,0x00,0x26,0xc0,0x3f,0x10,0x1e,0xfe,0x8e,0x7f,0xc1,0xe0,
|
||||
0x0f,0x19,0x00,0x00,0x00,0x00,0x26,0x7e,0xc0,0x10,0x3f,0xfe,0x0e,0x7c,0x21,
|
||||
0x00,0xfc,0x99,0xcf,0x1f,0x4e,0x3e,0xe6,0x03,0x80,0x90,0x21,0xfe,0x0e,0x00,
|
||||
0x41,0x00,0x80,0x99,0xcf,0x1f,0x4e,0x3e,0x26,0x00,0x40,0x90,0x61,0xfe,0x0e,
|
||||
0x00,0x81,0x00,0x00,0x19,0x00,0x00,0x00,0x00,0x26,0x00,0x20,0x90,0x65,0xfc,
|
||||
0x0e,0x00,0x01,0xff,0x7f,0x19,0x00,0x00,0x00,0x00,0xe6,0xff,0x03,0x10,0x37,
|
||||
0xfc,0x8f,0x3f,0x01,0x08,0xf8,0x99,0xf3,0x1c,0xfe,0x3d,0x66,0x00,0x04,0x90,
|
||||
0x17,0xfc,0x07,0x1c,0x01,0x04,0x00,0x19,0x00,0x00,0x00,0x00,0x26,0x00,0x08,
|
||||
0x10,0x00,0xfc,0x07,0x06,0x01,0x08,0xf0,0x19,0x00,0x00,0x00,0x00,0xe6,0x1f,
|
||||
0x04,0x10,0x00,0xfc,0x8e,0x3f,0x01,0xff,0xff,0x99,0x7f,0x1e,0x9e,0x3f,0x26,
|
||||
0xfe,0x1f,0x90,0x7f,0xfc,0x8e,0x3f,0x81,0x00,0x00,0x99,0x7f,0x1e,0x9e,0x3f,
|
||||
0x26,0x00,0x20,0x90,0x7f,0xfc,0x0e,0x00,0x81,0x00,0x80,0x19,0x00,0x00,0x00,
|
||||
0x00,0xe6,0x00,0x40,0x10,0x00,0xfe,0x0e,0x00,0x41,0x00,0xfc,0x19,0x00,0x00,
|
||||
0x00,0x00,0xe6,0x1f,0x80,0x90,0x03,0xfe,0x0e,0x40,0xc1,0xe0,0x1f,0x99,0xf3,
|
||||
0x19,0xce,0x39,0x26,0xfc,0x63,0x90,0x3f,0xfe,0x0e,0x70,0x02,0xff,0x00,0x99,
|
||||
0xf3,0x19,0xce,0x39,0x26,0x80,0x19,0x90,0x20,0xfe,0x0e,0x3c,0x02,0x10,0xe0,
|
||||
0x19,0x00,0x00,0x00,0x00,0xe6,0x01,0x02,0xd0,0x00,0xfe,0x0e,0x27,0x02,0x08,
|
||||
0x3c,0x99,0x9f,0x1f,0x7e,0x3e,0x26,0x1f,0x02,0xc8,0x00,0xfe,0x0e,0x3f,0x02,
|
||||
0x90,0x03,0x99,0x9f,0x1f,0x7e,0x3e,0x26,0xf8,0x01,0x08,0x00,0xfe,0x1e,0xfc,
|
||||
0x02,0x70,0x80,0x19,0x00,0x00,0x00,0x00,0x66,0x80,0x01,0x08,0x00,0xfe,0x1c,
|
||||
0x00,0x04,0x0c,0x60,0x19,0x00,0x00,0x00,0x00,0xe6,0x01,0x04,0xc8,0x00,0xff,
|
||||
0x1c,0x80,0x04,0x04,0x18,0x19,0x00,0x00,0x00,0x00,0x26,0x07,0x08,0xe4,0x07,
|
||||
0xf7,0x1c,0xf8,0x05,0x02,0x06,0x19,0x00,0x40,0x00,0x00,0x26,0x1c,0x10,0x24,
|
||||
0x1c,0xf7,0x1c,0x1e,0x08,0x82,0xc1,0x19,0x00,0xc0,0x00,0x00,0x66,0x70,0x10,
|
||||
0x24,0x00,0xf7,0x38,0x00,0x08,0xaf,0x60,0xff,0xff,0xff,0xff,0xff,0xff,0xa0,
|
||||
0x1f,0x22,0x80,0xf7,0x38,0xc0,0x09,0x80,0x30,0xff,0xff,0xff,0xff,0xff,0xbf,
|
||||
0x03,0x00,0x02,0x80,0xf3,0x38,0xf0,0x13,0x80,0x0c,0xc6,0x6c,0xa9,0xb6,0x4c,
|
||||
0x0c,0x66,0x00,0x02,0x80,0xf3,0x78,0x18,0x12,0x00,0x06,0x63,0x36,0xa9,0x24,
|
||||
0x99,0x30,0x1c,0x00,0x79,0xc0,0xf3,0x70,0x18,0x26,0x00,0x81,0x31,0xb2,0xad,
|
||||
0x24,0x1b,0x61,0x30,0x00,0xcd,0xc1,0xf1,0x70,0x18,0x27,0x80,0x40,0x00,0x00,
|
||||
0x00,0x00,0x00,0xc0,0x40,0x80,0x0c,0xc3,0xf1,0xf0,0xd0,0x43,0x00,0x20,0x00,
|
||||
0x00,0x00,0x00,0x00,0x80,0x41,0x80,0x0c,0xe0,0xf1,0xe0,0x70,0x40,0x40,0x10,
|
||||
0x14,0x42,0x8a,0x52,0xc4,0x09,0x03,0x40,0x38,0xe0,0xf0,0xe0,0x11,0x90,0x40,
|
||||
0x18,0x72,0x82,0x99,0x53,0xca,0x18,0x85,0x20,0xe0,0xe0,0xf0,0xc0,0x01,0x1c,
|
||||
0xc1,0x07,0x11,0x82,0x89,0x52,0x2e,0x31,0xf9,0x20,0x81,0x70,0xf0,0xc0,0x03,
|
||||
0x1e,0x01,0xe0,0x71,0x82,0xb9,0x52,0xca,0x60,0x00,0x10,0x03,0x70,0xf0,0x80,
|
||||
0x83,0x0b,0x02,0x80,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0x08,0x0e,0x78,0xf0,
|
||||
0x80,0x87,0x6c,0x04,0x40,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0xcc,0x1f,0x38,
|
||||
0xf0,0x00,0x07,0x3c,0x0c,0x00,0x18,0x31,0x33,0x11,0x21,0x06,0x00,0xa4,0x3e,
|
||||
0x3c,0xf0,0x00,0x0f,0x1e,0x19,0x00,0x94,0x31,0x33,0x11,0x61,0x0a,0x00,0x72,
|
||||
0x11,0x1e,0xf0,0x00,0x0e,0xc6,0x11,0x00,0xf2,0x10,0x31,0x11,0xc3,0x0b,0x00,
|
||||
0xc1,0x02,0x1e,0xf0,0x00,0x1e,0x60,0x20,0x80,0x81,0x10,0x31,0x31,0x42,0xe0,
|
||||
0x80,0x80,0x07,0x0f,0xf0,0x00,0x3c,0x30,0x40,0x00,0x40,0x18,0x31,0x31,0x82,
|
||||
0x00,0x40,0x00,0x06,0x07,0xf0,0x00,0x38,0x18,0x80,0x01,0x40,0x98,0x31,0x61,
|
||||
0x85,0x00,0x20,0x00,0x84,0x07,0xf0,0x00,0x78,0x00,0x00,0x03,0x40,0x60,0x31,
|
||||
0xa1,0x85,0x00,0x10,0x00,0xc0,0x03,0xf0,0x00,0xf0,0x00,0x00,0x06,0x40,0x04,
|
||||
0x50,0x20,0x88,0x00,0x0c,0x00,0xe0,0x01,0xf0,0x00,0xe0,0x01,0x04,0x08,0x40,
|
||||
0x83,0x10,0x22,0x30,0x00,0x06,0x00,0xe0,0x01,0xf0,0x00,0xe0,0x01,0x3c,0x30,
|
||||
0x80,0x00,0x11,0x22,0x40,0x00,0x81,0x02,0xf0,0x00,0xf0,0x00,0xc0,0x03,0x1c,
|
||||
0x40,0x00,0x00,0x09,0x14,0x00,0xc0,0x00,0x03,0x78,0x00,0xf0,0x00,0x80,0x07,
|
||||
0x3e,0x80,0x01,0x00,0x06,0x18,0x00,0x30,0x80,0x0f,0x3c,0x00,0xf0,0x00,0x00,
|
||||
0x0f,0x08,0x00,0x06,0x00,0x00,0x00,0x00,0x0c,0xc0,0x02,0x1e,0x00,0xf0,0x00,
|
||||
0x00,0x1e,0x08,0x18,0x38,0x00,0x00,0x00,0x00,0x03,0x00,0x02,0x0f,0x00,0xf0,
|
||||
0x00,0x00,0x3c,0x00,0x18,0xe0,0x00,0x00,0x00,0xe0,0x80,0x00,0x80,0x07,0x00,
|
||||
0xf0,0x00,0x00,0x78,0x00,0x1c,0x00,0x0f,0x00,0x00,0x1c,0xc0,0x00,0xc0,0x07,
|
||||
0x00,0xf0,0x00,0x00,0xf0,0x00,0x94,0x01,0xf8,0x01,0xf0,0x03,0xd8,0x00,0xe0,
|
||||
0x01,0x00,0xf0,0x00,0x00,0xe0,0x03,0xf6,0x01,0x00,0xfe,0x0f,0x00,0xf8,0x00,
|
||||
0xf0,0x00,0x00,0xf0,0x00,0x00,0xc0,0x07,0xaa,0x30,0x00,0x00,0x00,0x80,0xe0,
|
||||
0x00,0x7c,0x00,0x00,0xf0,0x00,0x00,0x80,0x0f,0xda,0xf0,0x01,0x00,0x00,0xd0,
|
||||
0xc0,0x01,0x3e,0x00,0x00,0xf0,0x00,0x00,0x00,0x3f,0x78,0x10,0x61,0x00,0xc0,
|
||||
0xf8,0x40,0x07,0x1f,0x00,0x00,0xf0,0x00,0x00,0x00,0x7c,0x60,0x18,0xf1,0xe1,
|
||||
0xf0,0xe1,0x40,0xc0,0x0f,0x00,0x00,0xf0,0x00,0x00,0x00,0xf8,0x01,0x18,0x19,
|
||||
0xb1,0x11,0xe1,0xc0,0xf0,0x03,0x00,0x00,0xf0,0x00,0x00,0x00,0xf0,0x07,0x88,
|
||||
0x19,0x10,0x11,0xe0,0x01,0xf8,0x01,0x00,0x00,0xf0,0x00,0x00,0x00,0xc0,0x1f,
|
||||
0xdc,0x08,0x18,0x10,0x60,0x03,0x7e,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,0x00,
|
||||
0x7f,0x60,0x98,0x19,0x30,0x63,0x80,0x1f,0x00,0x00,0x00,0xf0,0x00,0x00,0x00,
|
||||
0x00,0xfc,0x01,0xf0,0x31,0xf1,0x01,0xf0,0x0f,0x00,0x00,0x00,0xf0,0x00,0x00,
|
||||
0x00,0x00,0xf0,0x0f,0xf0,0xf0,0xc1,0x00,0xfe,0x03,0x00,0x00,0x00,0xf0,0x00,
|
||||
0x00,0x00,0x00,0xc0,0x7f,0x00,0x00,0x00,0xc0,0x7f,0x00,0x00,0x00,0x00,0xf0,
|
||||
0x00,0x00,0x00,0x00,0x00,0xff,0x07,0x00,0x00,0xfc,0x1f,0x00,0x00,0x00,0x00,
|
||||
0xf0,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0x07,0xfc,0xff,0x03,0x00,0x00,0x00,
|
||||
0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,
|
||||
0x00,0x00,0xf0,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0xff,0xff,0x07,0x00,0x00,
|
||||
0x00,0x00,0x00,0xf0};
|
||||
|
|
@ -0,0 +1,406 @@
|
|||
#!/bin/sh
|
||||
:;exec /usr/local/bin/stk -f
|
||||
;;
|
||||
;; STk/Scheme widget tour, Version 0.2
|
||||
;;
|
||||
;; Originally for Tk/Tcl by: Andrew Payne payne@crl.dec.com
|
||||
;; This one simplified and redesigned for STk/Scheme
|
||||
;; by: Suresh Srinivas ssriniva@cs.indiana.edu
|
||||
|
||||
;; Main differences are in the way the demo window is created
|
||||
;; The Tk/Tcl version uses send mechanisms extensively.
|
||||
;; The STk/Scheme version avoids using send mechanisms and
|
||||
;; fixes the user's input so as to make the user widgets to
|
||||
;; be children of a top-level widget called .wtour-wdemo
|
||||
|
||||
|
||||
(option 'add "Tk.geometry" "+25+405" "startupFile")
|
||||
(option 'add "Tk.demo-geometry" "300x300+25+25" "startupFile")
|
||||
|
||||
(option 'add "*Entry*BorderWidth" "2")
|
||||
(option 'add "*Entry*Background" "white")
|
||||
(option 'add "*Entry*Relief" "sunken")
|
||||
(option 'add "*Entry*Font" "-*-courier-bold-r-*-*-14-*-*-*-*-*-*-*")
|
||||
(option 'add "*Entry*Width" "40")
|
||||
|
||||
;; prefix all the globals with wtour
|
||||
;; so that we dont screw up the global name space quite a lot
|
||||
|
||||
(define wtour-wdemo ".wtour-wdemo")
|
||||
(define wtour-filename #f)
|
||||
(define wtour-action #f)
|
||||
|
||||
(define wtour-mframe #f)
|
||||
(define wtour-txt #f)
|
||||
|
||||
(define wtour-maxlessons 100)
|
||||
(define wtour-nlessons #f)
|
||||
(define wtour-lessons (make-vector wtour-maxlessons))
|
||||
(define wtour-curlesson #f)
|
||||
(define wtour-dir (if (null? *argv*) "." (car *argv*)))
|
||||
(define wtour-lessondir (string-append wtour-dir "/lessons/"))
|
||||
|
||||
(define wtour-menus '())
|
||||
(define wtour-menu-bar '())
|
||||
|
||||
|
||||
;; some tk goodies (stolen from one of the STk demos)
|
||||
|
||||
(define (->string obj)
|
||||
(cond ((string? obj) obj)
|
||||
((number? obj) (number->string obj))
|
||||
((symbol? obj) (symbol->string obj))
|
||||
((tk-command? obj) (widget->string obj))
|
||||
(else (error "Cannot convert ~S to a string" obj))))
|
||||
|
||||
(define (& . l)
|
||||
(let loop ((l l) (s ""))
|
||||
(if (null? l)
|
||||
s
|
||||
(loop (cdr l) (string-append s (->string (car l)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; Make a text widget with an attached scrollbar
|
||||
(define (mktext w)
|
||||
(let ((scl #f)
|
||||
(txt #f))
|
||||
(frame w)
|
||||
(set! scl (scrollbar (& w ".scroll")
|
||||
:relief "flat"
|
||||
:command (lambda l
|
||||
(apply txt 'yview l))))
|
||||
(set! txt (text (& w ".text")
|
||||
:bd 1
|
||||
:relief "raised"
|
||||
:yscrollcommand (lambda l
|
||||
(apply scl 'set l))))
|
||||
(pack scl :side "right" :fill "y")
|
||||
(pack txt :expand #t :fill "both")
|
||||
txt))
|
||||
|
||||
;; Set up the demo window
|
||||
(begin
|
||||
(catch (destroy .wtour-wdemo))
|
||||
(toplevel wtour-wdemo)
|
||||
(wm 'geometry wtour-wdemo "+300+300")
|
||||
(wm 'minsize wtour-wdemo "100" "100")
|
||||
(wm 'title .wtour-wdemo "STk Demo Window")
|
||||
(wm 'iconname .wtour-wdemo "STk Demo Window")
|
||||
(update "idletasks"))
|
||||
|
||||
|
||||
;;
|
||||
;; Set up main window
|
||||
;;
|
||||
|
||||
(wm 'title "." "STk Widget Tour")
|
||||
|
||||
(set! wtour-mframe (frame ".menu" :relief "raised" :borderwidth "1"))
|
||||
(pack wtour-mframe :fill "x")
|
||||
|
||||
;; having to eval the return values from Tk is indeed a bother
|
||||
|
||||
(let ([mframe-help (& wtour-mframe ".help")]
|
||||
[mframe-file (& wtour-mframe ".file")])
|
||||
(let ([mframe-help-menu (& mframe-help ".menu")])
|
||||
(menubutton mframe-help :text "Help" :menu mframe-help-menu)
|
||||
(pack mframe-help :side "right")
|
||||
(let ([m (menu mframe-help-menu)])
|
||||
(m 'add 'command :label "Help!" :command '(mkHelp))))
|
||||
(let ([mframe-file-menu (& mframe-file ".menu")])
|
||||
(menubutton mframe-file :text "File" :menu mframe-file-menu)
|
||||
(pack mframe-file :side "left")
|
||||
(let ([m (menu mframe-file-menu)])
|
||||
(m 'add 'command :label "New" :command '(do-new))
|
||||
(m 'add 'command :label "Open..." :command '(do-open))
|
||||
(m 'add 'command :label "Save..." :command '(do-saveas))
|
||||
(m 'add 'separator)
|
||||
(let ([mframe-file-menu-fonts (& mframe-file-menu ".fonts")])
|
||||
(m 'add 'cascade :label "Screen Font" :menu mframe-file-menu-fonts)
|
||||
(m 'add 'separator)
|
||||
(m 'add 'command :label "Exit" :command '(do-exit))
|
||||
(let ([m (menu mframe-file-menu-fonts)])
|
||||
(m 'add 'command :label "Small" :command
|
||||
'(set-font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*"))
|
||||
(m 'add 'command :label "Medium" :command
|
||||
'(set-font "-*-courier-medium-r-*-*-14-*-*-*-*-*-*-*"))
|
||||
(m 'add 'command :label "Large" :command
|
||||
'(set-font "-*-courier-medium-r-*-*-18-*-*-*-*-*-*-*")))))))
|
||||
|
||||
|
||||
(set! wtour-txt (mkText ".text"))
|
||||
(pack .text :expand "yes" :fill "both")
|
||||
|
||||
(bind wtour-txt "<Any-Key-Menu>" (lambda () (apply-changes)))
|
||||
(bind wtour-txt "<Any-Key-Prior>" (lambda () (adjust-lesson -1)))
|
||||
(bind wtour-txt "<Any-Key-Next>" (lambda () (adjust-lesson +1)))
|
||||
(focus wtour-txt)
|
||||
|
||||
(let ([f (frame ".buttons" :relief "raised" :borderw "1")])
|
||||
(pack f :side "bottom" :fill "x")
|
||||
(let ([f-apply (& f ".apply")]
|
||||
[f-next (& f ".next")]
|
||||
[f-prev (& f ".prev")])
|
||||
(button f-apply :text " Apply " :command (lambda () (apply-changes)))
|
||||
(button f-next :text " Next " :command (lambda () (adjust-lesson +1)))
|
||||
(button f-prev :text " Prev " :command (lambda () (adjust-lesson -1)))
|
||||
(pack f-apply f-next f-prev :side "left" :padx 7 :pady 7)))
|
||||
|
||||
;;
|
||||
;; Set the font of both text windows
|
||||
;;
|
||||
|
||||
(define (set-font reg)
|
||||
(wtour-txt 'configure :font reg))
|
||||
|
||||
|
||||
;; Make a new dialog toplevel window
|
||||
;;
|
||||
|
||||
(define (mkDialogWindow w)
|
||||
(catch (destroy w))
|
||||
(toplevel w :class "Dialog" :bd 0)
|
||||
(wm 'title w "Dialog box")
|
||||
(wm 'iconname w "Dialog")
|
||||
(wm 'geometry w "+425+300")
|
||||
(grab w)
|
||||
(focus w)
|
||||
(string->symbol w))
|
||||
|
||||
(define (centerwindow w)
|
||||
(wm 'withdraw w)
|
||||
(update "idletasks")
|
||||
(let ([x (- ( - (inexact->exact (/ (winfo 'screenwidth w) 2))
|
||||
(inexact->exact (/ (winfo 'reqwidth w) 2)))
|
||||
(winfo 'vrootx (eval (winfo 'parent w))))]
|
||||
[y (- ( - (inexact->exact (/ (winfo 'screenheight w) 2))
|
||||
(inexact->exact (/ (winfo 'reqheight w) 2)))
|
||||
(winfo 'vrooty (eval (winfo 'parent w))))])
|
||||
(wm 'geom w (format #f "+~A+~A" x y))
|
||||
(wm 'deiconify w)))
|
||||
|
||||
(define (mkHelp)
|
||||
(let ([w (mkDialogWindow ".help")])
|
||||
(wm 'title w "Window Tour Help")
|
||||
(let ([w-t (& w ".t")]
|
||||
[w-f (& w ".buttons")])
|
||||
(let ([t (mkText w-t)])
|
||||
(pack w-t)
|
||||
(let ([f (frame w-f :relief "raised" :borderw "1")])
|
||||
(pack f :side "bottom" :fill "x")
|
||||
(let ([f-close (& w-f ".close")])
|
||||
(button f-close :text " Close " :command `(destroy ,w))
|
||||
(pack f-close :side "right" :padx "7" :pady "7")))
|
||||
(t 'insert "current"
|
||||
"Wtour is an interactive tour of STk widgets.
|
||||
|
||||
The main window displays a short Scheme/STk program, and the demo window
|
||||
displays the results of running the program.
|
||||
|
||||
You can make changes to the program and apply those changes by clicking
|
||||
on the \"Apply\" button or pressing the \"Do\" button.
|
||||
|
||||
You can navigate through the tour with the \"Prev\" and \"Next\" buttons. Or,
|
||||
you can go directly to a specified lesson with the drop down menus.
|
||||
|
||||
There is also a command window that can be used to send individual commands
|
||||
to the demo process. You can toggle the command window on and off with an
|
||||
option under the \"File\" menu.
|
||||
|
||||
Originally by: Andrew Payne (payne@crl.dec.com)
|
||||
STk rewrite by: Suresh Srinivas (ssriniva@cs.indiana.edu)
|
||||
STk 3.0 port by: Erick Gallesio (eg@unice.fr)")
|
||||
(t 'configure :state "disabled")
|
||||
(centerwindow w)))))
|
||||
|
||||
|
||||
;; Make a one-line query dialog box
|
||||
|
||||
(define (mkentryquery w prompt var)
|
||||
(let ([w (mkdialogwindow w)])
|
||||
(let ([w-top (& w ".top")]
|
||||
[w-bot (& w ".bot")])
|
||||
(let ([t (frame w-top :relief "raised" :border "1")]
|
||||
[b (frame w-bot :relief "raised" :border "1")])
|
||||
(pack t b :fill "both")
|
||||
(let ([t-lab (& t ".lab")]
|
||||
[t-ent (& t ".ent")]
|
||||
[b-ok (& b ".ok")]
|
||||
[b-default (& b ".default")]
|
||||
[b-cancel (& b ".cancel")])
|
||||
(label t-lab :text prompt)
|
||||
(let ([e (entry t-ent :textvar `,var)])
|
||||
(bind e "<Any-Return>" `(set! wtour-action 'ok))
|
||||
(pack t-lab e :side "left" :padx "3m" :pady "3m")
|
||||
|
||||
(button b-ok :text "Ok" :command '(set! wtour-action "ok"))
|
||||
(frame b-default :relief "sunken" :bd 1)
|
||||
(raise b-ok b-default)
|
||||
(pack b-default :in w-bot :side "left" :expand "1"
|
||||
:padx "3m" :pady "2m")
|
||||
(pack b-ok :in b-default :padx "2m"
|
||||
:ipadx "2m" :ipady "1m")
|
||||
(button b-cancel :text "Cancel" :command
|
||||
'(set! wtour-action "cancel"))
|
||||
(pack b-cancel :side "left" :padx "3m" :pady "3m"
|
||||
:ipadx "2m" :ipady "1m" :expand "yes")
|
||||
(centerwindow w)
|
||||
(focus e)
|
||||
(tkwait 'variable 'wtour-action)
|
||||
(destroy w)
|
||||
wtour-action))))))
|
||||
|
||||
;; Write the edit buffer to the specified file
|
||||
|
||||
(define (write-file fname)
|
||||
(with-output-to-file fname
|
||||
(lambda ()
|
||||
(format #t "~A" (wtour-txt 'get "1.0" "end")))))
|
||||
|
||||
;; ignoring file existence check (update)
|
||||
|
||||
(define (do-save-file fname)
|
||||
(write-file fname))
|
||||
|
||||
(define (do-new)
|
||||
(wtour-txt 'delete "1.0" "end")
|
||||
(apply-changes))
|
||||
|
||||
(define (do-saveas)
|
||||
(if (equal? (mkentryquery ".dialog"
|
||||
"Enter save file name:" 'wtour-filename) "ok")
|
||||
(do-save-file wtour-filename)))
|
||||
|
||||
(define (do-open-file fname)
|
||||
(with-input-from-file fname
|
||||
(lambda ()
|
||||
(wtour-txt 'delete "1.0" "end")
|
||||
(do ((l (read-line) (read-line)))
|
||||
((eof-object? l))
|
||||
(wtour-txt 'insert "end" l)
|
||||
(wtour-txt 'insert "end" "\n"))
|
||||
(wtour-txt 'mark 'set 'insert "1.0")))
|
||||
(apply-changes))
|
||||
|
||||
(define (do-open)
|
||||
(if (equal? (mkentryquery ".dialog"
|
||||
"Enter file name to load:" 'wtour-filename) "ok")
|
||||
(do-open-file wtour-filename)))
|
||||
|
||||
|
||||
;; need to do it recursively! (look at X selection to see why it wont work)
|
||||
(define (fix-widget-names l)
|
||||
(map
|
||||
(lambda (x)
|
||||
(cond
|
||||
((symbol? x) (let ([y (symbol->string x)])
|
||||
(if (eq? (string-ref y 0) #\.)
|
||||
(string->symbol (string-append ".wtour-wdemo" y))
|
||||
x)))
|
||||
((string? x) (if (eq? (string-ref x 0) #\.)
|
||||
(string-append ".wtour-wdemo" x)
|
||||
x))
|
||||
((list? x) (fix-widget-names x))
|
||||
(else x)))
|
||||
l))
|
||||
|
||||
;; mopping up the demo window prior to loading the next lesson
|
||||
;; or applying the changes to the demo window.
|
||||
|
||||
(define (clear-up-wtour-wdemo)
|
||||
(let ([wtour-wdemo-child (winfo 'children .wtour-wdemo)])
|
||||
(if (not (null? wtour-wdemo-child))
|
||||
(if (list? wtour-wdemo-child)
|
||||
(map (lambda (w)
|
||||
(destroy w))
|
||||
wtour-wdemo-child)
|
||||
(destroy wtour-wdemo-child)))))
|
||||
|
||||
;; apply the changes to the demo window
|
||||
(define (apply-changes)
|
||||
(clear-up-wtour-wdemo)
|
||||
(let ([x (wtour-txt 'get "1.0" "end")])
|
||||
(with-input-from-string
|
||||
x
|
||||
(lambda ()
|
||||
(let loop ([y (read)])
|
||||
(if (not (eof-object? y))
|
||||
(let ([z (fix-widget-names y)])
|
||||
(eval z)
|
||||
(loop (read)))))))))
|
||||
|
||||
|
||||
(define-macro (add1! var)
|
||||
`(set! ,var (+ 1 ,var)))
|
||||
|
||||
(define-macro (incr! var val)
|
||||
`(set! ,var (+ ,var ,val)))
|
||||
|
||||
(define-macro (add-to-menu-assoc item)
|
||||
`(set! wtour-menus (cons ,item wtour-menus)))
|
||||
|
||||
|
||||
(define-macro (add-to-menu-list item)
|
||||
`(set! wtour-menu-bar (cons ,item wtour-menu-bar)))
|
||||
|
||||
;; Define a new lesson
|
||||
|
||||
(define (lesson mname name file)
|
||||
(vector-set! wtour-lessons wtour-nlessons file)
|
||||
(let ([mb (assoc mname wtour-menus)]
|
||||
[first (assoc mname wtour-menus)])
|
||||
(if (not first)
|
||||
(begin
|
||||
(set! mb (& (& wtour-mframe ".") wtour-nlessons))
|
||||
(menubutton mb :text mname :menu (& mb ".menu"))
|
||||
(pack mb :side "left")
|
||||
(add-to-menu-assoc (cons mname (menu (& mb ".menu"))))
|
||||
(add-to-menu-list mb)))
|
||||
(if (not (equal? name ""))
|
||||
(begin
|
||||
((eval (cdr (assoc mname wtour-menus))) 'add 'command :label name
|
||||
:command `(set-lesson ,wtour-nlessons))
|
||||
(add1! wtour-nlessons))
|
||||
((eval (cdr mb)) 'add "separator"))))
|
||||
|
||||
|
||||
;; set the current lesson
|
||||
(define (set-lesson num)
|
||||
(set! wtour-curlesson num)
|
||||
(do-open-file (& wtour-lessondir "/" (vector-ref wtour-lessons num))))
|
||||
|
||||
(define (do-warning-dialog str)
|
||||
(stk:make-dialog :window ".info" :title "Warning"
|
||||
:text str
|
||||
:bitmap ""
|
||||
:grab #t
|
||||
:defaults 0
|
||||
:buttons (list (list "Cancel" (lambda () #f)))))
|
||||
|
||||
;; adjust the current lesson by some increment
|
||||
|
||||
(define (adjust-lesson i)
|
||||
(incr! wtour-curlesson i)
|
||||
(if (>= wtour-curlesson wtour-nlessons)
|
||||
(begin
|
||||
(do-warning-dialog "That was the last lesson")
|
||||
(set! wtour-curlesson (- wtour-nlessons 1)))
|
||||
(if (< wtour-curlesson 0)
|
||||
(begin
|
||||
(do-warning-dialog "That was the first lesson")
|
||||
(set! wtour-curlesson 0))))
|
||||
(set-lesson wtour-curlesson))
|
||||
|
||||
|
||||
;; clean up and exit
|
||||
|
||||
(define (do-exit)
|
||||
(exit))
|
||||
|
||||
(set-font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*")
|
||||
|
||||
(set! wtour-nlessons 0)
|
||||
(load (& wtour-lessondir "/index"))
|
||||
(set-lesson 0)
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
#!/bin/sh
|
||||
#
|
||||
# This is a start up script for the STk/Scheme widget tour.
|
||||
#
|
||||
# Originally by: Andrew Payne payne@crl.dec.com
|
||||
# Present one by: Suresh Srinivas ssriniva@cs.indiana.edu
|
||||
|
||||
STK=/usr/local/bin/stk
|
||||
STK_LIBRARY=/usr/local/lib/stk
|
||||
|
||||
export STK_LIBRARY
|
||||
export STK
|
||||
|
||||
$STK -f ./lib/wtour.stk
|
||||
|
|
@ -0,0 +1,267 @@
|
|||
/*
|
||||
* This file is a contribution of David Tolpin (dvd@pizza.msk.su)
|
||||
* It is an implementation of BSD-INET sockets and is known to run on
|
||||
* Solaris 1 and Linux.
|
||||
*
|
||||
* (prepare-server-socket portnum)
|
||||
* bound socket to a local address. Returns an object of type socket-handle
|
||||
*
|
||||
* (release-server-socket! handle)
|
||||
* close server socket (created by prepare-server-socket
|
||||
*
|
||||
* (socket-handle? handle)
|
||||
* returns truth if the handle is of type socket-handle, false otherwise
|
||||
*
|
||||
* (listen-socket! handle)
|
||||
* listen for connection requests
|
||||
*
|
||||
* (accept-connection handle)
|
||||
* returns a new socket in response to a detected connection request,
|
||||
* the return value is a list of two ports,
|
||||
* - (car sp) is opened for reading,
|
||||
* - (cadr sp) - for writing
|
||||
*
|
||||
* (open-client-socket hostname portnum)
|
||||
* connect to a socket on a remote machine, returns the same data structure
|
||||
* as the function described above
|
||||
*
|
||||
* (shutdown-connection! skt)
|
||||
* shutdown socket, the mode of shutting down is determined according to
|
||||
* the mode of the port (read or write)
|
||||
*/
|
||||
|
||||
#include "stk.h"
|
||||
#include <errno.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
#include <netinet/in.h>
|
||||
#include <netdb.h>
|
||||
|
||||
PRIMITIVE prepare_server_socket(SCM portnum);
|
||||
PRIMITIVE release_server_socket(SCM handle);
|
||||
PRIMITIVE socket_handlep(SCM handle);
|
||||
PRIMITIVE listen_socket(SCM handle);
|
||||
PRIMITIVE accept_connection(SCM handle);
|
||||
PRIMITIVE open_client_socket(SCM hostname, SCM portnum);
|
||||
PRIMITIVE shutdown_connection(SCM skt);
|
||||
|
||||
/*
|
||||
: stk_socket.c,v 1.4 1994/06/26 19:14:55 dvd Exp dvd $
|
||||
*/
|
||||
|
||||
/*
|
||||
: stk_socket.c,v $
|
||||
* Revision 1.4 1994/06/26 19:14:55 dvd
|
||||
* *** empty log message ***
|
||||
*
|
||||
* Revision 1.3 1994/06/26 18:55:27 dvd
|
||||
* Verbose error reporting is added
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef __sun__
|
||||
extern char *sys_errlist[];
|
||||
#endif
|
||||
|
||||
struct socket_handle {
|
||||
int portnum;
|
||||
char *hostname;
|
||||
int handle;
|
||||
};
|
||||
|
||||
static int tc_sockhandle;
|
||||
|
||||
static void free_sockhandle(SCM handle);
|
||||
static void mark_sockhandle(SCM handle);
|
||||
static void displ_sockhandle(SCM x, FILE *f, int mode);
|
||||
|
||||
static extended_scheme_type sockhandle_type = {
|
||||
"sockhandle", /* name */
|
||||
0, /* is_procp */
|
||||
mark_sockhandle, /* gc_mark_fct */
|
||||
free_sockhandle, /* gc_free_fct */
|
||||
NULL, /* apply_fct */
|
||||
displ_sockhandle /* display_fct */
|
||||
};
|
||||
|
||||
|
||||
#define SOCKHANDLE(x) ((struct socket_handle*)(x->storage_as.extension.data))
|
||||
#define LSOCKHANDLE(x) (x->storage_as.extension.data)
|
||||
#define SOCKHANDLEP(x) (TYPEP(x,tc_sockhandle))
|
||||
#define NSOCKHANDLEP(x) (NTYPEP(x,tc_sockhandle))
|
||||
|
||||
void mark_sockhandle(SCM handle)
|
||||
{
|
||||
}
|
||||
|
||||
void free_sockhandle(SCM handle)
|
||||
{
|
||||
struct socket_handle *sh;
|
||||
sh = SOCKHANDLE(handle);
|
||||
if(sh->hostname) free(sh->hostname);
|
||||
close(sh->handle);
|
||||
free(sh);
|
||||
LSOCKHANDLE(handle) = NULL;
|
||||
}
|
||||
|
||||
void displ_sockhandle(SCM handle, FILE *f, int mode)
|
||||
{
|
||||
struct socket_handle *sh;
|
||||
sh = SOCKHANDLE(handle);
|
||||
sprintf(tkbuffer, "#[socket-handle %s %i]", sh->hostname, sh->portnum);
|
||||
Puts(tkbuffer,f);
|
||||
}
|
||||
|
||||
|
||||
static SCM makesp(int s, char *hn, int portnum)
|
||||
{
|
||||
int t;
|
||||
int hnlen;
|
||||
FILE *fs, *ft;
|
||||
SCM zs, zt;
|
||||
long flag;
|
||||
|
||||
flag = no_interrupt(1);
|
||||
|
||||
t = dup(s); /* duplicate handles so that we are able to access one socket channel */
|
||||
/* via two scheme ports */
|
||||
if(!((fs = fdopen(s, "r")) && (ft = fdopen(s, "w"))))
|
||||
err("internal(makesp): cannot create ports", NIL);
|
||||
NEWCELL(zs, tc_iport);
|
||||
NEWCELL(zt, tc_oport);
|
||||
zs->storage_as.port.f = fs; setbuf(fs, NULL); /* unbuffered input/output */
|
||||
zt->storage_as.port.f = ft; setbuf(ft, NULL);
|
||||
zs->storage_as.port.name = (char*)must_malloc((hnlen = strlen(hn))+16);
|
||||
sprintf(zs->storage_as.port.name, "%s:%i(r)", hn, portnum);
|
||||
zt->storage_as.port.name = (char*)must_malloc((hnlen = strlen(hn))+16);
|
||||
sprintf(zt->storage_as.port.name, "%s:%i(w)", hn, portnum);
|
||||
|
||||
no_interrupt(flag);
|
||||
return(cons(zs, cons(zt, NIL)));
|
||||
}
|
||||
|
||||
PRIMITIVE prepare_server_socket(SCM portnum)
|
||||
{
|
||||
struct sockaddr_in sin;
|
||||
int s;
|
||||
long flag;
|
||||
SCM ys;
|
||||
|
||||
if(NINTEGERP(portnum))
|
||||
err("not a port number", portnum);
|
||||
sin.sin_port = INTEGER(portnum);
|
||||
sin.sin_addr.s_addr = INADDR_ANY;
|
||||
if((s = socket(AF_INET, SOCK_STREAM, 0)) < 0)
|
||||
err(sys_errlist[errno], portnum);
|
||||
if(bind(s, (struct sockaddr*)&sin, sizeof sin) < 0)
|
||||
switch(errno) {
|
||||
case EADDRINUSE:
|
||||
case EADDRNOTAVAIL: {
|
||||
SCM errcode;
|
||||
NEWCELL(errcode, tc_integer);
|
||||
SET_INTEGER(errcode, errno);
|
||||
return errcode;
|
||||
}
|
||||
break;
|
||||
default: err(sys_errlist[errno], portnum);
|
||||
}
|
||||
/* now we're ready to create the object */
|
||||
NEWCELL(ys, tc_sockhandle);
|
||||
LSOCKHANDLE(ys) = (struct socket_handle*)must_malloc(sizeof (struct socket_handle));
|
||||
SOCKHANDLE(ys)->portnum = sin.sin_port;
|
||||
SOCKHANDLE(ys)->hostname = (char*)must_malloc(strlen("localhost")+1);
|
||||
strcpy(SOCKHANDLE(ys)->hostname, "localhost");
|
||||
SOCKHANDLE(ys)->handle = s;
|
||||
|
||||
return ys;
|
||||
}
|
||||
|
||||
|
||||
PRIMITIVE release_server_socket(SCM handle)
|
||||
{
|
||||
if(NSOCKHANDLEP(handle)) err("not a socket handle", handle);
|
||||
close(SOCKHANDLE(handle)->handle);
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
PRIMITIVE socket_handlep(SCM handle)
|
||||
{
|
||||
return SOCKHANDLEP(handle)? truth: ntruth;
|
||||
}
|
||||
|
||||
PRIMITIVE listen_socket(SCM handle)
|
||||
{
|
||||
if(NSOCKHANDLEP(handle))
|
||||
err("not a socket handle", handle);
|
||||
if(listen(SOCKHANDLE(handle)->handle, 5) < 0)
|
||||
err(sys_errlist[errno], handle);
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
PRIMITIVE accept_connection(SCM handle)
|
||||
{
|
||||
int s;
|
||||
|
||||
if(NSOCKHANDLEP(handle))
|
||||
err("not a socket handle", handle);
|
||||
if((s = accept(SOCKHANDLE(handle)->handle, NULL, NULL)) < 0)
|
||||
err(sys_errlist[errno], handle);
|
||||
return makesp(s, SOCKHANDLE(handle)->hostname, SOCKHANDLE(handle)->portnum);
|
||||
}
|
||||
|
||||
PRIMITIVE open_client_socket(SCM hostname, SCM portnum)
|
||||
{
|
||||
char *hn;
|
||||
struct hostent *hp;
|
||||
struct sockaddr_in server;
|
||||
int s;
|
||||
|
||||
if(NSTRINGP(hostname)) err("bad hostname", hostname);
|
||||
if(NINTEGERP(portnum)) err("bad port number", portnum);
|
||||
hp = gethostbyname(hn = CHARS(hostname));
|
||||
if(!hp) err("unknown or misspelled host name", hostname);
|
||||
bzero((char*)&server,sizeof server);
|
||||
bcopy(hp->h_addr,(char*)&server.sin_addr, hp->h_length);
|
||||
server.sin_family = hp->h_addrtype;
|
||||
server.sin_port = INTEGER(portnum);
|
||||
if((s = socket(AF_INET,SOCK_STREAM,0)) < 0)
|
||||
err(sys_errlist[errno], NIL);
|
||||
if(connect(s, (struct sockaddr *)&server, sizeof server) < 0)
|
||||
switch(errno) {
|
||||
case EADDRINUSE:
|
||||
case EADDRNOTAVAIL:
|
||||
case ETIMEDOUT:
|
||||
case ECONNREFUSED: {
|
||||
SCM errcode;
|
||||
NEWCELL(errcode, tc_integer);
|
||||
SET_INTEGER(errcode, errno);
|
||||
return errcode;
|
||||
}
|
||||
break;
|
||||
default: err(sys_errlist[errno], NIL);
|
||||
}
|
||||
return makesp(s, hn, server.sin_port);
|
||||
}
|
||||
|
||||
PRIMITIVE shutdown_connection(SCM skt)
|
||||
{
|
||||
if(NIPORTP(skt) && NOPORTP(skt))
|
||||
err("not a port", skt);
|
||||
if(shutdown(fileno(skt->storage_as.port.f), IPORTP(skt)?0:1) < 0)
|
||||
err(sys_errlist[errno], NIL);
|
||||
return UNDEFINED;
|
||||
}
|
||||
|
||||
void init_socket(void)
|
||||
{
|
||||
tc_sockhandle = add_new_type(&sockhandle_type);
|
||||
|
||||
add_new_primitive("prepare-server-socket", tc_subr_1, prepare_server_socket);
|
||||
add_new_primitive("release-server-socket!", tc_subr_1, release_server_socket);
|
||||
add_new_primitive("socket-handle?", tc_subr_1, socket_handlep);
|
||||
add_new_primitive("listen-socket!", tc_subr_1, listen_socket);
|
||||
add_new_primitive("accept-connection", tc_subr_1, accept_connection);
|
||||
add_new_primitive("open-client-socket", tc_subr_2, open_client_socket);
|
||||
add_new_primitive("shutdown-connection!", tc_subr_1, shutdown_connection);
|
||||
};
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1 @@
|
|||
../../Lib/trace.stk
|
||||
|
|
@ -0,0 +1,278 @@
|
|||
[Image] Demo directory
|
||||
|
||||
This directory contains demo programs for STk.
|
||||
|
||||
If you want to run a demo BEFORE a complete installation of the STk package,
|
||||
you must use the
|
||||
|
||||
../Src/test-stk
|
||||
|
||||
command to run the interpreter.
|
||||
|
||||
If you view this file with the STk HTML browser, you can click on each given
|
||||
command to launch a demo.
|
||||
|
||||
To use the STk HTML browser, just type:
|
||||
|
||||
../Src/test-stk -f hbrowse README.html
|
||||
|
||||
Happy STking
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
STk demos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
browse.stk
|
||||
Description
|
||||
a simple Unix file browser
|
||||
Run
|
||||
../Src/test-stk -f browse.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
colormap.stk
|
||||
Description
|
||||
a simple color builder
|
||||
Run
|
||||
../Src/test-stk -f colormap.stk
|
||||
Comment
|
||||
On exit, the RGB value is printed on the sandard output
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
small-ed.stk
|
||||
Description
|
||||
A small editor to create enhanced text
|
||||
Run
|
||||
../Src/test-stk -f small-ed.stk
|
||||
Comment
|
||||
Does not work (still) with STk 3.0
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
hanoi.stk
|
||||
Description
|
||||
Hanoi towers animation
|
||||
Run
|
||||
../Src/test-stk -f hanoi.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
hello.stk
|
||||
Description
|
||||
a simple button demonstration
|
||||
Run
|
||||
../Src/test-stk -f hello.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
showvars.stk
|
||||
Description
|
||||
a variable shower
|
||||
This program shows the value of three variables (named a,b and c)
|
||||
Changing the value of one of these vars (with a set! for instance) will
|
||||
redisplay its new value immediatly
|
||||
Run
|
||||
../Src/test-stk -load showvars.stk
|
||||
Comment
|
||||
Exit
|
||||
type (exit) on the STk prompt
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
turtle.stk
|
||||
Description
|
||||
a Logo turtle package + some demo functions.
|
||||
Run
|
||||
../Src/test-stk -f turtle.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
inspector.stk
|
||||
Description
|
||||
A simple demo of the inspector on Tk widgets
|
||||
Run
|
||||
../Src/test-stk -f inspector.stk
|
||||
Comment
|
||||
Does not work (still) with STk 3.0
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
mc-server.stk
|
||||
Description
|
||||
A multiple-clients server.
|
||||
Run
|
||||
../Src/test-stk -load mc-server.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
queens.stk
|
||||
Description
|
||||
The queens problem. You can do it yourself (and it will make sure you
|
||||
follow the rules) or you can ask it to solve the puzzle starting with a
|
||||
given board configuration. This code is a contribution of Grant Edwards
|
||||
(grante@rosemount.com)
|
||||
Run
|
||||
../Src/test-stk -f queens.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
stetris.stk
|
||||
Description
|
||||
This is a falling block game not unlike tetris(tm) :). It is
|
||||
implemented in STk just to prove it can be done, and as a challenge to
|
||||
TCLers. It starts slowly and becomes faster and faster. Have fun. This
|
||||
code is a contribution of Harvey J. Stein(hjstein@math.huji.ac.il)
|
||||
Run
|
||||
../Src/test-stk -f stetris.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
ttt.stk
|
||||
Description
|
||||
A 3D Tic-Tac-Toe, where the board is 4x4x4, a 3 dimensional board of
|
||||
four planes with four rows and four columns each. This code is a
|
||||
contribution of Edin "Dino" Hodzic <ehodzic@scu.edu>
|
||||
Run
|
||||
../Src/test-stk -f ttt.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
server.stk
|
||||
Description
|
||||
A simple server showing how to use the socket package. It creates a
|
||||
xterm window in which a read-eval-print-loop is executed. When the
|
||||
window is closed or when an error occurs, the socket is closed
|
||||
Run
|
||||
../Src/test-stk -f server.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
term.stk
|
||||
Description
|
||||
A simple terminal emulator (a kind of xterm, but in a text widget).
|
||||
Run
|
||||
../Src/test-stk -f term.stk
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
wtour.stk
|
||||
Description
|
||||
This is a rewrite of the Tcl/Tk wtour2.0 in Scheme/STk. Use the menus
|
||||
to navigate through different lessons. You can make changes to the
|
||||
lesson source code; click on the Apply button to see the results of the
|
||||
changes.
|
||||
Run
|
||||
../Src/test-stk -f ./wtour.stk ../Contrib/STk-wtour
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
STklos demos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
There are few demos of STklos. What is interesting is not what they do but
|
||||
how they are programmmed (IMO).
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
widget.stklos
|
||||
Description
|
||||
A tour of the Tk widgets. This demo shows all the Tk widgets
|
||||
Run
|
||||
../Src/test-stk -f widget.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
stklos-demo.stklos
|
||||
Description
|
||||
a simple demo written in STklos
|
||||
Run
|
||||
../Src/test-stk -f stklos-demo.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
stklos-demo2.stklos
|
||||
Description
|
||||
another simple demo written in STklos
|
||||
Run
|
||||
../Src/test-stk -f stklos-demo2.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
hello.stklos
|
||||
Description
|
||||
a rewriting of the hello.stk demo in STklos
|
||||
Run
|
||||
../Src/test-stk -f hello.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
browse.stklos
|
||||
Description
|
||||
a rewriting of the browse.stk demo in STklos
|
||||
Run
|
||||
../Src/test-stk -f browse.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
calc.stklos
|
||||
Description
|
||||
a very simple calculator
|
||||
Run
|
||||
../Src/test-stk -f calc.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
compo-demo.stklos
|
||||
Description
|
||||
A quick demo of the composite widgets which are in the STk release.
|
||||
This code is a contribution of <Drew.Whitehouse@anu.edu.au>
|
||||
Run
|
||||
../Src/test-stk -f compo-demo.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
filebox.stklos
|
||||
Description
|
||||
a simple program which uses the <File-box> compositeclass. A <File-box>
|
||||
is a file requestor with file name completion. It is a composition of
|
||||
various composite widget classes.
|
||||
Run
|
||||
../Src/test-stk -f filebox.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
File
|
||||
tkcolor.stklos
|
||||
Description
|
||||
a simple color picker written in STklos. Clicking button 1 on the color
|
||||
box sets the text color to that color; Clicking button 3 sets the
|
||||
background.
|
||||
Run
|
||||
../Src/test-stk -f tkcolor.stklos
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
eg@unice.fr
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#
|
||||
# Makefile for the Demos directory
|
||||
#
|
||||
|
||||
include ../config.make
|
||||
|
||||
DEMODIR=$(libdir)/demos
|
||||
|
||||
what:
|
||||
@echo "Type make install to install demos"
|
||||
install:
|
||||
-if [ ! -d $(DEMODIR) ] ; then mkdir -p $(DEMODIR); fi
|
||||
for i in *.stk *.stklos Widget/*.stklos ; \
|
||||
do \
|
||||
j=`basename $$i`; \
|
||||
sed -e 's=/usr/local/lib/stk=$(libdir)=' \
|
||||
-e 's=/usr/local/bin=$(bindir)=' $$i > $(DEMODIR)/$$j;\
|
||||
done
|
||||
for i in *.stk *.stklos ; \
|
||||
do \
|
||||
chmod 0755 $(DEMODIR)/`basename $$i`; \
|
||||
done
|
||||
|
||||
install.libs:
|
||||
|
||||
|
|
@ -0,0 +1,364 @@
|
|||
<html>
|
||||
<!-- Created by: Erick Gallesio, 1-Sep-1995 -->
|
||||
<head>
|
||||
<title>Demo directory README (Version 3.1 - July 1996)</title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<h1><img src="STk-normal.gif"> Demo directory</h1>
|
||||
<pre>
|
||||
|
||||
|
||||
</pre>
|
||||
<p>This directory contains demo programs for <b>STk</b>.
|
||||
|
||||
<p>If you want to run a demo <STRONG>BEFORE</STRONG> a complete
|
||||
installation of the <b>STk</b> package, you must use the
|
||||
<pre> ../Src/test-stk</pre>
|
||||
command to run the interpreter.
|
||||
|
||||
<p><b>If you view this file with the STk HTML browser, you can click on
|
||||
each given command to launch a demo.</b><p>
|
||||
To use the STk HTML browser, just type:
|
||||
<pre> ../Src/test-stk -f hbrowse README.html</pre>
|
||||
<p><I>Happy STking </I>
|
||||
|
||||
<hr></p>
|
||||
<h2>
|
||||
<center><font COLOR="red">STk demos</font></center>
|
||||
</h2>
|
||||
<hr>
|
||||
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> browse.stk
|
||||
<DT> Description
|
||||
<DD> a simple Unix file browser
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f browse.stk &")>
|
||||
../Src/test-stk -f browse.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> colormap.stk
|
||||
<DT> Description
|
||||
<DD> a simple color builder
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f colormap.stk &")>
|
||||
../Src/test-stk -f colormap.stk
|
||||
</A>
|
||||
<DT> Comment
|
||||
<DD> On exit, the RGB value is printed on the sandard output
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> small-ed.stk
|
||||
<DT> Description
|
||||
<DD> A small editor to create enhanced text
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f small-ed.stk &")>
|
||||
../Src/test-stk -f small-ed.stk
|
||||
</A>
|
||||
<DT> Comment
|
||||
<DD> <STRONG> Does not work (still) with <I>STk</I> 3.0</STRONG>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> hanoi.stk
|
||||
<DT> Description
|
||||
<DD> Hanoi towers animation
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f hanoi.stk &")>
|
||||
../Src/test-stk -f hanoi.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> hello.stk
|
||||
<DT> Description
|
||||
<DD> a simple button demonstration
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f hello.stk &")>
|
||||
../Src/test-stk -f hello.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> showvars.stk
|
||||
<DT> Description
|
||||
<DD> a variable shower<br>
|
||||
This program shows the value of three variables (named a,b and c)
|
||||
Changing the value of one of these vars (with a set! for
|
||||
instance) will redisplay its new value immediatly
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -load showvars.stk &")>
|
||||
../Src/test-stk -load showvars.stk
|
||||
</A>
|
||||
<DT> Comment
|
||||
<DT> Exit
|
||||
<DD> type (exit) on the STk prompt
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> turtle.stk
|
||||
<DT> Description
|
||||
<DD> a Logo turtle package + some demo functions.
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f turtle.stk &")>
|
||||
../Src/test-stk -f turtle.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> inspector.stk
|
||||
<DT> Description
|
||||
<DD> A simple demo of the inspector on Tk widgets
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f inspector.stk &")>
|
||||
../Src/test-stk -f inspector.stk
|
||||
</A>
|
||||
<DT> Comment
|
||||
<DD> <STRONG> Does not work (still) with <I>STk</I> 3.0</STRONG>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> mc-server.stk
|
||||
<DT> Description
|
||||
<DD> A multiple-clients server.
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "xterm -e ../Src/test-stk -load mc-server.stk &")>
|
||||
../Src/test-stk -load mc-server.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> queens.stk
|
||||
<DT> Description
|
||||
<DD> The queens problem. You can do it yourself (and it will make
|
||||
sure you follow the rules) or you can ask it to solve the
|
||||
puzzle starting with a given board configuration.
|
||||
<b>This code is a contribution of Grant Edwards</b>
|
||||
<tt>(grante@rosemount.com)</tt>
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f queens.stk &")>
|
||||
../Src/test-stk -f queens.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> stetris.stk
|
||||
<DT> Description
|
||||
<DD> This is a falling block game not unlike tetris(tm) :).
|
||||
It is implemented in STk just to prove it can be done,
|
||||
and as a challenge to TCLers.
|
||||
It starts slowly and becomes faster and faster.
|
||||
Have fun.
|
||||
This code is a contribution of Harvey J. Stein(hjstein@math.huji.ac.il)
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f stetris.stk &")>
|
||||
../Src/test-stk -f stetris.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> ttt.stk
|
||||
<DT> Description
|
||||
<DD> A 3D Tic-Tac-Toe, where the board is 4x4x4, a 3 dimensional board
|
||||
of four planes with four rows and four columns each.
|
||||
<B>This code is a contribution of Edin "Dino" Hodzic</B> <ehodzic@scu.edu>
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f ttt.stk &")>
|
||||
../Src/test-stk -f ttt.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> server.stk
|
||||
<DT> Description
|
||||
<DD> A simple server showing how to use the socket package.
|
||||
It creates a xterm window in which a read-eval-print-loop
|
||||
is executed. When the window is closed or when an error occurs,
|
||||
the socket is closed
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f server.stk &")>
|
||||
../Src/test-stk -f server.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> term.stk
|
||||
<DT> Description
|
||||
<DD> A simple terminal emulator (a kind of xterm, but in a text widget).
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f ./term.stk &")>
|
||||
../Src/test-stk -f term.stk
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> wtour.stk
|
||||
<DT> Description
|
||||
<DD> This is a rewrite of the Tcl/Tk wtour2.0 in Scheme/STk. Use the menus
|
||||
to navigate through different lessons. You can make changes
|
||||
to the lesson source code; click on the Apply button to see the results of
|
||||
the changes.
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f ./wtour.stk ../Contrib/STk-wtour &")>
|
||||
../Src/test-stk -f ./wtour.stk ../Contrib/STk-wtour
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<!-- --------------------------------------------------------------------------->
|
||||
<hr>
|
||||
<h2>
|
||||
<center><font COLOR="red"> STklos demos </font></center>
|
||||
</h2>
|
||||
<hr>
|
||||
<!-- --------------------------------------------------------------------------->
|
||||
|
||||
There are few demos of STklos. What is interesting is not what they do but
|
||||
how they are programmmed (IMO).
|
||||
|
||||
<hr>
|
||||
<DL>
|
||||
<DT> File
|
||||
<DD> widget.stklos
|
||||
<DT> Description
|
||||
<DD> A tour of the Tk widgets. This demo shows all the Tk widgets
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f widget.stk &")>
|
||||
../Src/test-stk -f widget.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> stklos-demo.stklos
|
||||
<DT> Description
|
||||
<DD> a simple demo written in STklos
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f stklos-demo.stklos &")>
|
||||
../Src/test-stk -f stklos-demo.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> stklos-demo2.stklos
|
||||
<DT> Description
|
||||
<DD> another simple demo written in STklos
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f stklos-demo2.stklos &")>
|
||||
../Src/test-stk -f stklos-demo2.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> hello.stklos
|
||||
<DT> Description
|
||||
<DD> a rewriting of the hello.stk demo in STklos
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f hello.stklos &")>
|
||||
../Src/test-stk -f hello.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> browse.stklos
|
||||
<DT> Description
|
||||
<DD> a rewriting of the browse.stk demo in STklos
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f browse.stklos &")>
|
||||
../Src/test-stk -f browse.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> calc.stklos
|
||||
<DT> Description
|
||||
<DD> a very simple calculator
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f calc.stklos &")>
|
||||
../Src/test-stk -f calc.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> compo-demo.stklos
|
||||
<DT> Description
|
||||
<DD> A quick demo of the composite widgets which are in the STk release.
|
||||
<BR>
|
||||
<STRONG>This code is a contribution of </STRONG>
|
||||
<TT><Drew.Whitehouse@anu.edu.au></TT>
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f compo-demo.stklos &")>
|
||||
../Src/test-stk -f compo-demo.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> filebox.stklos
|
||||
<DT> Description
|
||||
<DD> a simple program which uses the <File-box> compositeclass.
|
||||
A <File-box> is a file requestor with file name completion.
|
||||
It is a composition of various composite widget classes.
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f filebox.stklos &")>
|
||||
../Src/test-stk -f filebox.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
|
||||
<hr>
|
||||
<DL><DT>File
|
||||
<DD> tkcolor.stklos
|
||||
<DT> Description
|
||||
<DD> a simple color picker written in STklos. Clicking button 1 on the color
|
||||
box sets the text color to that color; Clicking button 3 sets the background.
|
||||
<DT> Run
|
||||
<DD> <A expr=(system "../Src/test-stk -f tkcolor.stklos &")>
|
||||
../Src/test-stk -f tkcolor.stklos
|
||||
</A>
|
||||
</DL>
|
||||
|
||||
<hr>
|
||||
<address>eg@unice.fr</address>
|
||||
</BODY>
|
||||
</HTML>
|
||||
|
|
@ -0,0 +1 @@
|
|||
../Lib/images/STk-normal.gif
|
||||
|
|
@ -0,0 +1,183 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a canvas widget that displays a
|
||||
;;;; large line with an arrowhead whose shape can be edited interactively.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-arrow)
|
||||
(define w (make-demo-toplevel "arrow"
|
||||
"Arrowhead Editor Demonstration"
|
||||
"This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item."))
|
||||
|
||||
(define a 8)
|
||||
(define b 10)
|
||||
(define c 3)
|
||||
(define width 2)
|
||||
(define motion-proc #f)
|
||||
(define x1 40)
|
||||
(define x2 350)
|
||||
(define y 150)
|
||||
(define small-tips '(5 5 2))
|
||||
(define cnv (make <Canvas> :parent w :width 500 :height 350
|
||||
:relief "sunken" :border-width 2))
|
||||
(define box1 #f)
|
||||
(define box2 #f)
|
||||
(define box3 #f)
|
||||
(define current-box #f)
|
||||
|
||||
;;; arrowSetup regenerates all the text and graphics in the canvas
|
||||
;;; window. It's called when the canvas is initially created, and also
|
||||
;;; whenever any of the parameters of the arrow head are changed
|
||||
;;; interactively.
|
||||
(define (arrow-setup cnv)
|
||||
|
||||
;; Create the arrow and outline.
|
||||
(canvas-delete cnv "all")
|
||||
|
||||
(apply make <Line> :parent cnv
|
||||
:coords (list x1 y x2 y)
|
||||
:width (* 10 width)
|
||||
:arrow-shape (list (* 10 a) (* 10 b) (* 10 c))
|
||||
:arrow "last"
|
||||
(if (> (winfo 'depth cnv) 1)
|
||||
`(:fill "SkyBlue1")
|
||||
`(:fill black
|
||||
:stipple ,(& "@" *stk-library* "/images/grey.25"))))
|
||||
|
||||
(let ((xtip (- x2 (* 10 b)))
|
||||
(delta-y (+ (* 10 c) (* 5 width))))
|
||||
(make <Line> :parent cnv
|
||||
:coords (list x2 y xtip (+ y delta-y) (- x2 (* 10 a))
|
||||
y xtip (- y delta-y) x2 y)
|
||||
:width 2
|
||||
:cap-style "round")
|
||||
|
||||
;;;Create the boxes for reshaping the line and arrowhead.
|
||||
(set! box1 (make <Rectangle> :parent cnv
|
||||
:coords (list (- x2 (* 10 a) +5) (- y 5)
|
||||
(- x2 (* 10 a) -5) (+ y 5))
|
||||
:fill "white" :tags '("box" "box1")))
|
||||
(set! box2 (make <Rectangle> :parent cnv
|
||||
:coords (list (- xtip 5) (- y delta-y +5)
|
||||
(+ xtip 5) (- y delta-y -5))
|
||||
:fill "white" :tags '("box" "box2")))
|
||||
(set! box3 (make <Rectangle> :parent cnv
|
||||
:coords (list (- x1 5) (- y (* 5 width) +5)
|
||||
(+ x1 5) (- y (* 5 width) -5))
|
||||
:fill "white" :tags '("box" "box3")))
|
||||
|
||||
;; Create three arrows in actual size with the same parameters
|
||||
(make <Line> :parent cnv :coords (list (+ x2 50) 0 (+ x2 50) 1000) :width 2)
|
||||
(let ((tmp (+ x2 100)))
|
||||
(make <Line> :parent cnv :coords (list tmp (- y 125) tmp (- y 75))
|
||||
:width width :arrow "both" :arrow-shape (list a b c))
|
||||
(make <Line> :parent cnv :coords (list (- tmp 25) y (+ tmp 25) y)
|
||||
:width width :arrow "both" :arrow-shape (list a b c))
|
||||
(make <Line> :parent cnv :coords (list (- tmp 25) (+ y 75)
|
||||
(+ tmp 25) (+ y 125))
|
||||
:width width :arrow "both" :arrow-shape (list a b c)))
|
||||
;; Create a bunch of other arrows and text items showing the
|
||||
;; current dimensions.
|
||||
(let ((tmp (+ x2 10)))
|
||||
(make <Line> :parent cnv :coords (list tmp (- y (* 5 width))
|
||||
tmp (- y delta-y))
|
||||
:arrow "both" :arrow-shape small-tips)
|
||||
(make <Text-item> :parent cnv :coords (list (+ x2 15)
|
||||
(- y delta-y (* -5 c)))
|
||||
:text c :anchor "w"))
|
||||
|
||||
(let ((tmp (- x1 10)))
|
||||
(make <Line> :parent cnv :coords (list tmp (- y (* 5 width))
|
||||
tmp (+ y (* 5 width)))
|
||||
:arrow "both" :arrow-shape small-tips)
|
||||
(make <Text-item> :parent cnv :coords (list (- x1 15) y)
|
||||
:text width :anchor "e"))
|
||||
|
||||
(let ((tmp (+ y (* 5 width) (* 10 c) 10)))
|
||||
(make <Line> :parent cnv :coords (list (- x2 (* 10 a)) tmp x2 tmp)
|
||||
:arrow "both" :arrow-shape small-tips)
|
||||
(make <Text-item> :parent cnv :coords (list (- x2 (* 5 a)) (+ tmp 5))
|
||||
:text a :anchor "n"))
|
||||
|
||||
(let ((tmp (+ y (* 5 width) (* 10 c) 35)))
|
||||
(make <Line> :parent cnv :coords (list (- x2 (* 10 b)) tmp x2 tmp)
|
||||
:arrow "both" :arrow-shape small-tips)
|
||||
(make <Text-item> :parent cnv :coords (list (- x2 (* 5 b)) (+ tmp 5))
|
||||
:text b :anchor "n"))
|
||||
|
||||
(make <Text-item> :parent cnv :coords (list x1 310)
|
||||
:text (format #f ":width ~A" width) :anchor "w"
|
||||
:font "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*")
|
||||
(make <Text-item> :parent cnv :coords (list x1 330)
|
||||
:text (format #f ":arrow-shape '~A" (list a b c)) :anchor "w"
|
||||
:font "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*"))
|
||||
(if current-box
|
||||
(set! (fill current-box) (if (> (winfo 'depth cnv) 1) "red" "black"))))
|
||||
|
||||
(define (activate-box)
|
||||
(let ((box (find-items cnv 'withtag "current")))
|
||||
(when (pair? box)
|
||||
(set! current-box (car box))
|
||||
(set! (fill current-box) (if (> (winfo 'depth cnv) 1) "red" "black")))))
|
||||
|
||||
(define (deactivate-box)
|
||||
(set! (fill current-box) "white")
|
||||
(set! current-box #f))
|
||||
|
||||
;; arrow-move-1 is called for each mouse motion event on box1 (the
|
||||
;; one at the vertex of the arrow). It updates the controlling parameters
|
||||
;; for the line and arrowhead.
|
||||
(define (arrow-move-1 cnv new-x new-y)
|
||||
(let ((new-a (inexact->exact (floor (/ (- x2 -5 (canvas-x cnv new-x)) 10)))))
|
||||
(if (< new-a 0) (set! new-a 0))
|
||||
(if (> new-a 25) (set! new-a 25))
|
||||
(unless (= new-a a)
|
||||
(move box1 (* 10 (- a new-a)) 0)
|
||||
(set! a new-a))))
|
||||
|
||||
;; arrow-move-2 is called for each mouse motion event on box2 (the
|
||||
;; one at the trailing tip of the arrowhead). It updates the controlling
|
||||
;; parameters for the line and arrowhead.
|
||||
(define (arrow-move-2 cnv new-x new-y)
|
||||
(let ((new-b (inexact->exact (floor (/ (- x2 -5 (canvas-x cnv new-x)) 10))))
|
||||
(new-c (inexact->exact (floor (/ (- y -5 (round (canvas-y cnv new-y))
|
||||
(* 5 width)) 10)))))
|
||||
(if (< new-b 0) (set! new-b 0))
|
||||
(if (> new-b 25) (set! new-b 25))
|
||||
(if (< new-c 0) (set! new-c 0))
|
||||
(if (> new-c 20) (set! new-c 20))
|
||||
(unless (and (= new-b b) (= new-c c))
|
||||
(move box2 (* 10 (- b new-b)) (* 10 (- c new-c)))
|
||||
(set! b new-b)
|
||||
(set! c new-c))))
|
||||
|
||||
;; arrow-move-3 is called for each mouse motion event on box3 (the
|
||||
;; one that controls the thickness of the line). It updates the
|
||||
;; controlling parameters for the line and arrowhead.
|
||||
(define (arrow-move-3 cnv new-x new-y)
|
||||
(let ((new-w (inexact->exact (floor (/ (- y -2 (canvas-y cnv new-y)) 5)))))
|
||||
(if (< new-w 0) (set! new-w 0))
|
||||
(if (> new-w 20) (set! new-w 20))
|
||||
(unless (= new-w width)
|
||||
(move box3 0 (* 5 (- width new-w)))
|
||||
(set! width new-w))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(arrow-setup cnv)
|
||||
(pack cnv :expand #t :fill "both")
|
||||
|
||||
;;; Bindings
|
||||
(bind cnv "box" "<Enter>" activate-box)
|
||||
(bind cnv "box" "<Leave>" deactivate-box)
|
||||
(bind cnv "box" "<B1-Enter>" (lambda () 'nop))
|
||||
(bind cnv "box" "<B1-Leave>" (lambda () 'nop))
|
||||
(bind cnv "box" "<B1-Motion>" (lambda (x y)
|
||||
(if motion-proc (motion-proc cnv x y))))
|
||||
(bind cnv "box1" "<1>" (lambda () (set! motion-proc arrow-move-1)))
|
||||
(bind cnv "box2" "<1>" (lambda () (set! motion-proc arrow-move-2)))
|
||||
(bind cnv "box3" "<1>" (lambda () (set! motion-proc arrow-move-3)))
|
||||
(bind cnv "<Any-ButtonRelease-1>" (lambda () (arrow-setup cnv))))
|
||||
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a text widget with bindings set
|
||||
;;;; up for hypertext-like effects.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-bind)
|
||||
(let* ((w (make-demo-toplevel "bind"
|
||||
"Text Demonstration - Tag Bindings"
|
||||
""))
|
||||
(t (make <Text> :parent w :setgrid #t :width 60 :height 24
|
||||
:font demo-font :wrap "word"))
|
||||
(bold (make <Text-tag> :parent t :background "#43ce80"
|
||||
:relief "raised" :border-width 1))
|
||||
(tags (make-vector 6))
|
||||
(action '#(demo-items demo-plot demo-ctext
|
||||
demo-arrow demo-ruler demo-cscroll)))
|
||||
|
||||
(when (= (winfo 'depth w) 1) ; Monochrome
|
||||
(slot-set! bold :foreground "white")
|
||||
(slot-set! bold :background "black"))
|
||||
|
||||
(pack t :expand #t :fill "both")
|
||||
|
||||
;; Add bindings
|
||||
(dotimes (i 6)
|
||||
(let ((tag (make <Text-tag> :parent t)))
|
||||
(vector-set! tags i tag)
|
||||
(bind tag "<Any-Enter>" (lambda ()
|
||||
(apply tag-add bold (tag-ranges tag))))
|
||||
(bind tag "<Any-Leave>" (lambda ()
|
||||
(apply tag-remove bold (tag-ranges tag))))
|
||||
(bind tag "<1>" (lambda ()
|
||||
(apply (eval (vector-ref action i)) '())))))
|
||||
|
||||
;; Add text to widget.
|
||||
(text-insert t "end"
|
||||
"The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked.\n\n" '()
|
||||
"1. Samples of all the different types of items that can be created in canvas widgets." (vector-ref tags 0)
|
||||
"\n\n" '()
|
||||
"2. A simple two-dimensional plot that allows you to adjust the positions of the data points." (vector-ref tags 1)
|
||||
"\n\n" '()
|
||||
"3. Anchoring and justification modes for text items." (vector-ref tags 2)
|
||||
"\n\n" '()
|
||||
"4. An editor for arrow-head shapes for line items." (vector-ref tags 3)
|
||||
"\n\n" '()
|
||||
"5. A ruler with facilities for editing tab stops." (vector-ref tags 4)
|
||||
"\n\n" '()
|
||||
"6. A grid that demonstrates how canvases can be scrolled." (vector-ref tags 5)
|
||||
)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window that displays
|
||||
;;;; all of Tk's built-in bitmaps.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-bitmap)
|
||||
(define w (make-demo-toplevel "bitmap"
|
||||
"Bitmap Demonstration"
|
||||
"This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts."))
|
||||
|
||||
(define (bitmap-row l)
|
||||
(let ((f (make <Frame> :parent w)))
|
||||
(pack f :side "top" :fill "both")
|
||||
(for-each (lambda (bitmap)
|
||||
(let ((f2 (make <Frame> :parent f)))
|
||||
(pack f2 :side "left" :fill "both" :padx '.25c :pady '.25c)
|
||||
(pack (make <Label> :parent f2 :bitmap bitmap)
|
||||
(make <Label> :parent f2 :text bitmap :width 9)
|
||||
:side "bottom")))
|
||||
l)))
|
||||
|
||||
;; Display two rows of bitmaps
|
||||
(bitmap-row '(error gray25 gray50 hourglass))
|
||||
(bitmap-row '(info question questhead warning)))
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; several button widgets.
|
||||
;;;;
|
||||
|
||||
(define (demo-button)
|
||||
(let ((w (make-demo-toplevel "button"
|
||||
"Button Demonstration"
|
||||
"If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button.")))
|
||||
|
||||
;; Create the 4 buttons
|
||||
(for-each (lambda (x)
|
||||
(pack (make <Button>
|
||||
:text (car x)
|
||||
:parent w
|
||||
:width 10
|
||||
:command (lambda() (set! (background w) (cadr x))))
|
||||
:side "top"
|
||||
:expand #t
|
||||
:pady 2))
|
||||
'(("Peach Puff" "PeachPuff1")
|
||||
("Light Blue" "LightBlue1")
|
||||
("Sea Green" "SeaGreen2")
|
||||
("Yellow" "Yellow1")))))
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; several checkbuttons.
|
||||
;;;;
|
||||
(require "Button")
|
||||
|
||||
(define (demo-check)
|
||||
(let ((w (make-demo-toplevel "check"
|
||||
"Checkbutton Demonstration"
|
||||
"Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables."
|
||||
'wipers 'brakes 'sober)))
|
||||
;; Create checkbuttons
|
||||
(pack (make <Check-button> :parent w :text "Wipers OK"
|
||||
:variable 'wipers :relief "flat")
|
||||
(make <Check-button> :parent w :text "Brakes OK"
|
||||
:variable 'brakes :relief "flat")
|
||||
(make <Check-button> :parent w :text "Driver Sober"
|
||||
:variable 'sober :relief "flat")
|
||||
:side "top"
|
||||
:pady 2
|
||||
:anchor "w")))
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a listbox widget that displays
|
||||
;;;; the names of the 50 states in the United States of America.
|
||||
;;;;
|
||||
|
||||
(require "Scrollbox")
|
||||
|
||||
(define (demo-colors)
|
||||
(let* ((w (make-demo-toplevel "colors"
|
||||
"Listbox Demonstration (colors)"
|
||||
"A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with Shift key and button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color"))
|
||||
(l (list "snow1" "snow2" "snow3" "snow4" "seashell1" "seashell2" "seashell3" "seashell4" "AntiqueWhite1" "AntiqueWhite2" "AntiqueWhite3" "AntiqueWhite4" "bisque1" "bisque2" "bisque3" "bisque4" "PeachPuff1" "PeachPuff2" "PeachPuff3" "PeachPuff4" "NavajoWhite1" "NavajoWhite2" "NavajoWhite3" "NavajoWhite4" "LemonChiffon1" "LemonChiffon2" "LemonChiffon3" "LemonChiffon4" "cornsilk1" "cornsilk2" "cornsilk3" "cornsilk4" "ivory1" "ivory2" "ivory3" "ivory4" "honeydew1" "honeydew2" "honeydew3" "honeydew4" "LavenderBlush1" "LavenderBlush2" "LavenderBlush3" "LavenderBlush4" "MistyRose1" "MistyRose2" "MistyRose3" "MistyRose4" "azure1" "azure2" "azure3" "azure4" "SlateBlue1" "SlateBlue2" "SlateBlue3" "SlateBlue4" "RoyalBlue1" "RoyalBlue2" "RoyalBlue3" "RoyalBlue4" "blue1" "blue2" "blue3" "blue4" "DodgerBlue1" "DodgerBlue2" "DodgerBlue3" "DodgerBlue4" "SteelBlue1" "SteelBlue2" "SteelBlue3" "SteelBlue4" "DeepSkyBlue1" "DeepSkyBlue2" "DeepSkyBlue3" "DeepSkyBlue4" "SkyBlue1" "SkyBlue2" "SkyBlue3" "SkyBlue4" "LightSkyBlue1" "LightSkyBlue2" "LightSkyBlue3" "LightSkyBlue4" "SlateGray1" "SlateGray2" "SlateGray3" "SlateGray4" "LightSteelBlue1" "LightSteelBlue2" "LightSteelBlue3" "LightSteelBlue4" "LightBlue1" "LightBlue2" "LightBlue3" "LightBlue4" "LightCyan1" "LightCyan2" "LightCyan3" "LightCyan4" "PaleTurquoise1" "PaleTurquoise2" "PaleTurquoise3" "PaleTurquoise4" "CadetBlue1" "CadetBlue2" "CadetBlue3" "CadetBlue4" "turquoise1" "turquoise2" "turquoise3" "turquoise4" "cyan1" "cyan2" "cyan3" "cyan4" "DarkSlateGray1" "DarkSlateGray2" "DarkSlateGray3" "DarkSlateGray4" "aquamarine1" "aquamarine2" "aquamarine3" "aquamarine4" "DarkSeaGreen1" "DarkSeaGreen2" "DarkSeaGreen3" "DarkSeaGreen4" "SeaGreen1" "SeaGreen2" "SeaGreen3" "SeaGreen4" "PaleGreen1" "PaleGreen2" "PaleGreen3" "PaleGreen4" "SpringGreen1" "SpringGreen2" "SpringGreen3" "SpringGreen4" "green1" "green2" "green3" "green4" "chartreuse1" "chartreuse2" "chartreuse3" "chartreuse4" "OliveDrab1" "OliveDrab2" "OliveDrab3" "OliveDrab4" "DarkOliveGreen1" "DarkOliveGreen2" "DarkOliveGreen3" "DarkOliveGreen4" "khaki1" "khaki2" "khaki3" "khaki4" "LightGoldenrod1" "LightGoldenrod2" "LightGoldenrod3" "LightGoldenrod4" "LightYellow1" "LightYellow2" "LightYellow3" "LightYellow4" "yellow1" "yellow2" "yellow3" "yellow4" "gold1" "gold2" "gold3" "gold4" "goldenrod1" "goldenrod2" "goldenrod3" "goldenrod4" "DarkGoldenrod1" "DarkGoldenrod2" "DarkGoldenrod3" "DarkGoldenrod4" "RosyBrown1" "RosyBrown2" "RosyBrown3" "RosyBrown4" "IndianRed1" "IndianRed2" "IndianRed3" "IndianRed4" "sienna1" "sienna2" "sienna3" "sienna4" "burlywood1" "burlywood2" "burlywood3" "burlywood4" "wheat1" "wheat2" "wheat3" "wheat4" "tan1" "tan2" "tan3" "tan4" "chocolate1" "chocolate2" "chocolate3" "chocolate4" "firebrick1" "firebrick2" "firebrick3" "firebrick4" "brown1" "brown2" "brown3" "brown4" "salmon1" "salmon2" "salmon3" "salmon4" "LightSalmon1" "LightSalmon2" "LightSalmon3" "LightSalmon4" "orange1" "orange2" "orange3" "orange4" "DarkOrange1" "DarkOrange2" "DarkOrange3" "DarkOrange4" "coral1" "coral2" "coral3" "coral4" "tomato1" "tomato2" "tomato3" "tomato4" "OrangeRed1" "OrangeRed2" "OrangeRed3" "OrangeRed4" "red1" "red2" "red3" "red4" "DeepPink1" "DeepPink2" "DeepPink3" "DeepPink4" "HotPink1" "HotPink2" "HotPink3" "HotPink4" "pink1" "pink2" "pink3" "pink4" "LightPink1" "LightPink2" "LightPink3" "LightPink4" "PaleVioletRed1" "PaleVioletRed2" "PaleVioletRed3" "PaleVioletRed4" "maroon1" "maroon2" "maroon3" "maroon4" "VioletRed1" "VioletRed2" "VioletRed3" "VioletRed4" "magenta1" "magenta2" "magenta3" "magenta4" "orchid1" "orchid2" "orchid3" "orchid4" "plum1" "plum2" "plum3" "plum4" "MediumOrchid1" "MediumOrchid2" "MediumOrchid3" "MediumOrchid4" "DarkOrchid1" "DarkOrchid2" "DarkOrchid3" "DarkOrchid4" "purple1" "purple2" "purple3" "purple4" "MediumPurple1" "MediumPurple2" "MediumPurple3" "MediumPurple4" "thistle1" "thistle2" "thistle3" "thistle4"))
|
||||
(sl (make <Scroll-listbox> :parent w :value l)))
|
||||
|
||||
;; Pack the scroll listbox
|
||||
(pack sl :padx 20 :pady 20)
|
||||
|
||||
;; Add a binding to change the palette on double click
|
||||
(bind (slot-ref sl 'listbox) "<Double-1>"
|
||||
(lambda ()
|
||||
(Tk:set-palette! (selection 'get))))))
|
||||
|
|
@ -0,0 +1,129 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a canvas widget with a text
|
||||
;;;; item that can be edited and reconfigured in various ways.
|
||||
;;;;
|
||||
|
||||
(define (demo-ctext)
|
||||
|
||||
(define config-fill #f)
|
||||
(define current #f)
|
||||
|
||||
(define (Enter c)
|
||||
(set! current (car (find-items c 'withtag "current")))
|
||||
(set! config-fill (slot-ref current 'fill))
|
||||
(slot-set! current 'fill "black"))
|
||||
|
||||
(define (Leave c)
|
||||
(slot-set! current 'fill config-fill))
|
||||
|
||||
(define (Insert c string)
|
||||
(unless (equal? string "")
|
||||
(catch c (delete-chars c "text" "sel.first" "sel.last"))
|
||||
(text-insert c "text" 'insert string)))
|
||||
|
||||
(define (Paste c x y)
|
||||
(catch (text-insert c "text" (format #f "@~A,~A" x y) (selection 'get))))
|
||||
|
||||
(define (B1-press c x y)
|
||||
(let ((pos (format #f "@~A,~A" x y)))
|
||||
(icursor c "current" pos)
|
||||
(focus c "current")
|
||||
(focus c)
|
||||
(text-selection c 'from "current" pos)))
|
||||
|
||||
(define (B1-move c x y)
|
||||
(text-selection c 'to "current" (format #f "@~A,~A" x y)))
|
||||
|
||||
(define (Bs c)
|
||||
(when (catch (delete-chars c "text" "sel.first" "sel.last"))
|
||||
(let ((char (- (text-index c "text" "insert") 1)))
|
||||
(if (>= char 0)
|
||||
(delete-chars c "text" char)))))
|
||||
|
||||
(define (Del c)
|
||||
(when (catch (delete-chars c "text" "sel.first" "sel.last"))
|
||||
(delete-chars c "text" "insert")))
|
||||
|
||||
(let* ((w (make-demo-toplevel "ctext"
|
||||
"Canvas Text Demonstration"
|
||||
"This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing:
|
||||
1. You can point, click, and type.
|
||||
2. You can also select with button 1.
|
||||
3. You can copy the selection to the mouse position with button 2.
|
||||
4. Backspace and Control+h delete the character just before the
|
||||
insertion cursor.
|
||||
5. Delete deletes the character just after the insertion cursor. "))
|
||||
(font "-*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-*")
|
||||
(c (make <Canvas> :parent w :width 500 :height 400))
|
||||
(txt (make <Text-item> :parent c :coords '(250 200)
|
||||
:width 440 :anchor "n" :font font :justify "left"
|
||||
:text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d.")))
|
||||
|
||||
(pack c :side "top" :expand #t :fill "both")
|
||||
|
||||
;; First, create the text item and give it bindings so it can be edited.
|
||||
(add-tag txt "text")
|
||||
(bind c "text" "<1>" (lambda (x y) (B1-press c x y)))
|
||||
(bind c "text" "<B1-Motion>" (lambda (x y) (B1-move c x y)))
|
||||
(bind c "text" "<Shift-B1-Motion>" (lambda (x y) (B1-move c x y)))
|
||||
(bind c "text" "<KeyPress>" (lambda (|A|) (Insert c |A|)))
|
||||
(bind c "text" "<Return>" (lambda () (Insert c "\n")))
|
||||
(bind c "text" "<Control-h>" (lambda () (BS c)))
|
||||
(bind c "text" "<BackSpace>" (lambda () (BS c)))
|
||||
(bind c "text" "<Delete>" (lambda () (Del c)))
|
||||
(bind c "text" "<2>" (lambda (x y) (Paste c x y)))
|
||||
|
||||
(let* ((x 50)
|
||||
(y 50)
|
||||
(color "LightSkyBlue1")
|
||||
(txt-config (lambda (x y option value color)
|
||||
(let ((item (make <Rectangle>
|
||||
:parent c
|
||||
:coords (list x y (+ x 30) (+ y 30))
|
||||
:outline "black"
|
||||
:tags "square"
|
||||
:fill color
|
||||
:width 1)))
|
||||
(bind item "<1>" (lambda ()
|
||||
(slot-set! txt option value)))))))
|
||||
|
||||
;; Create some items that allow the text's anchor position to be edited.
|
||||
(txt-config (+ x 00) (+ y 00) 'anchor "se" "LightSkyBlue1")
|
||||
(txt-config (+ x 30) (+ y 00) 'anchor "s" "LightSkyBlue1")
|
||||
(txt-config (+ x 60) (+ y 00) 'anchor "sw" "LightSkyBlue1")
|
||||
(txt-config (+ x 00) (+ y 30) 'anchor "e" "LightSkyBlue1")
|
||||
(txt-config (+ x 30) (+ y 30) 'anchor "center" "LightSkyBlue1")
|
||||
(txt-config (+ x 60) (+ y 30) 'anchor "w" "LightSkyBlue1")
|
||||
(txt-config (+ x 00) (+ y 60) 'anchor "ne" "LightSkyBlue1")
|
||||
(txt-config (+ x 30) (+ y 60) 'anchor "n" "LightSkyBlue1")
|
||||
(txt-config (+ x 60) (+ y 60) 'anchor "nw" "LightSkyBlue1")
|
||||
|
||||
;; Create some items that allow the text's justification to be changed.
|
||||
(txt-config (+ x 300) y 'justify "left" "SeaGreen2")
|
||||
(txt-config (+ x 330) y 'justify "center" "SeaGreen2")
|
||||
(txt-config (+ x 360) y 'justify "right" "SeaGreen2")
|
||||
|
||||
;; The two little red squares and the both titles
|
||||
(let ((item1 (make <Rectangle> :parent c
|
||||
:coords (list (+ x 40) (+ y 40) (+ x 50) (+ y 50))
|
||||
:outline "black" :fill "red"))
|
||||
(item2 (make <Rectangle> :parent c
|
||||
:coords '(245 195 255 205) :outline "black" :fill "red")))
|
||||
|
||||
(bind item1 "<1>" (lambda ()
|
||||
(slot-set! txt 'anchor "center")))
|
||||
|
||||
(make <Text-item> :parent c :text "Text Position" :anchor "s"
|
||||
:font font :fill "brown":coords (list (+ x 45) (- y 5)))
|
||||
|
||||
(make <Text-item> :parent c :text "Justification" :anchor "s"
|
||||
:font font :fill "brown":coords (list (+ x 345) (- y 5))))
|
||||
|
||||
;; Associate bindings to squares
|
||||
(bind c "square" "<Enter>" (lambda () (Enter c)))
|
||||
(bind c "square" "<Leave>" (lambda () (Leave c))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a dialog box with a local grab.
|
||||
;;;;
|
||||
|
||||
|
||||
(define (demo-dialog1)
|
||||
(STk:make-dialog :title "Dialog with local grab"
|
||||
:text "This is a modal dialog box. It uses Tk's \"grab\" command to create a \"local grab\" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications."
|
||||
:bitmap "info"
|
||||
:default 0
|
||||
:grab #t
|
||||
:buttons
|
||||
`(("OK" ,(lambda () (display "You pressed OK\n")))
|
||||
("Cancel" ,(lambda () (display "You pressed Cancel\n")))
|
||||
("See Code" ,(lambda () (show-code "dialog1"))))))
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a dialog box with a global grab.
|
||||
;;;;
|
||||
|
||||
|
||||
(define (demo-dialog2)
|
||||
(STk:make-dialog :title "Dialog with global grab"
|
||||
:text "This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don't use them unless you're truly desperate."
|
||||
:bitmap "info"
|
||||
:default 0
|
||||
:grab 'global
|
||||
:buttons
|
||||
`(("OK" ,(lambda () (display "You pressed OK\n")))
|
||||
("Cancel" ,(lambda () (display "You pressed Cancel\n")))
|
||||
("See Code" ,(lambda () (show-code "dialog2"))))))
|
||||
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates several entry widgets without
|
||||
;;;; scrollbars.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-entry1)
|
||||
(define w (make-demo-toplevel "entry1"
|
||||
"Entry Demonstration (no scrollbars)"
|
||||
"Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with Shift key and mouse button2 pressed."))
|
||||
|
||||
(pack (make <Entry> :parent w :relief "sunken" :value "Initial value")
|
||||
(make <Entry> :parent w :relief "sunken" :value "This entry contains a long value, much too long to fit in the window at one time, so long in fact that you'll have to scan or scroll to see the end.")
|
||||
(make <Entry> :parent w :relief "sunken")
|
||||
:side "top"
|
||||
:padx 10
|
||||
:pady 5
|
||||
:fill "x"))
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script is the same as the entry1.tcl script
|
||||
;;;; except that it creates scrollbars for the entries.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-entry2)
|
||||
(define w (make-demo-toplevel "entry2"
|
||||
"Entry Demonstration (with scrollbars)"
|
||||
"Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with Shift key and mouse button2 pressed."))
|
||||
|
||||
(define (scroll-entry value)
|
||||
(let*
|
||||
((f (make <Frame> :parent w))
|
||||
(s (make <Scrollbar> :parent f :relief "sunken" :orientation 'h :width 10))
|
||||
(e (make <Entry> :parent f :relief "sunken" :value value)))
|
||||
;; pack entry and scrollbar.
|
||||
(pack e s :side "top" :fill "x")
|
||||
;; Associate bindings
|
||||
(slot-set! e 'x-scroll-command (lambda l (apply (slot-ref s 'Id) 'set l)))
|
||||
(slot-set! s 'command (lambda l (apply (slot-ref e 'Id) 'xview l)))
|
||||
;; return the enclosing frame
|
||||
f))
|
||||
|
||||
(pack (scroll-entry "Initial value")
|
||||
(scroll-entry "This entry contains a long value, much too long to fit in the window at one time, so long in fact that you'll have to scan or scroll to see the end.")
|
||||
(scroll-entry "")
|
||||
:side "top"
|
||||
:padx 10
|
||||
:pady 10
|
||||
:fill "x"))
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a simple form with a bunch
|
||||
;;;; of entry widgets.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define (demo-form)
|
||||
(let ((w (make-demo-toplevel "form"
|
||||
"Form Demonstration"
|
||||
"This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries.")))
|
||||
|
||||
;; Make the entries
|
||||
(for-each (lambda (x)
|
||||
(pack (make <Labeled-entry>
|
||||
:parent w :title x
|
||||
:title-width 8 :width 40
|
||||
:anchor "w" :entry-relief "sunken")
|
||||
:padx 5))
|
||||
|
||||
(list "Name:" "Address:" "" "" "Phone:"))
|
||||
;; destroy the window when <Return> is typed in the current toplevelel
|
||||
(let ((top (winfo 'toplevel w)))
|
||||
(bind top "<Return>" (lambda () (catch (destroy top)))))))
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script shows an example with a horizontal scale.
|
||||
;;;;
|
||||
|
||||
(define (demo-hscale)
|
||||
|
||||
(define (set-width! c poly line width)
|
||||
(let* ((width (+ width 21))
|
||||
(x2 (max (- width 30) 21)))
|
||||
(set! (coords poly) (list 20 15 20 35 x2 35 x2 45 width 25 x2 5 x2 15 20 15))
|
||||
(set! (coords line) (list 20 15 20 35 x2 35 x2 45 width 25 x2 5 x2 15 20 15)))
|
||||
)
|
||||
|
||||
|
||||
(let* ((w (make-demo-toplevel "hscale"
|
||||
"Horizontal Scale Demonstration"
|
||||
"An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow."))
|
||||
(f (make <Frame> :parent w :border-width 10))
|
||||
(c (make <Canvas> :parent f :width 50 :height 50 :border-width 0
|
||||
:highlight-thickness 0))
|
||||
(poly (make <Polygon> :parent c :coords '(0 0 1 1 2 2)
|
||||
:fill "DeepSkyBlue3"))
|
||||
(line (make <Line> :parent c :coords '(0 0 1 1 2 2 0 0) :fill "black"))
|
||||
(s (make <Scale> :parent f :orientation "horizontal" :scale-length 284
|
||||
:from 0 :to 250
|
||||
:tick-interval 50 :value 75
|
||||
:command (lambda (v) (set-width! c poly line v)))))
|
||||
|
||||
(pack f :side "top" :fill "x")
|
||||
(pack s :side "left" :side "bottom" :expand #t :anchor "n")
|
||||
(pack c :side "left" :side "top" :expand #t :anchor "s" :fill "x" :padx 15)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; buttons that display bitmaps instead of text.
|
||||
;;;;
|
||||
|
||||
(define (demo-icon)
|
||||
(let* ((w (make-demo-toplevel "icon"
|
||||
"Iconic Button Demonstration"
|
||||
"This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected."))
|
||||
(up (make <Bitmap-Image> :file (string-append *STk-images* "flagup")))
|
||||
(down (make <Bitmap-Image> :file (string-append *STk-images* "flagdown")))
|
||||
(left (make <Frame> :parent w :border-width 10))
|
||||
(right (make <Frame> :parent w :border-width 10)))
|
||||
|
||||
;; Create Radio buttons
|
||||
(pack (make <Radio-button>
|
||||
:parent left
|
||||
:bitmap (string-append "@" *STk-images* "letters")
|
||||
:variable 'letters
|
||||
:value "full")
|
||||
(make <Radio-button>
|
||||
:parent left
|
||||
:bitmap (string-append "@" *STk-images* "noletters")
|
||||
:variable 'letters
|
||||
:value "empty")
|
||||
:pady "3m")
|
||||
|
||||
;; Create check buttons
|
||||
(pack (make <Check-button>
|
||||
:parent right
|
||||
:image down
|
||||
:select-image up
|
||||
:indicator-on #f)
|
||||
(make <Check-button>
|
||||
:parent right
|
||||
:bitmap (string-append "@" *STk-images* "letters")
|
||||
:indicator-on "0"
|
||||
:select-color "SeaGreen1")
|
||||
:side "left" :expand #t :padx "5m")
|
||||
(pack left right :side "left" :expand #t)))
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script displays two image widgets.
|
||||
;;;;
|
||||
|
||||
(require "Button")
|
||||
(require "Image")
|
||||
|
||||
(define (demo-image1)
|
||||
(let ((w (make-demo-toplevel "image1"
|
||||
"Image Demonstration #1"
|
||||
"This demonstration displays two images, each in a separate label widget.")))
|
||||
|
||||
(pack (make <Label>
|
||||
:parent w
|
||||
:image (make <Photo-Image>
|
||||
:file (string-append *STk-images* "earth.gif")))
|
||||
(make <Label>
|
||||
:parent w
|
||||
:image (make <Photo-Image>
|
||||
:file (string-append *STk-images* "earthris.gif")))
|
||||
:side "top" :padx ".5m" :pady ".5m")))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script displays two image widgets.
|
||||
;;;;
|
||||
(require "Tk-classes")
|
||||
|
||||
(define image-directory *STk-images*)
|
||||
|
||||
(define (demo-image2)
|
||||
(let* ((w (make-demo-toplevel "image2"
|
||||
"Image Demonstration #2"
|
||||
"This demonstration allows you to view images using an Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image."))
|
||||
(dir (make <Entry> :parent w :width 30 :text-variable 'image-directory))
|
||||
(lst (make <Scroll-listbox> :parent w
|
||||
:value '("earth.gif" "earthris.gif" "mickey.gif" "teapot.ppm")))
|
||||
(img (make <Photo-Image>))
|
||||
(lab (make <Label> :parent w :image img)))
|
||||
|
||||
(pack (make <Label> :parent w :text "Directory:")
|
||||
dir
|
||||
(make <Label> :parent w :text "File:")
|
||||
lst
|
||||
(make <Label> :parent w :text "Image:")
|
||||
lab
|
||||
:side "top" :anchor "w")
|
||||
|
||||
;; Add binding to listbox and entry
|
||||
(let ((lb (slot-ref lst 'listbox)))
|
||||
(bind lb "<Double-1>"
|
||||
(lambda ()
|
||||
(let ((file (selection 'get)))
|
||||
(slot-set! img 'file (string-append image-directory "/" file)))))
|
||||
|
||||
(bind dir "<Return>"
|
||||
(lambda ()
|
||||
(slot-set! lb 'value
|
||||
(sort (map basename
|
||||
(glob (string-append image-directory "/*")))
|
||||
string<?)))))))
|
||||
|
|
@ -0,0 +1,257 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a canvas that displays the
|
||||
;;;; canvas item types.
|
||||
;;;;
|
||||
|
||||
(define (demo-items)
|
||||
;;
|
||||
;; Functions used by this demo
|
||||
;;
|
||||
(let* ((w (make-demo-toplevel "items"
|
||||
"Canvas Item Demonstration"
|
||||
"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area."))
|
||||
(c (make <Scroll-Canvas>
|
||||
:parent w
|
||||
:scroll-region (list 0 0 '30c '24c)
|
||||
:width "15c"
|
||||
:height "10c"
|
||||
:relief "groove"
|
||||
:border-width 3
|
||||
:h-scroll-side "bottom"))
|
||||
(font1 "-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*")
|
||||
(font2 "-Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*")
|
||||
(mono (= (winfo 'depth c) 1))
|
||||
(blue (if mono "black" "DeepSkyBlue3"))
|
||||
(red (if mono "black" "red"))
|
||||
(bisque (if mono "black" "bisque3"))
|
||||
(green (if mono "black" "SeaGreen3")))
|
||||
|
||||
(pack c :expand #t :fill "both")
|
||||
|
||||
;; Display a 3x3 rectangular grid.
|
||||
(make <Rectangle> :parent c :coords '(0c 0c 30c 24c) :width 2)
|
||||
(make <Line> :parent c :coords '(0c 8c 30c 8c) :width 2)
|
||||
(make <Line> :parent c :coords '(0c 16c 30c 16c) :width 2)
|
||||
(make <Line> :parent c :coords '(10c 0c 10c 24c) :width 2)
|
||||
(make <Line> :parent c :coords '(20c 0c 20c 24c) :width 2)
|
||||
|
||||
;;
|
||||
;; Set up demos within each of the areas of the grid.
|
||||
;;
|
||||
|
||||
;; Lines
|
||||
(make <Text-item> :parent c :coords '(5c .2c) :text "Lines" :anchor "n")
|
||||
(make <Line> :parent c :coords '(1c 1c 3c 1c 1c 4c 3c 4c) :width "2m"
|
||||
:fill blue :cap "butt" :join "miter" :tags "item")
|
||||
(make <Line> :parent c :coords '(4.67c 1c 4.67c 4c) :arrow "last"
|
||||
:tags "item")
|
||||
(make <Line> :parent c :coords '(6.33c 1c 6.33c 4c) :arrow "both"
|
||||
:tags "item")
|
||||
(make <Line> :parent c
|
||||
:coords '(5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c)
|
||||
:width 3 :fill red :tags "item")
|
||||
(make <Line> :parent c :coords '(1c 5c 7c 5c 7c 7c 9c 7c) :width '.5c
|
||||
:stipple (string-append "@" *STk-images* "grey.25")
|
||||
:arrow "both" :arrow-shape (list 15 15 7) :tags "item")
|
||||
(make <Line> :parent c
|
||||
:coords '(1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c) :width '.5c
|
||||
:cap-style "round" :join-style "round" :tags "item")
|
||||
|
||||
;; Smoothed lines
|
||||
(make <Text-item> :parent c :coords '(15c .2c)
|
||||
:text "Curves (smoothed lines)" :anchor "n")
|
||||
(make <Line> :parent c :coords '(11c 4c 11.5c 1c 13.5c 1c 14c 4c)
|
||||
:smooth #t :fill blue :tags "item")
|
||||
(make <Line> :parent c :coords '(15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c)
|
||||
:smooth #t :arrow "both" :width 3 :tags "item")
|
||||
(make <Line> :parent c
|
||||
:coords '(12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c 7.5c 12c 6c)
|
||||
:smooth #t :width '3m :cap-style "round"
|
||||
:stipple (string-append "@" *STk-images* "grey.25")
|
||||
:fill red :tags "item")
|
||||
|
||||
;; Polygons
|
||||
(make <Text-item> :parent c :coords '(25c .2c) :text "Polygons"
|
||||
:anchor "n")
|
||||
(make <Polygon> :parent c
|
||||
:coords '(21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c)
|
||||
:fill green :outline "black" :width 4 :tags "item")
|
||||
(make <Polygon> :parent c
|
||||
:coords '(25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c 29c 4c 29c 4c)
|
||||
:fill red :smooth #t :tags "item")
|
||||
(make <Polygon> :parent c
|
||||
:coords '(22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c)
|
||||
:stipple (string-append "@" *STk-images* "grey.25")
|
||||
:outline "black" :tags "item")
|
||||
|
||||
;; Rectangles
|
||||
(make <Text-item> :parent c :coords '(5c 8.2c) :text "Rectangles"
|
||||
:anchor "n")
|
||||
(make <Rectangle> :parent c :coords '(1c 9.5c 4c 12.5c)
|
||||
:outline red :width '3m :tags "item")
|
||||
(make <Rectangle> :parent c :coords '(0.5c 13.5c 4.5c 15.5c)
|
||||
:fill green :tags "item")
|
||||
(make <Rectangle> :parent c :coords '(6c 10c 9c 15c)
|
||||
:stipple (string-append "@" *STk-images* "grey.25")
|
||||
:outline "" :fill blue :tags "item")
|
||||
|
||||
;; Ovals
|
||||
(make <Text-item> :parent c :coords '(15c 8.2c) :text "Ovals" :anchor "n")
|
||||
(make <Oval> :parent c :coords '(11c 9.5c 14c 12.5c)
|
||||
:outline red :width '3m :tags "item")
|
||||
(make <Oval> :parent c :coords '(10.5c 13.5c 14.5c 15.5c)
|
||||
:fill green :tags "item")
|
||||
(make <Oval> :parent c :coords '(16c 10c 19c 15c)
|
||||
:stipple (string-append "@" *STk-images* "grey.25")
|
||||
:outline "" :fill blue :tags "item")
|
||||
|
||||
;; Texts
|
||||
(make <Text-item> :parent c :coords '(25c 8.2c) :text "Text" :anchor "n")
|
||||
(make <Rectangle> :parent c :coords '(22.4c 8.9c 22.6c 9.1c))
|
||||
(make <Text-item> :parent c :coords '(22.5c 9c) :anchor "n"
|
||||
:font font1 :width '4c
|
||||
:text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text."
|
||||
:tags "item")
|
||||
(make <Rectangle> :parent c :coords '(25.4c 10.9c 25.6c 11.1c))
|
||||
(make <Text-item> :parent c :coords '(25.5c 11c) :anchor "w"
|
||||
:font font1 :fill blue
|
||||
:text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge."
|
||||
:justify "center" :tags "item")
|
||||
(make <Rectangle> :parent c :coords '(24.9c 13.9c 25.1c 14.1c))
|
||||
(make <Text-item> :parent c :coords '(25c 14c)
|
||||
:font font2 :anchor "c" :fill red
|
||||
:stipple (string-append "@" *STk-images* "grey.5")
|
||||
:text "Stippled characters" :tags "item")
|
||||
|
||||
;; Arcs
|
||||
(make <Text-item> :parent c :coords '(5c 16.2c) :text "Arcs" :anchor "n")
|
||||
(make <Arc> :parent c :coords '(0.5c 17c 7c 20c) :fill green
|
||||
:outline "black" :start 45 :extent 270 :style "pieslice" :tags "item")
|
||||
(make <Arc> :parent c :coords '(6.5c 17c 9.5c 20c) :width '4m :style "arc"
|
||||
:outline blue :start -135 :extent 270
|
||||
:outline-stipple (string-append "@" *STk-images* "grey.25")
|
||||
:tags "item")
|
||||
(make <Arc> :parent c :coords '(0.5c 20c 9.5c 24c) :width '4m
|
||||
:style "pieslice" :fill "" :outline red :start 225 :extent -90
|
||||
:tags "item")
|
||||
(make <Arc> :parent c :coords '(5.5c 20.5c 9.5c 23.5c) :width '4m
|
||||
:style "chord" :fill blue :outline "" :start 45 :extent 270
|
||||
:tags "item")
|
||||
|
||||
;; Bitmaps
|
||||
(make <Text-item> :parent c :coords '(15c 16.2c) :text "Bitmaps" :anchor "n")
|
||||
|
||||
(make <Bitmap-item> :parent c :coords '(13c 20c)
|
||||
:bitmap-name (string-append "@" *STk-images* "face")
|
||||
:tags "item")
|
||||
(make <Bitmap-item> :parent c :coords '(17c 18.5c)
|
||||
:bitmap-name (string-append "@" *STk-images* "noletters")
|
||||
:tags "item")
|
||||
(make <Bitmap-item> :parent c :coords '(17c 21.5c)
|
||||
:bitmap-name (string-append "@" *STk-images* "letters")
|
||||
:tags "item")
|
||||
|
||||
;; Windows
|
||||
(make <Text-item> :parent c :coords '(25c 16.2c) :text "Windows" :anchor "n")
|
||||
(make <Canvas-window> :parent c :coords '(21c 18c) :anchor "nw"
|
||||
:window (make <Button> :text "Press Me" :parent c
|
||||
:command (lambda ()
|
||||
(let ((i (make <Text-item> :parent c
|
||||
:coords '(25c 18.1c)
|
||||
:anchor "n"
|
||||
:text "Ouch!!"
|
||||
:fill "Red")))
|
||||
(after 500 (lambda ()
|
||||
(destroy i))))))
|
||||
:tags "item")
|
||||
(make <Canvas-window> :parent c :coords '(21c 21c) :anchor "nw"
|
||||
:window (make <Entry> :parent c :width 20 :relief "sunken"
|
||||
:value "Edit thid text")
|
||||
:tags "item")
|
||||
|
||||
(make <Canvas-window> :parent c :coords '(28.5c 17.5c) :anchor "n"
|
||||
:window (make <Scale> :parent c :from 0 :to 100 :length '6c
|
||||
:slider-length '.4c :width '.5c :tick-interval 0)
|
||||
:tags "item")
|
||||
(make <Text-item> :parent c :coords '(21c 17.9c) :text "Button" :anchor "sw")
|
||||
(make <Text-item> :parent c :coords '(21c 20.9c) :text "Entry" :anchor "sw")
|
||||
(make <Text-item> :parent c :coords '(28.5c 17.4c) :text "Scale" :anchor "s")
|
||||
|
||||
;; Set up event bindings for canvas:
|
||||
(let ((action #f)
|
||||
(x0 0) (y0 0)
|
||||
(x1 0) (y1 0)
|
||||
(x2 0) (y2 0))
|
||||
|
||||
(define (item-enter c)
|
||||
(let ((item (car (find-items c 'with "current"))))
|
||||
(cond
|
||||
((= (winfo 'depth c) 1)
|
||||
(set! action #f))
|
||||
((is-a? item <Canvas-window>)
|
||||
(set! action #f))
|
||||
((is-a? item <Bitmap-item>)
|
||||
(let ((bg (slot-ref item 'background)))
|
||||
(set! action `(slot-set! ,item 'background ,bg))
|
||||
(slot-set! item 'background "SteelBlue2")))
|
||||
((and (or (is-a? item <Rectangle>)
|
||||
(is-a? item <Oval>)
|
||||
(is-a? item <Arc>))
|
||||
(equal? (slot-ref item 'fill) ""))
|
||||
(let ((outline (slot-ref item 'outline)))
|
||||
(set! action `(slot-set! ,item 'outline ,outline))
|
||||
(slot-set! item 'outline "SteelBlue2")))
|
||||
(ELSE (let ((fill (slot-ref item 'fill)))
|
||||
(set! action `(slot-set! ,item 'fill ,fill))
|
||||
(slot-set! item 'fill "SteelBlue2"))))))
|
||||
|
||||
;; Utility procedures for stroking out a rectangle and printing what's
|
||||
;; underneath the rectangle's area.
|
||||
|
||||
(define (item-mark c x y)
|
||||
(set! x1 (canvas-x c x))
|
||||
(set! y1 (canvas-y c y))
|
||||
(canvas-delete c "area"))
|
||||
|
||||
(define (item-stroke c x y)
|
||||
(let ((x (canvas-x c x))
|
||||
(y (canvas-y c y)))
|
||||
(unless (and (= x x1) (= y y1))
|
||||
(canvas-delete c "area")
|
||||
(make <Rectangle> :parent c :coords (list x1 y1 x y) :tags "area")
|
||||
(set! x2 x)
|
||||
(set! y2 y))))
|
||||
|
||||
(define (items-under-area c)
|
||||
(format #t "Items enclosed by area: ~S\n"
|
||||
(find-items c 'enclosed x1 y1 x2 y2))
|
||||
(format #t "Items overlapping area: ~S\n"
|
||||
(cdr (reverse (find-items c 'overlapping x1 y1 x2 y2)))))
|
||||
|
||||
;; Utility procedures to support dragging of items.
|
||||
(define (item-start-drag c x y)
|
||||
(set! x0 (canvas-x c x))
|
||||
(set! y0 (canvas-x c y)))
|
||||
|
||||
(define (item-drag c x y)
|
||||
(let ((x (canvas-x c x))
|
||||
(y (canvas-x c y)))
|
||||
(move c "current" (- x x0) (- y y0))
|
||||
(set! x0 x)
|
||||
(set! y0 y)))
|
||||
|
||||
(bind c "item" "<Any-Enter>" (lambda () (item-enter c)))
|
||||
(bind c "item" "<Any-Leave>" (lambda () (eval action)))
|
||||
|
||||
(bind c "<1>" (lambda (x y) (item-start-drag c x y)))
|
||||
(bind c "<B1-Motion>" (lambda (x y) (item-drag c x y)))
|
||||
(bind c "<2>" (lambda (x y) (scan c 'mark x y)))
|
||||
(bind c "<B2-Motion>" (lambda (x y) (scan c 'dragto x y)))
|
||||
(bind c "<3>" (lambda (x y) (item-mark c x y)))
|
||||
(bind c "<B3-Motion>" (lambda (x y) (item-stroke c x y)))
|
||||
(bind c "<Control-f>" (lambda () (items-under-area c))))
|
||||
(focus c)
|
||||
|
||||
))
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; several label widgets.
|
||||
;;;;
|
||||
|
||||
(require "Button")
|
||||
|
||||
(define (demo-label)
|
||||
(let* ((w (make-demo-toplevel "label"
|
||||
"Label Demonstration"
|
||||
"Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them."))
|
||||
(left (make <Frame> :parent w))
|
||||
(right (make <Frame> :parent w)))
|
||||
|
||||
;; The labels on the left
|
||||
(pack (make <Label> :parent left :text "First label")
|
||||
(make <Label> :parent left :text "Second label, raised" :relief "raised")
|
||||
(make <Label> :parent left :text "Third label, sunken" :relief "sunken")
|
||||
:side "top"
|
||||
:expand #t
|
||||
:pady 2
|
||||
:anchor "w")
|
||||
|
||||
;; labels on the right
|
||||
(pack (make <Label> :parent right :border-width 2 :relief "sunken"
|
||||
:bitmap (string-append "@" *STk-images* "face"))
|
||||
(make <Label> :parent right :text "Tcl/Tk Proprietor")
|
||||
:side "top")
|
||||
|
||||
(pack left right :side "left" :expand #t :padx 10 :pady 10 :fill "both")))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a window with a bunch of menus
|
||||
;;;; and cascaded menus.
|
||||
;;;;
|
||||
|
||||
|
||||
(define (demo-menu)
|
||||
(let ((w (make-demo-toplevel "menu" "Menu Demonstration" #f))
|
||||
(txt "This window contains a collection of menus and cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator."))
|
||||
(define (mess str)
|
||||
(error "This is just a demo: no action has been defined for the \"~A\" entry"
|
||||
str))
|
||||
|
||||
(define (print-letter letter)
|
||||
(let ((binding (lambda () (display letter) (newline))))
|
||||
(bind w (format #f "<Meta-~A>" letter) binding)
|
||||
`(command :label ,(format #f "Print letter ~S" letter) :underline 14
|
||||
:accel ,(format #f "Meta+~a" letter) :command ,binding)))
|
||||
|
||||
(define (print-hello-goodbye text letter)
|
||||
(let ((binding (lambda () (display text) (newline))))
|
||||
(bind w (format #f "<Control-~A>" letter) binding)
|
||||
`(command :label ,(format #f "Print ~A" text)
|
||||
:underline 6 :accel ,(format #f "Control+~a" letter)
|
||||
:command ,binding)))
|
||||
|
||||
(define (print-message mess)
|
||||
`(command :label ,mess :command ,(lambda ()
|
||||
(format #t "You invoked ~S\n" mess))))
|
||||
|
||||
(define (print-message2 mess)
|
||||
`(command :label ,mess :background ,mess
|
||||
:command ,(lambda () (format #t "You invoked ~S\n" mess))))
|
||||
|
||||
(define f (make-menubar w
|
||||
`(("File"
|
||||
("Open ..." ,(lambda () (mess "Open ...")))
|
||||
("New" ,(lambda () (mess "New")))
|
||||
("Save" ,(lambda () (mess "Save")))
|
||||
("Save As ..." ,(lambda () (mess "Save As ...")))
|
||||
("")
|
||||
("Print Setup ..." ,(lambda () (mess "Print Setup ...")))
|
||||
("Print ..." ,(lambda () (mess "Print ...")))
|
||||
("")
|
||||
("Quit" ,(lambda () (destroy (winfo 'toplevel w)))))
|
||||
("Basic"
|
||||
("Long entry that does nothing"
|
||||
,(lambda () #f))
|
||||
,(print-letter "a")
|
||||
,(print-letter "b")
|
||||
,(print-letter "c")
|
||||
,(print-letter "d")
|
||||
,(print-letter "e")
|
||||
,(print-letter "f")
|
||||
,(print-letter "g"))
|
||||
("Cascades"
|
||||
,(print-hello-goodbye "Hello" "a")
|
||||
,(print-hello-goodbye "Goodbye" "b")
|
||||
("Check buttons"
|
||||
((check :label "Oil checked" :variable oil)
|
||||
(check :label "Transmission checked" :variable trans)
|
||||
(check :label "Brakes checked" :variable brakes)
|
||||
(check :label "Lights checked" :variable lights)
|
||||
("")
|
||||
("Show current values"
|
||||
,(lambda ()
|
||||
(show-variables w '(oil trans brakes lights))))))
|
||||
("Radio buttons"
|
||||
((radio :label "10 point" :variable point-size :value 10)
|
||||
(radio :label "14 point" :variable point-size :value 14)
|
||||
(radio :label "18 point" :variable point-size :value 18)
|
||||
(radio :label "24 point" :variable point-size :value 24)
|
||||
(radio :label "32 point" :variable point-size :value 32)
|
||||
("")
|
||||
(radio :label "Roman" :variable style :value "roman")
|
||||
(radio :label "Bold" :variable style :value "bold")
|
||||
(radio :label "Italic" :variable style :value "italic")
|
||||
("")
|
||||
("Show current values"
|
||||
,(lambda () (show-variables w '(style point-size)))))))
|
||||
("Icons"
|
||||
(command :bitmap ,(string-append "@" *stk-images* "/pattern")
|
||||
:command ,(lambda ()
|
||||
(STk:make-dialog :text "The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry." :buttons (list (list "OK" (lambda () 'OK))))))
|
||||
(command :bitmap "info"
|
||||
:command (format #t "You invoked the info bitmap\n"))
|
||||
(command :bitmap "questhead"
|
||||
:command (format #t "You invoked the questhead bitmap\n"))
|
||||
(command :bitmap "error"
|
||||
:command (format #t "You invoked the error bitmap\n")))
|
||||
("More"
|
||||
,(print-message "An entry")
|
||||
,(print-message "Another entry")
|
||||
,(print-message "Does nothing")
|
||||
,(print-message "Does almost nothing")
|
||||
,(print-message "Make life meaningful"))
|
||||
|
||||
("Colors"
|
||||
,(print-message2 "red")
|
||||
,(print-message2 "orange")
|
||||
,(print-message2 "yellow")
|
||||
,(print-message2 "green")
|
||||
,(print-message2 "blue")))))
|
||||
|
||||
(slot-set! f 'border-width 3)
|
||||
(slot-set! f 'relief "raised")
|
||||
(pack f
|
||||
(make <Label> :parent w
|
||||
:wrap-length "4i"
|
||||
:justify "left"
|
||||
:font demo-font
|
||||
:text txt)
|
||||
:expand #t :fill "x")))
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a canvas widget showing a 2-D
|
||||
;;;; plot with data points that can be dragged with the mouse.
|
||||
;;;;
|
||||
|
||||
;; demo-plot can be used also by the text embedded windows demos. In this case,
|
||||
;; it is called with an argument which its embedding window
|
||||
|
||||
(define (demo-plot . arg)
|
||||
(let* ((w (if (null? arg)
|
||||
(make-demo-toplevel "plot"
|
||||
"Plot Demonstration"
|
||||
"This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.")
|
||||
(car arg)))
|
||||
(c (make <Canvas> :parent w :width 450 :height 300
|
||||
:cursor "top_left_arrow"))
|
||||
(plot-font "-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*")
|
||||
(last-x 0)
|
||||
(last-y 0))
|
||||
|
||||
(define (plot-down w x y)
|
||||
(delete-tag w 'selected)
|
||||
(add-tag w 'selected 'withtag 'current)
|
||||
(raise c 'current)
|
||||
(set! last-x x)
|
||||
(set! last-y y))
|
||||
|
||||
(define (plot-move w x y)
|
||||
(move c 'selected (- x last-x) (- y last-y))
|
||||
(set! last-x x)
|
||||
(set! last-y y))
|
||||
|
||||
(pack c :side "top" :fill "x")
|
||||
|
||||
(make <Line> :parent c :coords '(100 250 400 250) :width 2)
|
||||
(make <Line> :parent c :coords '(100 250 100 50) :width 2)
|
||||
(make <Text-item> :parent c :coords '(225 20) :text "A Simple Plot"
|
||||
:font plot-font :fill "brown")
|
||||
|
||||
(dotimes (i 11)
|
||||
(let ((x (+ 100 (* 30 i))))
|
||||
(make <Line> :parent c :coords (list x 250 x 245) :width 2)
|
||||
(make <Text-item> :parent c :coords (list x 254) :anchor "n"
|
||||
:text (* 10 i) :font plot-font)))
|
||||
|
||||
(dotimes (i 6)
|
||||
(let ((y (- 250 (* 40 i))))
|
||||
(make <Line> :parent c :coords (list 100 y 105 y) :width 2)
|
||||
(make <Text-item> :parent c :coords (list 96 y) :anchor "e"
|
||||
:text (* 50 i) :font plot-font)))
|
||||
|
||||
(for-each (lambda (point)
|
||||
(let ((x (+ 100 (* 3 (car point))))
|
||||
(y (- 250 (* 0.8 (cadr point)))))
|
||||
(make <Oval> :parent c
|
||||
:coords (list (- x 6) (- y 6) (+ x 6) (+ y 6))
|
||||
:width 1
|
||||
:outline "black"
|
||||
:fill "SkyBlue2"
|
||||
:tags "point")))
|
||||
'((12 56) (20 94) (33 98) (32 120) (61 180) (75 160) (98 223)))
|
||||
|
||||
|
||||
(bind c "point" "<Any-Enter>"
|
||||
(lambda ()
|
||||
(let ((i (car (find-items c 'withtag 'current))))
|
||||
(set! (fill i) "red"))))
|
||||
|
||||
(bind c "point" "<Any-Leave>"
|
||||
(lambda ()
|
||||
(let ((i (car (find-items c 'withtag 'current))))
|
||||
(set! (fill i) "SkyBlue2"))))
|
||||
|
||||
(bind c "point" "<1>" (lambda (x y) (plot-down c x y)))
|
||||
(bind c "point" "<ButtonRelease-1>" (lambda ()
|
||||
(delete-tag c 'selected)))
|
||||
|
||||
(bind c "<B1-Motion>" (lambda (x y) (plot-move c x y)))
|
||||
c))
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; buttons that display bitmaps instead of text.
|
||||
;;;;
|
||||
|
||||
(require "Button")
|
||||
|
||||
(define (demo-puzzle)
|
||||
|
||||
(define (puzzle-switch w num xpos ypos space)
|
||||
(let ((x (vector-ref xpos num))
|
||||
(y (vector-ref ypos num))
|
||||
(x_spc (vector-ref xpos space))
|
||||
(y_spc (vector-ref ypos space)))
|
||||
(when (or (and (>= y (- y_spc 0.01)) (<= y (+ y_spc 0.01))
|
||||
(>= x (- x_spc 0.26)) (<= x (+ x_spc 0.26)))
|
||||
(and (>= x (- x_spc 0.01)) (<= x (+ x_spc 0.01))
|
||||
(>= y (- y_spc 0.26)) (<= y (+ y_spc 0.26))))
|
||||
(vector-set! xpos space x)
|
||||
(vector-set! xpos num x_spc)
|
||||
(vector-set! ypos space y)
|
||||
(vector-set! ypos num y_spc)
|
||||
(place w :relx x_spc :rely y_spc))))
|
||||
|
||||
|
||||
(let* ((w (make-demo-toplevel "puzzle"
|
||||
"15-Puzzle Demonstration"
|
||||
"This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected."))
|
||||
(frame (make <Frame> :parent w :width 120 :height 120 :border-width 2
|
||||
:relief "sunken")))
|
||||
|
||||
(pack frame :side "top" :pady 20 :padx 20)
|
||||
|
||||
(let ((order '#(3 1 6 2 5 7 15 13 4 11 8 9 14 10 12))
|
||||
(xpos (make-vector 16))
|
||||
(ypos (make-vector 16))
|
||||
(space 0))
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i 15))
|
||||
(let* ((num (vector-ref order i))
|
||||
(b (make <Button> :parent frame :text num
|
||||
:highlight-thickness 0)))
|
||||
;; Set the command of the button (and grab current environment)
|
||||
(set! (command b) (lambda ()
|
||||
(puzzle-switch b num xpos ypos space)))
|
||||
|
||||
(vector-set! xpos num (* (modulo i 4) 0.25))
|
||||
(vector-set! ypos num (* (floor (/ i 4)) 0.25))
|
||||
|
||||
(place b :relx (vector-ref xpos num)
|
||||
:rely (vector-ref ypos num)
|
||||
:relwidth 0.25
|
||||
:relheight 0.25)))
|
||||
(vector-set! xpos space 0.75)
|
||||
(vector-set! ypos space 0.75))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
;;;; STk adaptation of the Tk widget demo.
|
||||
;;;;
|
||||
;;;; This demonstration script creates a toplevel window containing
|
||||
;;;; several radiobutton widgets.
|
||||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(require "Button")
|
||||
|
||||
(define (demo-radio)
|
||||
(let* ((w (make-demo-toplevel "radio"
|
||||
"Radiobutton Demonstration"
|
||||
"Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables."
|
||||
'radio-size 'radio-color))
|
||||
(radios (make <Frame> :parent w))
|
||||
(left (make <Frame> :parent radios))
|
||||
(right (make <Frame> :parent radios)))
|
||||
|
||||
;; Create radiobuttons
|
||||
(for-each (lambda (pt)
|
||||
(pack (make <Radio-button>
|
||||
:parent left
|
||||
:text (format #f "Point Size ~A" pt)
|
||||
:variable 'radio-size
|
||||
:relief "flat"
|
||||
:width 15
|
||||
:anchor "w"
|
||||
:value pt)))
|
||||
'(10 12 18 24))
|
||||
|
||||
(for-each (lambda (color)
|
||||
(pack (make <Radio-button>
|
||||
:parent right
|
||||
:text color
|
||||
:variable 'radio-color
|
||||
:relief "flat"
|
||||
:width 15
|
||||
:anchor "w"
|
||||
:value color)))
|
||||
'("Red" "Green" "Blue" "Yellow" "Orange" "Purple"))
|
||||
|
||||
(pack left right :side "left" :expand #f :pady ".5c" :padx ".5c")
|
||||
(pack radios)))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue