v03i049: color demo, Part01/01
Mike Wexler
mikew at wyse.wyse.com
Sat Mar 11 06:28:23 AEST 1989
Submitted-by: kent at decwrl.dec.com (Chris Kent)
Posting-number: Volume 3, Issue 49
Archive-name: clover/part01
[I couldn't test this since it requires a color server. -mcw]
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 1 (of 1)."
# Contents: README AUTHOR Imakefile Makefile clover.1 clover.c
# clover.lsp lex.yy.c patchlevel.h
# Wrapped by mikew at wyse on Fri Mar 10 12:09:21 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" \(290 characters\)
sed "s/^X//" >'README' <<'END_OF_FILE'
XThis is a rewrite of a hack that originally was created on the MIT
XLisp Machines. Probably not for the faint of heart.
X
X(For historians, the original Lisp is included.)
X
XChris Kent Western Research Laboratory Digital Equipment Corporation
Xkent at decwrl.dec.com decwrl!kent (415) 853-6639
X
X
END_OF_FILE
if test 290 -ne `wc -c <'README'`; then
echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test -f 'AUTHOR' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'AUTHOR'\"
else
echo shar: Extracting \"'AUTHOR'\" \(383 characters\)
sed "s/^X//" >'AUTHOR' <<'END_OF_FILE'
XPath: decwrl!kent
XFrom: kent at decwrl.dec.com (Christopher A. Kent)
XNewsgroups: comp.sources.x
XSubject: clover -- an example of colormap hackery
XMessage-Id: <10 at gilroy.dec.com>
XDate: 8 Mar 89 23:25:19 GMT
XOrganization: DEC Western Research Laboratory
XLines: 1098
X
X
XChris Kent Western Research Laboratory Digital Equipment Corporation
Xkent at decwrl.dec.com decwrl!kent (415) 853-6639
X
X
END_OF_FILE
if test 383 -ne `wc -c <'AUTHOR'`; then
echo shar: \"'AUTHOR'\" unpacked with wrong size!
fi
# end of 'AUTHOR'
fi
if test -f 'Imakefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Imakefile'\"
else
echo shar: Extracting \"'Imakefile'\" \(178 characters\)
sed "s/^X//" >'Imakefile' <<'END_OF_FILE'
X SYS_LIBRARIES = $(XTOOLLIB) $(XMULIB) $(XLIB)
XLOCAL_LIBRARIES =
X SRCS = clover.c
X OBJS = clover.o
X
XComplexProgramTarget(clover)
XNormalLintTarget($(SRCS))
X
END_OF_FILE
if test 178 -ne `wc -c <'Imakefile'`; then
echo shar: \"'Imakefile'\" unpacked with wrong size!
fi
# end of 'Imakefile'
fi
if test -f 'Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Makefile'\"
else
echo shar: Extracting \"'Makefile'\" \(6566 characters\)
sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X# Makefile generated by imake - do not edit!
X# $XConsortium: imake.c,v 1.37 88/10/08 20:08:30 jim Exp $
X#
X# The cpp used on this machine replaces all newlines and multiple tabs and
X# spaces in a macro expansion with a single space. Imake tries to compensate
X# for this, but is not always successful.
X#
X
X###########################################################################
X# X Window System Makefile generated from template file Imake.tmpl
X# $XConsortium: Imake.tmpl,v 1.91 88/10/23 22:37:10 jim Exp $
X#
X# Do not change the body of the imake template file. Server-specific
X# parameters may be set in the appropriate .macros file; site-specific
X# parameters (but shared by all servers) may be set in site.def. If you
X# make any changes, you'll need to rebuild the makefiles using
X# "make World" (at best) or "make Makefile; make Makefiles" (at least) in
X# the top level directory.
X#
X# If your C preprocessor doesn't define any unique symbols, you'll need
X# to set BOOTSTRAPCFLAGS when rebuilding imake (usually when doing
X# "make Makefile", "make Makefiles", or "make World").
X#
X# If you absolutely can't get imake to work, you'll need to set the
X# variables at the top of each Makefile as well as the dependencies at the
X# bottom (makedepend will do this automatically).
X#
X
X###########################################################################
X# platform-specific configuration parameters - edit Sun.macros to change
X
X# platform: $XConsortium: Sun.macros,v 1.52 88/10/23 11:00:55 jim Exp $
X# operating system: SunOS 3.4
X
XBOOTSTRAPCFLAGS =
X AS = as
X CC = cc
X CPP = /lib/cpp
X LD = ld
X LINT = lint
X INSTALL = install
X TAGS = ctags
X RM = rm -f
X MV = mv
X LN = ln -s
X RANLIB = ranlib
XRANLIBINSTFLAGS = -t
X AR = ar clq
X LS = ls
X LINTOPTS = -xz
X LINTLIBFLAG = -C
X MAKE = make
XSTD_CPP_DEFINES =
X STD_DEFINES =
X
X###########################################################################
X# site-specific configuration parameters - edit site.def to change
X
X# site: $XConsortium: site.def,v 1.16 88/10/12 10:30:24 jim Exp $
X
X###########################################################################
X# definitions common to all Makefiles - do not edit
X
X SHELL = /bin/sh
X
X DESTDIR = /global
X USRLIBDIR = $(DESTDIR)/lib
X BINDIR = $(DESTDIR)/bin/X11
X INCDIR = $(DESTDIR)/include
X ADMDIR = $(DESTDIR)/usr/adm
X LIBDIR = $(USRLIBDIR)/X11
X LINTLIBDIR = $(USRLIBDIR)/lint
X FONTDIR = $(LIBDIR)/fonts
X XINITDIR = $(LIBDIR)/xinit
X XDMDIR = $(LIBDIR)/xdm
X UWMDIR = $(LIBDIR)/uwm
X AWMDIR = $(LIBDIR)/awm
X TWMDIR = $(LIBDIR)/twm
X DTDIR = $(LIBDIR)/dt
X MANPATH = /usr/man
X MANSOURCEPATH = $(MANPATH)/man
X MANDIR = $(MANSOURCEPATH)n
X LIBMANDIR = $(MANSOURCEPATH)n3
X XAPPLOADDIR = $(LIBDIR)/app-defaults
X
X INSTBINFLAGS = -m 0755
X INSTUIDFLAGS = -m 4755
X INSTLIBFLAGS = -m 0664
X INSTINCFLAGS = -m 0444
X INSTMANFLAGS = -m 0444
X INSTAPPFLAGS = -m 0444
X INSTKMEMFLAGS = -m 4755
X FCFLAGS = -t
X CDEBUGFLAGS = -O
X
X PATHSEP = /
X DEPEND = $(BINDIR)/makedepend
X IMAKE = $(BINDIR)/imake
X RGB = $(LIBDIR)/rgb
X FC = $(BINDIR)/bdftosnf
X MKFONTDIR = $(BINDIR)/mkfontdir
X MKDIRHIER = $(BINDIR)/mkdirhier.sh
X
X CFLAGS = $(CDEBUGFLAGS) $(INCLUDES) $(STD_DEFINES) $(DEFINES)
X LINTFLAGS = $(LINTOPTS) $(INCLUDES) $(STD_DEFINES) $(DEFINES) -DLINT
X LDFLAGS = $(CDEBUGFLAGS) -L$(USRLIBDIR) $(SYS_LIBRARIES) $(SYSAUX_LIBRARIES)
X
X IRULESRC = $(LIBDIR)/imake.includes
X
X EXTENSIONLIB = $(USRLIBDIR)/libext.a
X XLIB = $(USRLIBDIR)/libX11.a
X XMULIB = $(USRLIBDIR)/libXmu.a
X OLDXLIB = $(USRLIBDIR)/liboldX.a
X XTOOLLIB = $(USRLIBDIR)/libXt.a
X XAWLIB = $(USRLIBDIR)/libXaw.a
X LINTXLIB = $(USRLIBDIR)/lint/llib-lX11.ln
X LINTXMU = $(USRLIBDIR)/lint/llib-lXmu.ln
X LINTXTOOL = $(USRLIBDIR)/lint/llib-lXt.ln
X LINTXAW = $(USRLIBDIR)/lint/llib-lXaw.ln
X INCLUDES = -I$(INCDIR)
X MACROFILE = Sun.macros
X ICONFIGFILES = $(IRULESRC)/Imake.tmpl \
X $(IRULESRC)/$(MACROFILE) $(IRULESRC)/site.def
X IMAKE_DEFINES =
X IMAKE_CMD = $(NEWTOP)$(IMAKE) -TImake.tmpl -I$(NEWTOP)$(IRULESRC) \
X -s Makefile $(IMAKE_DEFINES)
X RM_CMD = $(RM) *.CKP *.ln *.BAK *.bak *.o core errs ,* *~ *.a \
X .emacs_* tags TAGS make.log MakeOut
X
X###########################################################################
X# rules: $XConsortium: Imake.rules,v 1.71 88/10/23 22:46:34 jim Exp $
X
X###########################################################################
X# start of Imakefile
X
X SYS_LIBRARIES = $(XTOOLLIB) $(XMULIB) $(XLIB)
XLOCAL_LIBRARIES =
X SRCS = clover.c
X OBJS = clover.o
X
X PROGRAM = clover
X
Xall:: clover
X
Xclover: $(OBJS) $(LOCAL_LIBRARIES)
X $(RM) $@
X $(CC) -o $@ $(OBJS) $(LOCAL_LIBRARIES) $(LDFLAGS) $(SYSLAST_LIBRARIES)
X
Xrelink::
X $(RM) $(PROGRAM)
X $(MAKE) $(MFLAGS) $(PROGRAM)
X
Xinstall:: clover
X $(INSTALL) -c $(INSTALLFLAGS) clover $(BINDIR)
X
Xinstall.man:: clover.man
X $(INSTALL) -c $(INSTMANFLAGS) clover.man $(MANDIR)/clover.n
X
Xdepend:: $(DEPEND)
X
Xdepend::
X $(DEPEND) -s "# DO NOT DELETE" -- $(CFLAGS) -- $(SRCS)
X
X$(DEPEND):
X @echo "making $@"; \
X cd $(DEPENDSRC); $(MAKE)
X
Xclean::
X $(RM) $(PROGRAM)
X
Xlint:
X $(LINT) $(LINTFLAGS) $(SRCS) $(LINTLIBS)
Xlint1:
X $(LINT) $(LINTFLAGS) $(FILE) $(LINTLIBS)
X
X###########################################################################
X# Imake.tmpl common rules for all Makefiles - do not edit
X
Xemptyrule::
X
Xclean::
X $(RM_CMD) \#*
X
XMakefile:: $(IMAKE)
X
XMakefile:: Imakefile \
X $(IRULESRC)/Imake.tmpl \
X $(IRULESRC)/Imake.rules \
X $(IRULESRC)/site.def \
X $(IRULESRC)/$(MACROFILE)
X - at if [ -f Makefile ]; then \
X echo "$(RM) Makefile.bak; $(MV) Makefile Makefile.bak"; \
X $(RM) Makefile.bak; $(MV) Makefile Makefile.bak; \
X else exit 0; fi
X $(IMAKE_CMD) -DTOPDIR=$(TOP)
X
X$(IMAKE):
X @echo "making $@"; \
X cd $(IMAKESRC); $(MAKE) BOOTSTRAPCFLAGS=$(BOOTSTRAPCFLAGS)
X
Xtags::
X $(TAGS) -w *.[ch]
X $(TAGS) -xw *.[ch] > TAGS
X
X###########################################################################
X# empty rules for directories that do not have SUBDIRS - do not edit
X
Xinstall::
X @echo "install done"
X
Xinstall.man::
X @echo "install.man done"
X
XMakefiles::
X
X###########################################################################
X# dependencies generated by makedepend
X
END_OF_FILE
if test 6566 -ne `wc -c <'Makefile'`; then
echo shar: \"'Makefile'\" unpacked with wrong size!
fi
# end of 'Makefile'
fi
if test -f 'clover.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'clover.1'\"
else
echo shar: Extracting \"'clover.1'\" \(1438 characters\)
sed "s/^X//" >'clover.1' <<'END_OF_FILE'
X.TH clover 1 "6 March 1989" "X Version 11"
X.SH NAME
Xclover \- a color map hack for X
X.SH SYNTAX
X.B clover
X[ \fIoptions\fR ]
X.SH DESCRIPTION
X.I Clover
Xdraws a symmetric image and animates it by manipulating the display's
Xcolormap.
XClover tries very hard to be ICCCM compliant, which means that it counts
Xon the window manager to install its private color map. The animation won't be
Xapparent until you get the window manager's attention (usually by directing
Xinput focus to clover's window).
X.PP
XThe animation speed varies \- clicking in the window resets the delay between
Xsteps to the inital value.
XTyping 'q' in the window terminates the program.
X.SH OPTIONS
XIn addition to the standard X toolkit command line and resource options,
X.I clover
Xunderstands three others:
X.TP
X.BI -colors \ n
XUse
Xat most
X.I n
Xcolormap cells for the animation.
XThe default is MAX(15, sizeof(colorMap)).
XMore colors make for a more interesting display, but can slow things down
Xconsiderably.
X.TP
X.BI -radius \ r
XUse
X.I r
Xas the `radius' of the image.
X.TP
X.BI -speed \ s
XUse
X.I s
Xas the inital delay between steps in the animation.
X.PP
XThe default geometry value covers the entire display.
X.SH NOTE
X.I Clover
Xcan only run on a display with a
X.IR PseudoColor ,
X.IR DirectColor ,
Xor
X.I GrayScale
Xvisual.
X
XIt probably won't work right under uwm.
X.SH AUTHOR
XChristopher A. Kent (DECWRL)
X.br
XAlgorithm originally due to Bill Gosper, on the MIT Lisp Machine.
END_OF_FILE
if test 1438 -ne `wc -c <'clover.1'`; then
echo shar: \"'clover.1'\" unpacked with wrong size!
fi
# end of 'clover.1'
fi
if test -f 'clover.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'clover.c'\"
else
echo shar: Extracting \"'clover.c'\" \(15344 characters\)
sed "s/^X//" >'clover.c' <<'END_OF_FILE'
X/* $Header$ */
X
X/*
X * clover.c - Gosper's LispM "smoking clover" color table hack
X *
X * Author: Christopher A. Kent
X * Western Research Laboratory
X * Digital Equipment Corporation
X * Date: Wed Feb 22 1989
X */
X
X/*
X * $Log$
X */
X
Xstatic char rcs_ident[] = "$Header$";
X
X#include <stdio.h>
X
X#include <X11/Xos.h>
X#include <X11/Xlib.h>
X#include <X11/Xutil.h>
X#include <X11/Xatom.h>
X#include <X11/Xresource.h>
X#include <X11/StringDefs.h>
X#include <X11/Intrinsic.h>
X#include <X11/cursorfont.h>
X
X#define NCOLORS 16
X#define R 5432
X#define S 4321
X
X#define MIN(x, y) ((x) < (y))?(x):(y)
X#define MAX(x, y) ((x) > (y))?(x):(y)
X#define CEIL(a, b) ((a)+(b)-1)/(b)
X#define FLOOR(a, b) CEIL((a)-(b), (b))
X
XDisplay *dpy; /* the display */
XWindow w; /* the window */
Xint screen; /* the screen to use */
XColormap colorMap; /* private Colormap resource */
XXColor *colors; /* color sets */
Xint cmap = 0; /* which color set to use now */
XVisual *v; /* the appropriate visual */
Xint nColors; /* how many colors (per v) */
XPixel fg_pixel; /* specified fg color (ignored) */
XPixel bg_pixel; /* specified bg color */
XPixel borderColor; /* ... border color */
XCardinal borderWidth; /* ... border width */
XString geometry; /* ... geometry */
Xint posX, posY; /* ... position */
Xint width, height; /* ... sizes */
Xint one = 1;
Xint radius = R; /* ... 'radius' of clover */
Xint speed = S; /* ... initial speed */
Xint maxColors = NCOLORS; /* ... maximum colors to use */
X
Xchar *malloc();
X
X#define XtNgeometry "geometry"
X#define XtCGeometry "Geometry"
X#define XtNcolors "colors"
X#define XtCColors "Colors"
X#define XtNradius "radius"
X#define XtCRadius "Radius"
X#define XtNspeed "speed"
X#define XtCSpeed "Speed"
X
Xstatic XrmOptionDescRec opTable[] = {
X{"-geometry", "*geometry", XrmoptionSepArg, (caddr_t) NULL},
X{"-colors", "*colors", XrmoptionSepArg, (caddr_t) NULL},
X{"-radius", "*radius", XrmoptionSepArg, (caddr_t) NULL},
X{"-speed", "*speed", XrmoptionSepArg, (caddr_t) NULL},
X};
X
Xstatic XtResource resources[] = { /* don't really need some of these */
X {XtNforeground, XtCForeground, XtRPixel, sizeof(Pixel),
X (Cardinal)&fg_pixel, XtRString, "black"},
X {XtNbackground, XtCBackground, XtRPixel, sizeof(Pixel),
X (Cardinal)&bg_pixel, XtRString, "white"},
X {XtNborderWidth, XtCBorderWidth, XtRInt, sizeof(int),
X (Cardinal)&borderWidth, XtRInt, (caddr_t) &one},
X {XtNborder, XtCBorderColor, XtRPixel, sizeof(Pixel),
X (Cardinal)&borderColor, XtRString, "black"},
X {XtNgeometry, XtCGeometry, XtRString, sizeof(char *),
X (Cardinal)&geometry, XtRString, (caddr_t) NULL},
X {XtNcolors, XtCColors, XtRInt, sizeof(int),
X (Cardinal)&maxColors, XtRInt, (caddr_t) &maxColors},
X {XtNradius, XtCRadius, XtRInt, sizeof(int),
X (Cardinal)&radius, XtRInt, (caddr_t) &radius},
X {XtNspeed, XtCSpeed, XtRInt, sizeof(int),
X (Cardinal)&speed, XtRInt, (caddr_t) &speed},
X};
X
Xmain(argc, argv)
Xchar **argv;
X{
X Widget widg;
X XEvent xev;
X XSizeHints hint;
X char text[10];
X int i;
X KeySym key;
X Pixmap p, cloverPixmap();
X XWindowAttributes attr;
X Bool mapped = False;
X Cursor spiral;
X int cycleDelay, cycleDecrement = 0, currentSpeed;
X
X /*
X * We cheat here by using the Toolkit to do the initialization work.
X * We just ignore the top-level widget that gets created.
X */
X
X widg = XtInitialize("clover", "clover", opTable, XtNumber(opTable),
X &argc, argv);
X dpy = XtDisplay(widg);
X screen = DefaultScreen(dpy);
X
X XtGetApplicationResources(widg, (caddr_t) NULL, resources,
X XtNumber(resources), NULL, (Cardinal) 0);
X
X posX = posY = -1;
X width = height = 0;
X if (geometry) {
X int mask, gx, gy, gw, gh;
X
X mask = XParseGeometry(geometry, &gx, &gy, &gw, &gh);
X if (mask & WidthValue)
X width = gw;
X if (mask & HeightValue)
X height = gh;
X if (mask & XValue)
X if (mask & XNegative)
X posX = DisplayWidth(dpy, screen) -
X width + posX;
X else
X posX = gx;
X if (mask & YValue)
X if (mask & YNegative)
X posY = DisplayHeight(dpy, screen) -
X height + posY;
X else
X posY = gy;
X }
X
X hint.width = width = width ? width : DisplayWidth(dpy, screen);
X hint.height = height = height ? height : DisplayHeight(dpy, screen);
X hint.x = posX >= 0 ? posX : (DisplayWidth(dpy, screen) - width)/2;
X hint.y = posY >= 0 ? posY : (DisplayHeight(dpy, screen) - height)/2;
X hint.flags = PPosition | PSize;
X
X w = XCreateSimpleWindow(dpy, DefaultRootWindow(dpy),
X hint.x, hint.y,
X hint.width, hint.height,
X borderWidth,
X BlackPixel(dpy, screen),
X WhitePixel(dpy, screen));
X XSetStandardProperties(dpy, w, "Smoking Clover", "clover", None,
X argv, argc, &hint);
X XSelectInput(dpy, w,
X ButtonPressMask | ExposureMask |
X KeyPressMask | StructureNotifyMask);
X
X buildColormaps();
X
X p = cloverPixmap(radius);
X
X spiral = XCreateFontCursor(dpy, XC_box_spiral);
X
X XSynchronize(dpy, True);
X XMapRaised(dpy, w);
X
X cycleDelay = speed;
X currentSpeed = speed;
X while(1) {
X if (mapped && !XPending(dpy)) {
X if (--cycleDelay <= 0) {
X cycle();
X cycleDelay = currentSpeed;
X if (++cycleDecrement%16 == 0)
X currentSpeed >>= 1;
X }
X continue;
X }
X
X XNextEvent(dpy, &xev);
X switch(xev.type) {
X case Expose:
X case MapNotify:
X mapped = True;
X break;
X
X case ConfigureNotify:
X XSynchronize(dpy, True);
X XDefineCursor(dpy, w, spiral);
X XGetWindowAttributes(dpy, w, &attr);
X width = attr.width;
X height = attr.height;
X XFreePixmap(dpy, p);
X p = cloverPixmap(radius);
X XClearWindow(dpy, w);
X XUndefineCursor(dpy, w);
X XSynchronize(dpy, False);
X break;
X
X case UnmapNotify:
X mapped = False;
X break;
X
X case MappingNotify:
X XRefreshKeyboardMapping(&xev);
X break;
X
X case ButtonPress:
X currentSpeed = speed;
X break;
X
X case KeyPress:
X i = XLookupString(&xev, text, 10, &key, 0);
X if (i == 1 && text[0] == 'q')
X exit(0);
X break;
X }
X }
X}
X
X/*
X * Decide how many colors to use (depends on the available Visuals). Create a
X * private Colormap and that many sets of color cells. Load the first set with
X * a random selection of colors, and the rest so that the colors slide through
X * the pixel values.
X *
X * It might seem more straightforward to allocate nColors Colormaps, load them
X * and explicitly install them, but well-behaved clients should not install
X * Colormaps explicitly. Rather, they should change the Colormap attribute and
X * wait for the window manager to do the installation. This slows things down
X * a lot, so we do explict XStoreColors calls to cycle through the color sets.
X *
X */
X
X/*
X * There are nColors sets of (nColors+1) colors each. Slots [0..nColors-1]
X * rotate in subsequent sets; slot nColors is always the background color.
X */
X
X#define COLOR(a, b) colors[((a)*(nColors+1))+(b)]
X
XbuildColormaps()
X{
X int i, j;
X XColor *c1, *c2, tempColor, bgColor;
X Visual *findVisual();
X
X v = findVisual();
X if (v == NULL) {
X printf("Sorry, clover needs a writable colormap to run\n");
X exit(0);
X }
X
X /*
X * Find out the color values of the specified background...
X */
X
X bgColor.pixel = bg_pixel;
X XQueryColor(dpy, DefaultColormap(dpy, screen), &bgColor);
X
X colors = (XColor *) malloc((nColors+1) * nColors * sizeof(XColor));
X
X colorMap = XCreateColormap(dpy, w, v, AllocAll);
X
X /*
X * allocate random colors into first color map, with bg at the end
X */
X
X for (i = 0; i < nColors; i++) {
X c1 = &COLOR(0, i);
X c1->pixel = i;
X if (i == 0) {
X c1->red = 0;
X c1->green = (unsigned short) -65535/6;
X c1->blue = 65535/6;
X } else {
X c2 = &COLOR(0, i-1);
X c1->red = c2->red - random()/6;
X c1->green = c2->green - random()/6;
X c1->blue = c2->blue - random()/6;
X }
X c1->flags = DoRed | DoGreen | DoBlue;
X
X for (j = 1; j < nColors; j++)
X COLOR(j, i).pixel = i;
X }
X c1 = &COLOR(0, nColors);
X c1->pixel = nColors;
X c1->red = bgColor.red;
X c1->green = bgColor.green;
X c1->blue = bgColor.blue;
X c1->flags = DoRed | DoGreen | DoBlue;
X XStoreColors(dpy, colorMap, colors, nColors+1);
X
X
X /* rotate colors (but not pixels) through other colors */
X for (i = 1; i < nColors; i++) {
X tempColor = COLOR(i-1, 0);
X for (j = 0; j < nColors-1; j++) {
X c1 = &COLOR(i, j);
X c2 = &COLOR(i-1, j+1);
X c1->red = c2->red;
X c1->green = c2->green;
X c1->blue = c2->blue;
X c1->flags = c2->flags;
X }
X c1 = &COLOR(i, nColors-1);
X c2 = &tempColor;
X c1->red = c2->red;
X c1->green = c2->green;
X c1->blue = c2->blue;
X c1->flags = c2->flags;
X
X COLOR(i, nColors) = COLOR(i-1, nColors);
X }
X}
X
X/*
X * Create the image in memory. Assumes several things have already been set up
X * in global variables.
X */
X
Xchar *bits;
Xint trace = 0;
X#define getPixel(x, y) bits[(y)*width+(x)]
X#define putPixel(x, y, v) bits[(y)*width+(x)] = (v)%nColors;
XxputPixel(x, y, v)
X{
X printf("%d, %d -> %d/%d\n", x, y, v, v%nColors);
X xputPixel(x, y, v);
X}
X
XPixmap
XcloverPixmap(r)
X{
X XImage *im, *simpleImage(), *cloverImage();
X Pixmap p;
X XSetWindowAttributes attr;
X
X im = cloverImage(r);
X p = XCreatePixmap(dpy, w, width, height, XDefaultDepth(dpy, screen));
X XPutImage(dpy, p, DefaultGC(dpy, screen), im,
X 0, 0, 0, 0, width, height);
X XDestroyImage(im);
X
X attr.background_pixmap = p;
X attr.colormap = colorMap;
X attr.bit_gravity = CenterGravity;
X XChangeWindowAttributes(dpy, w,
X CWBackPixmap | CWColormap | CWBitGravity,
X &attr);
X
X return p;
X}
X
XXImage *
XsimpleImage()
X{
X int i, j;
X XImage *im;
X
X bits = malloc(width * height);
X
X for (i = 0; i < height; i++)
X for (j = 0; j< width; j++)
X bits[i * width + j] = i % nColors;
X
X im = XCreateImage(dpy, v,
X XDefaultDepth(dpy, screen),
X ZPixmap, 0, bits, width, height, 0, width);
X free(bits);
X return im;
X}
X
X/*
X * Basically the algorithm is to draw a series of Bresenham lines from the
X * center. The "interference pattern" is built by incrementing the pixel value
X * of (x,y) every time it's touched; the resulting pattern is a product of the
X * vagaries of integer arithmetic.
X */
X
XXImage *
XcloverImage(r)
X{
X XImage *im;
X int maxX, maxY, midX, midY, x, f, y;
X int v, yy, x1, y1;
X int i, o;
X char *b;
X
X bits = malloc(width * height);
X if (bits == NULL) {
X perror("No memory");
X exit(-1);
X }
X
X maxX = width - 1;
X maxY = height - 1;
X midX = maxX / 2;
X midY = maxY / 2;
X
X for (y = 0; y < height; y++) {
X b = &bits[y*width];
X for (x = 0; x < width; x++)
X *b++ = nColors; /* fill in background */
X }
X
X /*
X * Fill in the first semi-quadrant.
X */
X
X x = r;
X f = 0;
X for (y = 0; y < x; y++) {
X if (f > x) {
X x--;
X f = f-x - (x-1);
X }
X clipLine(midX, midY, x+midX, y+midY, 0, 0, maxX, maxY);
X f = f+y + y+1;
X }
X
X /*
X * Copy to the other seven, adjusting the horizontal and diagonal.
X */
X
X for (x = midX; x < maxX; x++) {
X/* putPixel(x, midY, (getPixel(x, midY) << 1) - 1);*/
X if (x - midX + midY <= maxY)
X putPixel(x, x-midX+midY,
X (getPixel(x, x-midX+midY) << 1) - 1);
X yy = MIN(maxY, x + midY - midX);
X for (y = midY; y <= yy; y++) {
X v = getPixel(x, y);
X x1 = x;
X y1 = y;
X for (i = 0; i < 4; i++) {
X if ((y1 < maxY) && (y1 > 0)) {
X putPixel(midX + midX - x1, y1, v);
X putPixel(x1, y1, v);
X }
X o = x1;
X x1 = midX + midY - y1;
X y1 = midY + o - midX;
X }
X }
X }
X
X im = XCreateImage(dpy, v,
X XDefaultDepth(dpy, screen),
X ZPixmap, 0, bits, width, height, 0, width);
X free(bits);
X return im;
X}
X
X/*
X * (xe, ye) and (xf, yf) are the corners of a rectangle to clip a line to.
X * (x0, y0) and (xn, yn) are the endpoints of the line to clip.
X * The function argument that's being computed is the semi-quadrant;
X * dx and dy are used to determine whether we're above or below the diagonal,
X * since (x0, y0) is always the midpoint of the pattern.
X * (The LispM has the origin at lower left, instead of upper left, so
X * the numbers don't correspond to the normal Cartesian plane quadrants.)
X *
X * This routine is very general, but the calling code only builds lines in the
X * first semi-quadrant and then copies them everywhere else.
X */
X
XclipLine(x0, y0, xn, yn, xe, ye, xf, yf)
X{
X int dx, dy;
X
X dx = abs(xn - x0);
X dy = abs(yn - y0);
X
X if (xn > x0) { /* moving right */
X if (yn >= y0) { /* moving up */
X if (dx > dy) /* below diagonal */
X line(0, x0, y0, dx, dy, xe, ye, xf, yf);
X else
X line(1, y0, x0, dy, dx, ye, xe, yf, xf);
X } else {
X if (dx > dy)
X line(7, x0, -y0, dx, dy, xe, -yf, xf, -ye);
X else
X line(6, -y0, x0, dy, dx, -yf, xe, -ye, xf);
X }
X } else {
X if (yn >= y0) {
X if (dx > dy)
X line(3, -x0, y0, dx, dy, -xf, ye, -xe, yf);
X else
X line(2, y0, -x0, dy, dx, ye, -xf, yf, -xe);
X } else {
X if (dx > dy)
X line(4, -x0, -y0, dx, dy, -xf, -yf, -xe, -ye);
X else
X line(5, -y0, -x0, dy, dx, -yf, -xf, -ye, -xe);
X }
X }
X}
X
X#define plot(x, y) putPixel((x), (y), getPixel((x), (y))+1)
X
X/*
X * Clip symmetric segment (x0, y0) thru (xn, yn) to the rectangle
X * (xe, ye) < (xf, yf).
X *
X * The original says:
X *
X * "This routine incorrectly assumes that the subsegment starts prior to the
X * midpoint of the supersegment. The 'divide for nearest integer' (i.e.,
X * divide for remainder of minimum magnitude), which is simulated by the FLOOR
X * and CEIL of num and (dx <<1), always rounds up on the half integer case, but
X * should round down (for symmetry) if startup is in 2nd half. It would be
X * nice to have these other flavors of divide.'
X */
X
Xline(fun, x0, y0, dx, dy, xe, ye, xf, yf)
X{
X int x, num, lx;
X int xx, y, x00, f;
X int x11;
X
X x = MAX(x0, MAX(xe,
X (dy == 0)? xe :
X x0 + CEIL(dx * (((ye - y0)<<1) - 1),
X (dy << 1))));
X num = dx + 2*dy*(x - x0);
X lx = MIN(xf, (dy == 0) ? xf :
X x0 + CEIL(dx * (((yf - y0)<<1) - 1),
X (dy << 1)));
X xx = MIN(lx, x0 + (dx>>1));
X y = y0 + FLOOR(num, (dx<<1));
X f = (FLOOR(num, (dx<<1)) - dx) >> 1;
X
X for (x00 = x; x00 < xx; x00++,f+=dy) {
X if (f+f > dx) {
X f -= dx;
X y++;
X }
X switch(fun) {
X case 0: plot(x00, y); break;
X case 1: plot(y, x00); break;
X case 2: plot(-y, x00); break;
X case 3: plot(-x00, y); break;
X case 4: plot(-x00, -y); break;
X case 5: plot(-y, -x00); break;
X case 6: plot(y, -x00); break;
X case 7: plot(x00, -y); break;
X }
X }
X
X for (x11 = x00; x11 < lx; x11++, f+=dy) {
X if (f + f > dx) {
X f -= dx;
X y++;
X }
X switch(fun) {
X case 0: plot(x11, y); break;
X case 1: plot(y, x11); break;
X case 2: plot(-y, x11); break;
X case 3: plot(-x11, y); break;
X case 4: plot(-x11, -y); break;
X case 5: plot(-y, -x11); break;
X case 6: plot(y, -x11); break;
X case 7: plot(x11, -y); break;
X }
X }
X}
X
X/*
X * Install the next set of colors in the cycle.
X */
X
Xcycle()
X{
X cmap = ++cmap % nColors;
X XStoreColors(dpy, colorMap, &colors[cmap * (nColors+1)], nColors+1);
X}
X
X/*
X * Find an appropriate visual (and set the screen and nColors as a side effect)
X * to run on.
X */
X
Xint classes[] = {
X PseudoColor,
X DirectColor,
X GrayScale,
X 0
X};
X
XVisual *
XfindVisual()
X{
X int howMany, i, max, *class;
X XVisualInfo *vip, vTemplate;
X
X for (class = classes; *class; class++) {
X vTemplate.class = *class;
X vip = XGetVisualInfo(dpy, VisualClassMask,
X &vTemplate, &howMany);
X if (vip) {
X max = 0;
X for (i = 0; i < howMany; i++) {
X if (vip->colormap_size > max)
X v = vip->visual;
X max = vip->colormap_size;
X }
X screen = vip->screen;
X nColors = MIN(maxColors, vip->colormap_size);
X nColors--;
X return v;
X }
X }
X return NULL;
X}
END_OF_FILE
if test 15344 -ne `wc -c <'clover.c'`; then
echo shar: \"'clover.c'\" unpacked with wrong size!
fi
# end of 'clover.c'
fi
if test -f 'clover.lsp' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'clover.lsp'\"
else
echo shar: Extracting \"'clover.lsp'\" \(13240 characters\)
sed "s/^X//" >'clover.lsp' <<'END_OF_FILE'
X ;;; -*- Mode: LISP; Package: hacks; base: 8; lowercase: t -*-
X
X(defvar *color-screen-array*)
X
X(defsubst //- (n d) (floor n d))
X
X(defun \- (n d)
X (multiple-value-bind (nil rem) (floor n d) rem))
X
X(defsubst //+ (n d) (ceiling n d))
X
X(defmacro plot (x1 y1)
X `(as-2-reverse (1+ (ar-2-reverse *color-screen-array* ,x1 ,y1))
X *color-screen-array*
X ,x1
X ,y1))
X
X(defun draw-sym-line (x0 y0 xn yn &optional ignore ignore
X &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
X (draw-sym-subline x0 y0 xn yn 0 max))
X
X(defun draw-sym-fractional-line (x0 y0 xn yn begfrac endfrac
X &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
X (draw-sym-subline x0 y0 xn yn
X (- (fix (* -1 begfrac max)))
X (fix (* endfrac max))))
X
X(defun draw-sym-subline (x0 y0 xn yn i j &optional (dx (abs (- xn x0))) (dy (abs (- yn y0))))
X (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot0 x0 y0 dx dy i j))
X ((line-loop #'plot1 y0 x0 dy dx i j))))
X ((cond ((> dx dy) (line-loop #'plot7 x0 (- y0) dx dy i j))
X ((line-loop #'plot6 (- y0) x0 dy dx i j))))))
X ((cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot3 (- x0) y0 dx dy i j))
X ((line-loop #'plot2 y0 (- x0) dy dx i j))))
X ((cond ((> dx dy) (line-loop #'plot4 (- x0) (- y0) dx dy i j))
X ((line-loop #'plot5 (- y0) (- x0) dy dx i j))))))))
X
X(defun line-loop (fun x0 y0 dx dy i j
X &aux (num (+ dx (* 2 i dy))))
X (do ((j2 (min j (ash dx -1)))
X (y (+ y0 (truncate num (ash dx 1))))
X (i i (1+ i))
X (x (+ x0 i) (1+ x))
X (f (ash (- (\ num (ash dx 1)) dx) -1) (+ f dy)))
X ((> i j2) (do ((i i (1+ i))
X (x x (1+ x))
X (f f (+ f dy)))
X ((> i j))
X (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X
X(defun draw-clip-sym-line (x0 y0 xn yn xe ye xf yf
X &optional (dx (abs (- xn x0))) (dy (abs (- yn y0))))
X (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy)
X (line-clip #'plot0 x0 y0 dx dy xe ye xf yf))
X ((line-clip #'plot1 y0 x0 dy dx ye xe yf xf))))
X ((cond ((> dx dy)
X (line-clip #'plot7 x0 (- y0) dx dy xe (- yf) xf (- ye)))
X ((line-clip #'plot6 (- y0) x0 dy dx (- yf) xe (- ye) xf))))))
X ((cond ((> yn y0)
X (cond ((> dx dy)
X (line-clip #'plot3 (- x0) y0 dx dy (- xf) ye (- xe) yf))
X ((line-clip #'plot2 y0 (- x0) dy dx ye (- xf) yf (- xe)))))
X ((cond ((> dx dy)
X (line-clip #'plot4 (- x0) (- y0) dx dy (- xf) (- yf) (- xe) (- ye)))
X ((line-clip #'plot5 (- y0) (- x0) dy dx (- yf) (- xf) (- ye) (- xe)))))))))
X;clip symmetric segment (x0, y0) thru (xn, yn) to the rectangle (xe, ye) < (xf,yf)
X
X(defun line-clip (fun x0 y0 dx dy xe ye xf yf
X &aux (x (max x0 xe (if (= dy 0) xe (+ x0 (//+ (* dx
X (1- (ash (- ye y0) 1)))
X (ash dy 1))))))
X (num (+ dx (* 2 dy (- x x0))))
X (lx (min xf (if (= dy 0) xf (+ x0 (//+ (* dx (1- (ash (- yf y0) 1)))
X (ash dy 1)))))))
X (do ((xx (min (+ x0 (ash dx -1)) lx))
X (y (+ y0 (//- num (ash dx 1))))
X (x x (1+ x))
X (f (ash (- (\- num (ash dx 1)) dx) -1) (+ f dy)))
X ((> x xx) (do ((xx lx)
X (x x (1+ x))
X (f f (+ f dy)))
X ((> x xx))
X (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X
X;line-clip incorrectly assumes that subsegment starts prior to midpoint of supersegment.
X;the "divide for nearest integer" (ie divide for remainder of minimum magnitude),
X;which is simulated the //- and \- of num and (ash dx 1), always rounds up on the
X;half integer case, but should round down (for symmetry) if startup is in 2nd half.
X;it would be nice to have these other flavors of divide.
X
X(defun plot0 (x y) (plot x y))
X(defun plot1 (x y) (plot y x))
X(defun plot2 (x y) (plot (- y) x))
X(defun plot3 (x y) (plot (- x) y))
X(defun plot4 (x y) (plot (- x) (- y)))
X(defun plot5 (x y) (plot (- y) (- x)))
X(defun plot6 (x y) (plot y (- x)))
X(defun plot7 (x y) (plot x (- y)))
X
X(declare (special min-x min-y max-x max-y mid-x mid-y beg end))
X
X(COMMENT
X(defun semi-circ (r &optional (y 0) (x r) (f 0))
X; (color:clear)
X (let ((min-x (screen-x1 tv-color-screen))
X (min-y (screen-y1 tv-color-screen))
X (max-x (1- (screen-x2 tv-color-screen)))
X (max-y (1- (screen-y2 tv-color-screen)))
X (mid-x (truncate (screen-width tv-color-screen) 2))
X (mid-y (truncate (screen-height tv-color-screen) 2)))
X (semi-circ-1 r y x f))) )
X
X(defun semi-circ-1 (r y x f)
X (rect-points x y)
X (and (< y (1- x)) (semi-circ-1 r
X (1+ y)
X (cond (( (setq f (+ f y y 1)) x)
X (setq f (- f x x -1))
X (1- x))
X (t x))
X f))
X (and ( x y) ( y 0) (rect-points y x)))
X
X(defun semi-wedge (r)
X; (color:clear)
X (MULTIPLE-VALUE-BIND (MIN-X MIN-Y MAX-X MAX-Y)
X (FUNCALL COLOR:COLOR-SCREEN ':EDGES)
X (SETQ MAX-X (1- MAX-X) MAX-Y (1- MAX-Y))
X (let ((mid-x (truncate (- MAX-X MIN-X) 2))
X (mid-y (truncate (- MAX-Y MIN-Y) 2)))
X (do ((y 0 (1+ y))
X (x r)
X (f 0 (+ f y y 1)))
X ((> y x))
X (and ( f x) (setq x (1- x) f (- f x x -1)))
X (draw-clip-sym-line mid-x mid-y (+ x mid-x) (+ y mid-y) min-x min-y max-x max-y))
X (do ((a (TV:SHEET-SCREEN-ARRAY COLOR:COLOR-SCREEN))
X (x mid-x (1+ x)))
X ((> x max-x))
X (as-2-reverse (1- (ash (ar-2-reverse a x mid-y) 1)) a x mid-y)
X (and ( (+ x (- mid-x) mid-y) max-y)
X (as-2-reverse
X (1- (ash (ar-2-reverse a x (+ x (- mid-x) mid-y)) 1))
X a x (+ x (- mid-x) mid-y)))
X (do ((yy (min max-y (+ x mid-y (- mid-x))))
X (y mid-y (1+ y)))
X ((> y yy))
X (do ((v (ar-2-reverse a x y))
X (x x (+ mid-x mid-y (- y)))
X (y y (+ mid-y x (- mid-x)))
X (i 0 (1+ i)))
X (( i 4))
X (and ( y max-y) (> y min-y)
X (as-2-reverse (as-2-reverse v a (+ mid-x mid-x (- x)) y)
X a x y))))))))
X
X(DEFUN NO-COLOR-DEMO ()
X "Report that we can't do this demo."
X ;;this is better than wedging the machine, or generating an ugly error, or doing nothing
X (TV:NOTIFY NIL "Sorry, apparently you don't have a color screen."))
X
X(defun smoking-clover (&optional (size 5432) (speed 4321))
X "Displays a really neat pattern on the color screen. Slowly at first, then speed up."
X (COND ((COLOR:COLOR-EXISTS-P)
X (WITH-REAL-TIME
X (setq *color-screen-array* (tv:sheet-screen-array color:color-screen))
X (COLOR:write-color-map 0 0 0 0)
X (color:clear)
X (COLOR:random-color-map)
X (semi-wedge size)
X (color-guard speed)))
X (T
X (NO-COLOR-DEMO))))
X
X(defun semi-circ-1 (r y x f)
X (rect-points x y)
X (and (< y (1- x)) (semi-circ-1 r
X (1+ y)
X (cond (( (setq f (+ f y y 1)) x)
X (setq f (- f x x -1))
X (1- x))
X (t x))
X f))
X (and ( x y) ( y 0) (rect-points y x)))
X
X(defun mask-points (x y)
X (draw-sym-fractional-line
X (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) beg end)
X (draw-sym-fractional-line
X (+ mid-x y) (- mid-y x) (- mid-x y) (+ mid-y x) beg end))
X
X(defun rect-points (x y)
X (draw-clip-sym-line
X (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) min-x min-y max-x max-y)
X (draw-clip-sym-line
X (+ mid-x y) (- mid-y x) (- mid-x y) (+ mid-y x) min-x min-y max-x max-y))
X
X(defun mash-points (x y &aux (m1 (cond ((> y x) (1- mid-y))
X ((min mid-x
X (- (truncate (- (* mid-x mid-x (- y x))
X (* mid-y (- (* y mid-x) (* x mid-y))))
X (* x (- mid-y mid-x))) 5)))))
X (z (max x y)))
X (draw-sym-subline
X (- mid-x x) (- mid-y y) (+ mid-x x) (+ mid-y y) (- z m1 -1) (+ z m1))
X (or (= y 0) (draw-sym-subline
X (- mid-x x) (+ mid-y y) (+ mid-x x) (- mid-y y) (- z m1 -1) (+ z m1))))
X
X(defun color-ramp (red green blue)
X (WITH-REAL-TIME
X (do ((r 0 (+ r red))
X (g 0 (+ g green))
X (b 0 (+ b blue))
X (i 0 (1+ i)))
X ((= i 20))
X (COLOR:write-color-map i r g b))))
X
X(defun color-march (&optional (y 0))
X (COND ((COLOR:COLOR-EXISTS-P)
X (WITH-REAL-TIME
X (do ((dr 0 (- (random 42) 20))
X (dg -21 (- (random 42) 20))
X (db 21 (- (random 42) 20)))
X ((funcall terminal-io ':tyi-no-hang))
X (multiple-value-bind (r g b) (COLOR:read-color-map y)
X (do ((r r (+ r dr))
X (g g (+ g dg))
X (b b (+ b db)))
X ((bit-test (logior r g b) 400))
X (do ((i 17 (1- i))
X (r r) (g g) (b b))
X ((< i y))
X (cond ((= (logand i 1) 1)
X (do ((tv-adr (TV:screen-control-address color:color-screen)))
X ((bit-test (%xbus-read tv-adr) 40)))))
X (COLOR:write-color-map-immediate i r g
X (prog1 b
X (multiple-value (r g b)
X (COLOR:read-color-map i))))))))))
X (T
X (NO-COLOR-DEMO))))
X
X(defun color-guard (&optional (snooze 0) (y 0)
X &aux (map-values (make-array '(20 3)
X ':type 'art-8b)))
X (do ((i 0 (1+ i))
X (r) (g) (b))
X (( i 20))
X (multiple-value (r g b) (COLOR:read-color-map i))
X (aset r map-values i 0)
X (aset g map-values i 1)
X (aset b map-values i 2))
X (do ((dr 0 (- (random 42) 20))
X (dg -21 (- (random 42) 20))
X (db 21 (- (random 42) 20)))
X ((funcall terminal-io ':tyi-no-hang) (return-array map-values))
X (do ((r (aref map-values y 0) (+ r dr))
X (g (aref map-values y 1) (+ g dg))
X (b (aref map-values y 2) (+ b db)))
X ((bit-test (logior r g b) 400))
X (do ((i snooze (1- i))) ((< i 0)))
X (do ((i 17 (1- i))
X (or) (og) (ob)
X (r r or)
X (g g og)
X (b b ob))
X ((< i y))
X (setq or (aref map-values i 0) og (aref map-values i 1) ob (aref map-values i 2))
X (aset r map-values i 0)
X (aset g map-values i 1)
X (aset b map-values i 2))
X (COLOR:blt-color-map map-values))))
X
X(defun color-zoom (&optional (z 0) &aux (map-values (make-array '(20 3)
X ':type 'art-8b)))
X (do ((i 0 (1+ i))
X (r) (g) (b))
X (( i 20))
X (multiple-value (r g b) (COLOR:read-color-map i))
X (aset r map-values i 0)
X (aset g map-values i 1)
X (aset b map-values i 2))
X (do ((j 1)
X (dr 0 (- (random 80) 36))
X (dg -21 (- (random 80) 36))
X (db 21 (- (random 80) 36)))
X ((funcall terminal-io ':tyi-no-hang) (return-array map-values))
X (do ((r (aref map-values j 0) (+ r dr))
X (g (aref map-values j 1) (+ g dg))
X (b (aref map-values j 2) (+ b db)))
X ((bit-test (logior r g b) 400))
X (setq j (logand (1- j) 17))
X (do ((i j (logand (1- i) 17))
X (r r) (g g) (b b)
X (rr) (gg) (bb)
X (k 0 (1+ k)))
X ((= k 20))
X (do ((i 0 (1+ i)))((> i z))) ;snooze
X (setq rr (aref map-values i 0)
X gg (aref map-values i 1)
X bb (aref map-values i 2))
X (aset r map-values i 0)
X (aset g map-values i 1)
X (aset b map-values i 2)
X (setq r (ash (+ r (* 37 rr) 25) -5)
X g (ash (+ g (* 37 gg) 25) -5)
X b (ash (+ b (* 37 bb) 25) -5)))
X (COLOR:blt-color-map map-values))))
X
X(defun color-mash ()
X (COND ((COLOR:COLOR-EXISTS-P)
X (WITH-REAL-TIME
X (do ((i 1)
X (dr 0 (- (random 8) 4))
X (dg -21 (- (random 8) 4))
X (db 21 (- (random 8) 4)))
X ((funcall terminal-io ':tyi-no-hang))
X (multiple-value-bind (r g b) (COLOR:read-color-map i)
X (do ((r r (+ r dr))
X (g g (+ g dg))
X (b b (+ b db)))
X ((bit-test (logior r g b) 400))
X ; (and (bit-test i 1)
X ; (do ((tv-adr (screen-control-address tv-color-screen)))
X ; ((bit-test (%xbus-read tv-adr) 40))))
X (COLOR:write-color-map (setq i (logand (1- i) 17))
X r
X g
X b
X t))))))
X (T
X (NO-COLOR-DEMO))))
X
X(COMMENT
X(defun frac-tour (a b &optional (xx (screen-x2 tv-color-screen))
X (yy (screen-y2 tv-color-screen)))
X (do ((pixel-array (screen-buffer-pixel-array tv-color-screen))
X (x (screen-x1 tv-color-screen) (1+ x)))
X (( x xx))
X (do ((y (screen-y1 tv-color-screen) (1+ y)))
X (( y yy))
X (as-2-reverse (fracpart (+ (* a x) (* b y))) pixel-array x y)))) )
X
X;(defun fracpart (a) (fix (ash (- a (fix a)) 4)))
X
X(defun fracpart (a) (- 17 (haulong (fix (ash (- a (fix (+ a .5))) 20)))))
X
X(defun random-ramp ()
X (COND ((COLOR:COLOR-EXISTS-P)
X (WITH-REAL-TIME
X (do ((i 0 (1+ i)))
X ((= i 20))
X (COLOR:write-color-map i (random (+ 17 (ash i 4)))
X (random (+ 17 (ash i 4)))
X (random (+ 17 (ash i 4)))))))
X (T
X (NO-COLOR-DEMO))))
X
X(defun brighten ()
X "Possibly make the color screen more visible."
X (COND ((COLOR:COLOR-EXISTS-P)
X (WITH-REAL-TIME
X (do ((i 17 (- i 3))
X (r 377 (- r 60))
X (g 377 (- g 60))
X (b 377 (- b 60)))
X (( i 2))
X (color:write-color-map i r 0 0)
X (color:write-color-map (1- i) 0 g 0)
X (color:write-color-map (- i 2) 0 0 b))
X (color:write-color-map 0 0 0 0)))
X (T
X (NO-COLOR-DEMO))))
X
X(defdemo "Color TV Hacks" "Various demos that run on the color screen, if you have one."
X "Color"
X ("Smoking Clover" "Gosper's spectacular display hack." (smoking-clover))
X ("Cafe Slide" "Cafe wall illusion. Type space to start it sliding." (cafe-slide))
X ("Color Mash" "Mash up the color map." (color-mash))
X ("Color March" "March colors through the color map." (color-march))
X; ("Color Ramp" "This can't work." (color-ramp))
X ("Random Ramp" "Randomize color map." (random-ramp))
X ("Brighten" "" (brighten)))
END_OF_FILE
if test 13240 -ne `wc -c <'clover.lsp'`; then
echo shar: \"'clover.lsp'\" unpacked with wrong size!
fi
# end of 'clover.lsp'
fi
if test -f 'lex.yy.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'lex.yy.c'\"
else
echo shar: Extracting \"'lex.yy.c'\" \(3755 characters\)
sed "s/^X//" >'lex.yy.c' <<'END_OF_FILE'
X# include "stdio.h"
X# define U(x) x
X# define NLSTATE yyprevious=YYNEWLINE
X# define BEGIN yybgin = yysvec + 1 +
X# define INITIAL 0
X# define YYLERR yysvec
X# define YYSTATE (yyestate-yysvec-1)
X# define YYOPTIM 1
X# define YYLMAX BUFSIZ
X# define output(c) putc(c,yyout)
X# define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10?(yylineno++,yytchar):yytchar)==EOF?0:yytchar)
X# define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;}
X# define yymore() (yymorfg=1)
X# define ECHO fprintf(yyout, "%s",yytext)
X# define REJECT { nstr = yyreject(); goto yyfussy;}
Xint yyleng; extern char yytext[];
Xint yymorfg;
Xextern char *yysptr, yysbuf[];
Xint yytchar;
XFILE *yyin = {stdin}, *yyout = {stdout};
Xextern int yylineno;
Xstruct yysvf {
X struct yywork *yystoff;
X struct yysvf *yyother;
X int *yystops;};
Xstruct yysvf *yyestate;
Xextern struct yysvf yysvec[], *yybgin;
X ;;; -*- Mode: LISP; Package: hacks; base: 8; lowercase: t -*-
X (multiple-value-bind (nil rem) (floor n d) rem))
X `(as-2-reverse (1+ (ar-2-reverse *color-screen-array* ,x1 ,y1))
X *color-screen-array*
X ,x1
X ,y1))
X &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
X (draw-sym-subline x0 y0 xn yn 0 max))
X &aux (max (max (abs (- xn x0)) (abs (- yn y0)))))
X (draw-sym-subline x0 y0 xn yn
X (- (fix (* -1 begfrac max)))
X (fix (* endfrac max))))
X (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot0 x0 y0 dx dy i j))
X ((line-loop #'plot1 y0 x0 dy dx i j))))
X ((cond ((> dx dy) (line-loop #'plot7 x0 (- y0) dx dy i j))
X ((line-loop #'plot6 (- y0) x0 dy dx i j))))))
X ((cond ((> yn y0) (cond ((> dx dy) (line-loop #'plot3 (- x0) y0 dx dy i j))
X ((line-loop #'plot2 y0 (- x0) dy dx i j))))
X ((cond ((> dx dy) (line-loop #'plot4 (- x0) (- y0) dx dy i j))
X ((line-loop #'plot5 (- y0) (- x0) dy dx i j))))))))
X &aux (num (+ dx (* 2 i dy))))
X (do ((j2 (min j (ash dx -1)))
X (y (+ y0 (truncate num (ash dx 1))))
X (i i (1+ i))
X (x (+ x0 i) (1+ x))
X (f (ash (- (\ num (ash dx 1)) dx) -1) (+ f dy)))
X ((> i j2) (do ((i i (1+ i))
X (x x (1+ x))
X (f f (+ f dy)))
X ((> i j))
X (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X &optional (dx (abs (- xn x0))) (dy (abs (- yn y0))))
X (cond ((> xn x0) (cond ((> yn y0) (cond ((> dx dy)
X (line-clip #'plot0 x0 y0 dx dy xe ye xf yf))
X ((line-clip #'plot1 y0 x0 dy dx ye xe yf xf))))
X ((cond ((> dx dy)
X (line-clip #'plot7 x0 (- y0) dx dy xe (- yf) xf (- ye)))
X ((line-clip #'plot6 (- y0) x0 dy dx (- yf) xe (- ye) xf))))))
X ((cond ((> yn y0)
X (cond ((> dx dy)
X (line-clip #'plot3 (- x0) y0 dx dy (- xf) ye (- xe) yf))
X ((line-clip #'plot2 y0 (- x0) dy dx ye (- xf) yf (- xe)))))
X ((cond ((> dx dy)
X (line-clip #'plot4 (- x0) (- y0) dx dy (- xf) (- yf) (- xe) (- ye)))
X ((line-clip #'plot5 (- y0) (- x0) dy dx (- yf) (- xf) (- ye) (- xe)))))))))
X &aux (x (max x0 xe (if (= dy 0) xe (+ x0 (//+ (* dx
X (1- (ash (- ye y0) 1)))
X (ash dy 1))))))
X (num (+ dx (* 2 dy (- x x0))))
X (lx (min xf (if (= dy 0) xf (+ x0 (//+ (* dx (1- (ash (- yf y0) 1)))
X (ash dy 1)))))))
X (do ((xx (min (+ x0 (ash dx -1)) lx))
X (y (+ y0 (//- num (ash dx 1))))
X (x x (1+ x))
X (f (ash (- (\- num (ash dx 1)) dx) -1) (+ f dy)))
X ((> x xx) (do ((xx lx)
X (x x (1+ x))
X (f f (+ f dy)))
X ((> x xx))
X (and (> (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
X (and ( (+ f f) dx) (setq f (- f dx) y (1+ y)))
X (funcall fun x y)))
END_OF_FILE
if test 3755 -ne `wc -c <'lex.yy.c'`; then
echo shar: \"'lex.yy.c'\" unpacked with wrong size!
fi
# end of 'lex.yy.c'
fi
if test -f 'patchlevel.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'patchlevel.h'\"
else
echo shar: Extracting \"'patchlevel.h'\" \(21 characters\)
sed "s/^X//" >'patchlevel.h' <<'END_OF_FILE'
X#define PATCHLEVEL 0
END_OF_FILE
if test 21 -ne `wc -c <'patchlevel.h'`; then
echo shar: \"'patchlevel.h'\" unpacked with wrong size!
fi
# end of 'patchlevel.h'
fi
echo shar: End of archive 1 \(of 1\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have the archive.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Mike Wexler(wyse!mikew) Phone: (408)433-1000 x1330
Moderator of comp.sources.x
More information about the Comp.sources.x
mailing list