steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Imported https://downloads.factorcode.org/releases/0.83/Factor-0.83.zip

release import-0.83
nomennescio 2019-10-18 15:04:58 +02:00
parent 37fbc8f959 375061d350
commit b60e439ccd
637 changed files with 67397 additions and 17847 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
.cvskeywords
View File

@ -1,10 +1,3 @@
./library/windows/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.15 2006/01/28 20:49:31 spestov Exp $ ./vm/bignum.h:$Id: s48_bignum.h,v 1.13 2005/12/21 02:36:52 spestov Exp $
./library/windows/win32-io.factor:! $Id: win32-io.factor,v 1.4 2005/07/23 06:11:07 eiz Exp $ ./vm/bignumint.h:$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
./library/windows/win32-stream.factor:! $Id: win32-stream.factor,v 1.16 2006/01/28 20:49:31 spestov Exp $ ./vm/bignum.c:$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $
./library/windows/win32-errors.factor:! $Id: win32-errors.factor,v 1.11 2005/12/22 02:30:00 erg Exp $
./library/windows/win32-server.factor:! $Id: win32-server.factor,v 1.13 2006/01/28 20:49:31 spestov Exp $
./library/windows/winsock.factor:! $Id: winsock.factor,v 1.8 2005/09/12 15:10:33 erg Exp $
./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.10 2005/09/29 19:26:32 eiz Exp $
./native/s48_bignum.c:$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $
./native/s48_bignumint.h:$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
./native/s48_bignum.h:$Id: s48_bignum.h,v 1.13 2005/12/21 02:36:52 spestov Exp $

54
Factor.app/Contents/Info.plist
View File

@ -12,5 +12,59 @@
<string>Factor</string> <string>Factor</string>
<key>CFBundlePackageType</key> <key>CFBundlePackageType</key>
<string>APPL</string> <string>APPL</string>
<key>CFBundleDocumentTypes</key>
<array>
<dict>
<key>CFBundleTypeExtensions</key>
<array>
<string>*</string>
</array>
<key>CFBundleTypeName</key>
<string>Any</string>
<key>CFBundleTypeRole</key>
<string>Viewer</string>
<key>CFBundleTypeOSTypes</key>
<array>
<string>****</string>
</array>
</dict>
</array>
<key>NSServices</key>
<array>
<dict>
<key>NSMenuItem</key>
<dict>
<key>default</key>
<string>Factor/Evaluate in Listener</string>
</dict>
<key>NSMessage</key>
<string>evalInListener</string>
<key>NSPortName</key>
<string>Factor</string>
<key>NSSendTypes</key>
<array>
<string>NSStringPboardType</string>
</array>
</dict>
<dict>
<key>NSMenuItem</key>
<dict>
<key>default</key>
<string>Factor/Evaluate Selection</string>
</dict>
<key>NSMessage</key>
<string>evalToString</string>
<key>NSPortName</key>
<string>Factor</string>
<key>NSSendTypes</key>
<array>
<string>NSStringPboardType</string>
</array>
<key>NSReturnTypes</key>
<array>
<string>NSStringPboardType</string>
</array>
</dict>
</array>
</dict> </dict>
</plist> </plist>

157
Makefile
View File

@ -3,82 +3,51 @@ CC = gcc
BINARY = f BINARY = f
IMAGE = factor.image IMAGE = factor.image
BUNDLE = Factor.app BUNDLE = Factor.app
DISK_IMAGE_DIR = Factor-0.82 DISK_IMAGE_DIR = Factor-0.83
DISK_IMAGE = Factor-0.82.dmg DISK_IMAGE = Factor-0.83.dmg
ifdef DEBUG ifdef DEBUG
DEFAULT_CFLAGS = -g CFLAGS = -g
STRIP = touch STRIP = touch
else else
DEFAULT_CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS) CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
STRIP = strip STRIP = strip
endif endif
DEFAULT_LIBS = -lm
ifdef NO_UI ifdef NO_UI
UNIX_UI_LIBS = X11_UI_LIBS =
else else
UNIX_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11 X11_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11
endif endif
WINDOWS_OBJS = native/windows/ffi.o \ ifdef CONFIG
native/windows/file.o \ include $(CONFIG)
native/windows/misc.o \
native/windows/run.o \
native/windows/memory.o
UNIX_OBJS = native/unix/file.o \
native/unix/signal.o \
native/unix/ffi.o \
native/unix/memory.o \
native/unix/icache.o
MACOSX_OBJS = $(UNIX_OBJS) \
native/macosx/run.o \
native/macosx/mach_signal.o
GENERIC_UNIX_OBJS = $(UNIX_OBJS) \
native/unix/run.o
ifdef WINDOWS
PLAF_OBJS = $(WINDOWS_OBJS)
PLAF_SUFFIX = .exe
else
ifdef MACOSX
PLAF_OBJS = $(MACOSX_OBJS)
else
PLAF_OBJS = $(GENERIC_UNIX_OBJS)
endif
endif endif
OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \ OBJS = $(PLAF_OBJS) \
native/s48_bignum.o \ vm/alien.o \
native/complex.o native/cons.o native/error.o \ vm/bignum.o \
native/factor.o native/fixnum.o \ vm/debug.o \
native/float.o native/gc.o \ vm/factor.o \
native/image.o native/memory.o \ vm/ffi_test.o \
native/misc.o native/primitives.o \ vm/image.o \
native/ratio.o native/relocate.o \ vm/io.o \
native/run.o \ vm/math.o \
native/sbuf.o native/stack.o \ vm/memory.o \
native/string.o native/cards.o native/vector.o \ vm/primitives.o \
native/word.o native/compiler.o \ vm/run.o \
native/alien.o native/dll.o \ vm/stack.o \
native/boolean.o \ vm/types.o
native/debug.o \
native/hashtable.o \
native/io.o \
native/wrapper.o \
native/ffi_test.o
default: default:
@echo "Run 'make' with one of the following parameters:" @echo "Run 'make' with one of the following parameters:"
@echo "" @echo ""
@echo "bsd" @echo "freebsd"
@echo "linux" @echo "linux-x86"
@echo "linux-amd64"
@echo "linux-ppc" @echo "linux-ppc"
@echo "macosx" @echo "macosx-x86"
@echo "macosx-ppc"
@echo "solaris" @echo "solaris"
@echo "windows" @echo "windows"
@echo "" @echo ""
@ -91,30 +60,46 @@ default:
@echo "" @echo ""
@echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\"" @echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\""
bsd: freebsd:
$(MAKE) $(BINARY) \ $(MAKE) $(BINARY) CONFIG=vm/Config.freebsd
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -pthread" \
LIBS="$(DEFAULT_LIBS) $(UI_LIBS)" macosx-freetype:
ln -sf libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.dylib
macosx-ppc: macosx-freetype
$(MAKE) $(BINARY) CONFIG=vm/Config.macosx.ppc
macosx-x86: macosx-freetype
$(MAKE) $(BINARY) CONFIG=vm/Config.macosx
linux-x86 linux-amd64:
$(MAKE) $(BINARY) CONFIG=vm/Config.linux
$(STRIP) $(BINARY) $(STRIP) $(BINARY)
macosx: linux-ppc:
$(MAKE) $(BINARY) \ $(MAKE) $(BINARY) CONFIG=vm/Config.linux.ppc
CFLAGS="$(DEFAULT_CFLAGS)" \ $(STRIP) $(BINARY)
LIBS="$(DEFAULT_LIBS) -framework Cocoa -framework OpenGL -lfreetype" \
MACOSX=y solaris solaris-x86 solaris-amd64:
$(MAKE) $(BINARY) CONFIG=vm/Config.solaris
$(STRIP) $(BINARY)
windows:
$(MAKE) $(BINARY) CONFIG=vm/Config.windows
macosx.app: macosx.app:
cp $(BINARY) $(BUNDLE)/Contents/MacOS/Factor cp $(BINARY) $(BUNDLE)/Contents/MacOS/Factor
rm -rf $(BUNDLE)/Contents/Resources/ rm -rf $(BUNDLE)/Contents/Resources/
mkdir -p $(BUNDLE)/Contents/Resources/fonts/ mkdir -p $(BUNDLE)/Contents/Resources/fonts/
cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
chmod +x cp_dir chmod +x cp_dir
find doc library contrib examples \( -name '*.factor' \ find doc library contrib examples fonts \( -name '*.factor' \
-o -name '*.facts' \ -o -name '*.facts' \
-o -name '*.txt' \ -o -name '*.txt' \
-o -name '*.html' \ -o -name '*.html' \
-o -name '*.ttf' \
-o -name '*.js' \) \ -o -name '*.js' \) \
-exec ./cp_dir {} $(BUNDLE)/Contents/Resources/{} \; -exec ./cp_dir {} $(BUNDLE)/Contents/Resources/{} \;
@ -131,41 +116,20 @@ macosx.app:
Factor.app/Contents/MacOS/Factor Factor.app/Contents/MacOS/Factor
macosx.dmg: macosx.dmg:
rm -f $(DISK_IMAGE) rm $(DISK_IMAGE)
rm -rf $(DISK_IMAGE_DIR) rm -rf $(DISK_IMAGE_DIR)
mkdir $(DISK_IMAGE_DIR) mkdir $(DISK_IMAGE_DIR)
cp -R $(BUNDLE) $(DISK_IMAGE_DIR)/$(BUNDLE) cp -R $(BUNDLE) $(DISK_IMAGE_DIR)/$(BUNDLE)
hdiutil create -srcfolder "$(DISK_IMAGE_DIR)" -fs HFS+ \ hdiutil create -srcfolder "$(DISK_IMAGE_DIR)" -fs HFS+ \
-volname "$(DISK_IMAGE_DIR)" "$(DISK_IMAGE)" -volname "$(DISK_IMAGE_DIR)" "$(DISK_IMAGE)"
linux linux-x86 linux-amd64:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
linux-ppc:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
solaris solaris-x86:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -D_STDC_C99 -Drestrict=\"\" " \
LIBS="-ldl -lsocket -lnsl $(DEFAULT_LIBS) -R/opt/PM/lib -R/opt/csw/lib -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib -R/opt/sfw/lib $(UNIX_UI_LIBS)"
$(STRIP) $(BINARY)
windows:
$(MAKE) $(BINARY) \
CFLAGS="$(DEFAULT_CFLAGS) -DWINDOWS" \
LIBS="$(DEFAULT_LIBS)" WINDOWS=y
f: $(OBJS) f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS)
clean: clean:
rm -f $(OBJS) rm -f $(OBJS) $(UNIX_OBJS) $(WINDOWS_OBJS) $(MACOSX_OBJS)
rm -rf $(BUNDLE)/Contents/Resources/
rm -f $(BUNDLE)/Contents/MacOS/Factor
.c.o: .c.o:
$(CC) -c $(CFLAGS) -o $@ $< $(CC) -c $(CFLAGS) -o $@ $<
@ -175,8 +139,3 @@ clean:
.m.o: .m.o:
$(CC) -c $(CFLAGS) -o $@ $< $(CC) -c $(CFLAGS) -o $@ $<
boot:
echo "USE: image \"$(ARCH)\" make-image bye" | ./f factor.image
./f boot.image.$(ARCH) $(BOOTSTRAP_FLAGS)

53
README.txt
View File

@ -13,7 +13,6 @@ implementation. It is not an introduction to the language itself.
- Running Factor on Mac OS X - Running Factor on Mac OS X
- Running Factor on Windows - Running Factor on Windows
- Source organization - Source organization
- Learning Factor
- Community - Community
- Credits - Credits
@ -23,19 +22,21 @@ Factor is fully supported on the following platforms:
Linux/x86 Linux/x86
Linux/AMD64 Linux/AMD64
Mac OS X/x86
Mac OS X/PowerPC Mac OS X/PowerPC
Solaris/x86 MS Windows XP
Microsoft Windows 2000 or later
The following platforms should work, but are not tested on a The following platforms should work, but are not tested on a
regular basis: regular basis:
FreeBSD/x86 FreeBSD/x86
FreeBSD/AMD64 FreeBSD/AMD64
Linux/PowerPC Solaris/x86
Solaris/AMD64 Solaris/AMD64
Linux/PowerPC
Other platforms are not supported. Please donate time or hardware if you wish to see Factor running on
other platforms.
* Compiling Factor * Compiling Factor
@ -47,12 +48,13 @@ Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
Run 'make' (or 'gmake' on non-Linux platforms) with one of the following Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
parameters to build the Factor runtime: parameters to build the Factor runtime:
bsd freebsd
linux linux-x86
linux-amd64
linux-ppc linux-ppc
macosx macosx-x86
macosx-ppc
solaris solaris
windows
The following options can be given to make: The following options can be given to make:
@ -76,9 +78,10 @@ Compilation will yield an executable named 'f'.
* Building Factor * Building Factor
The Factor source distribution ships with three boot image files: The Factor source distribution ships with four boot image files:
boot.image.x86 boot.image.x86
boot.image.pentium4 -- uses SSE2, only for Pentium 4 and later
boot.image.ppc boot.image.ppc
boot.image.amd64 boot.image.amd64
@ -89,9 +92,6 @@ The system is bootstrapped with the following command line:
./f boot.image.<foo> ./f boot.image.<foo>
Additional options may be specified to load external C libraries; see
the next section for details.
Bootstrap can take a while, depending on your system. When the process Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between is both CPU and OS-specific, so in general cannot be shared between
@ -141,29 +141,22 @@ between PowerPC Macs.
* Running Factor on Windows * Running Factor on Windows
On Windows, double-clicking f.exe will start running the Win32-based UI If you did not download the binary package, you can bootstrap Factor in
with the factor.image in the same directory as the executable. the command prompt:
Bootstrap runs in a Windows command prompt, however after bootstrapping f.exe boot.image.pentium4 (or boot.image.x86)
only the UI can be used.
Once bootstrapped, double-clicking f.exe starts the Factor UI. There is
no option to run the listener in the command prompt on Windows.
* Source organization * Source organization
doc/ - the developer's handbook, and various other bits and pieces doc/ - the developer's handbook, and various other bits and pieces
native/ - sources for the Factor runtime, written in C
library/ - sources for the library, written in Factor
contrib/ - various handy libraries not part of the core contrib/ - various handy libraries not part of the core
examples/ - small examples illustrating various language features examples/ - small examples illustrating various language features
fonts/ - TrueType fonts used by UI fonts/ - TrueType fonts used by UI
library/ - sources for the library, written in Factor
* Learning Factor vm/ - sources for the Factor runtime, written in C
The UI has a tutorial and defailed reference documentation. You can
browse it in the UI or by running the HTTP server (contrib/httpd).
You can browse the source code; it is organized into small,
well-commented files and should be easy to follow once you have a good
grasp of the language.
* Community * Community
@ -179,7 +172,9 @@ The following people have contributed code to the Factor core:
Slava Pestov: Lead developer Slava Pestov: Lead developer
Alex Chapman: OpenGL binding Alex Chapman: OpenGL binding
Doug Coleman: Mersenne Twister random number generator Doug Coleman: Mersenne Twister RNG, Windows port
Eduardo Cavazos: X11 binding
Joshua Grams: PowerPC instruction cache flush code
Mackenzie Straight: Windows port Mackenzie Straight: Windows port
Trent Buck: Debian package Trent Buck: Debian package

171
TODO.FACTOR.txt
View File

@ -1,78 +1,129 @@
should fix in 0.82:
- another i/o bug: on factorcode eventually all i/o times out
- get factor running on mac intel
+ io: + io:
- unix i/o: problems with passing f to syscalls
- factorcode httpd started using 99% CPU, but still received connections;
closing read-fds solved it
- sometimes darcs get fails with the httpd
- gdb triggers 'mutliple i/o ops on port' error - gdb triggers 'mutliple i/o ops on port' error
- stream server can hang because of exception handler limitations
- better i/o scheduler
- yield in a loop starves i/o
- "localhost" 50 <client> won't fail - "localhost" 50 <client> won't fail
+ ui/help: + ui:
- clicks sent twice - "benchmark/help" runs out of memory
- speed up ideas: - shortcuts:
- only do clipping for certain gadgets - find a listener
- use glRect - find a browser
- polish OS X menu bar code - find a help window
- help search - they'll either focus such a window, or if the current window is of
- reimplement clicking input that type, cycle
- reimplement tab completion - thumb min size
- x11 input methods - support x11's large selections, if needed
- own-selection violates ICCCM
- one-column table doesn't need borders...?
- make-frame should compile
- editor:
- undo and redo
- transpose char/word/line
- autoscroll
- page up/down
- search and replace
- only redraw visible lines
- more efficient multi-line inserts
- editor should support stream output protocol
- scroll to caret
- better listener multi-line expression handling
- history doesn't work in a good way if you ^K the input
- history: move caret to end
- finish gui stepper
- cocoa: windows are not updated while resizing
- graphical module manager tool
- add some handy services:
- base conversion
- search help for selection
- make factor a services client
- services do not launch if factor not running
- grid slows down with 2000 lines
- integrated error documentation
- roundoff is still not quite right with tracks
- 'show' doesn't work if invoked from a listener on an object which is
itself inspected in the listener
- ui uses too much cpu time idling
- see if its possible to only repaint dirty regions
- x11 title bars are funny - x11 title bars are funny
- cocoa:
- don't multiplex in the event loop if there is no pending i/o
- horizontal scrolling
- fix mouse-overs...
- display lists
- saving the image should save window configuration
- make the UI look better, something like this:
http://twb.ath.cx/~twb/darcs/OBSOLETE/factor/final.html
- fix remaining HTML stream issues
- fix up the min thumb size hack
- automatically update help graph when adding/removing articles/words
- document conventions
- new turtle graphics tutorial
- better line spacing in ui and html
- tabular formatting - for inspector, changes and $values in help
- grid layout
- variable width word wrap
- fix top level window positioning - fix top level window positioning
- changing window titles - prettyprinter's highlighting of non-leaves doesn't really work
- rollover is not updated on window focus changes
- x11 input methods
- cocoa:
- horizontal wheel scrolling
- polish OS X menu bar code
- variable width word wrap
- slider needs to be modelized
+ module system:
- 'see' should show tuple constructors
- forgetting a class should remove its methods from all generic words
- offer to remove generic words which are not called and have no
methods
- forgetting a tuple class should forget the constructor
- seeing a tuple class should show the constructor
- C types should be words
- TYPEDEF: float { ... } { ... } ; ==> \ float T{ c-type ... } "c-type" swp
- TYPEDEF: float FTFloat ; ==> \ float \ FTFloat "c-type" swp
- make typedef aliasing explicit
- seeing a C struct word should show its def
- see by itself only shows the G: def
- { class generic } see supports forms:
{ f generic } to show all methods
{ class f } to show all methods
- modularize core
- TUPLE: module files tests articles article main ;
- methods: remember their file/line
- { class generic } jedit, reload DTRT
- requesting a list of assets loaded from a specific file
- T{ link f "foo" "bar" } see
- T{ link f "foo" "bar" } jedit
- T{ link f "foo" "bar" } reload
- generic 'define ( asset def -- )'
- file out
- make 'forget' generic
+ compiler/ffi: + compiler/ffi:
- free up r11, r12 as a vreg on ppc - nasty inference regressions
- float= on powerpc doesn't consider nans equal
- intrinsic fixnum>float float>fixnum
- win64 port
- amd64 %unbox-struct
- constant branch folding
- core foundation should use unicode strings
- alien>utf16-string, utf16-string>alien words
- can <void*> only be called with an alien?
- remove <char*>, <ushort*>, set-char*-nth, set-ushort*-nth since they
have incorrect semantics
- complex float type
- complex float intrinsics
- remove literal table
- C functions returning structs by value
- FIELD: char key_vector[32];
- FIELD: union { char b[20]; short s[10]; long l[5]; } data;
- MEMBER: long pad[24];
- C structs: use new-style string mode parsing
- [ [ dup call ] dup call ] infer hangs - [ [ dup call ] dup call ] infer hangs
- the invalid recursion form case needs to be fixed, for inlines too - the invalid recursion form case needs to be fixed, for inlines too
- code gc - instead of decompiling words, add them to a 'recompile' set; compiler
treats words in the recompile set as if they were not compiled
- mac intel: struct returns from objc methods
- see if alien calls can be made faster
- faster sequence= for UI
- fix compiled gc check - fix compiled gc check
- there was a performance hit, investigate
- float boxing and overflow checks need a gc check too
- constant branch folding
- type inference at branch merge points
- float= doesn't consider nans equal
- intrinsic fixnum>float float>fixnum
- remove literal table
- C functions returning structs by value
- code gc
- infer which variables are read, written in a quotation
+ misc: + misc:
- 3 >n fep - consider: swap tail --> tail, swap head --> head
- code walker & exceptions - mach_signal: fault address reporting is not reliable
- slice: if sequence or seq start is changed, abstraction violation - slice: if sequence or seq start is changed, abstraction violation
- make 3.4 bits>double an error - hashed generic method dispatch
- code walker and callbacks is broken? - fix this:
[ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113 ] .
[ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113
]
- code walker & exceptions -- test and debug problems
- break: perhaps use current stdio to run break listener
- httpd search tools
- remaining HTML issues need fixing

BIN
boot.image.amd64
View File

Binary file not shown.

BIN
boot.image.pentium4
View File

Binary file not shown.

BIN
boot.image.ppc
View File

Binary file not shown.

BIN
boot.image.x86
View File

Binary file not shown.

63
contrib/README.txt
View File

@ -1,43 +1,32 @@
This directory contains Factor code that is not part of the core This directory contains Factor code that is not part of the core
library, but is useful enough to ship with the Factor distribution. library, but is useful enough to ship with the Factor distribution.
- contrib/aim/ -- AOL Instant Messenger client library (Doug Coleman) Modules can be loaded from the listener:
- contrib/algebra/ -- infix math syntax (Daniel Ehrenberg) "modulename" require
- contrib/cairo/ -- cairo bindings (Sampo Vuori) Credits:
- contrib/concurrency/ -- Erlang/Termite-style concurrency (Chris Double) - automata -- Graphics demo for the UI (Eduardo Cavazos)
- boids -- Graphics demo for the UI (Eduardo Cavazos)
- contrib/cont-responder/ -- additional examples and tools for the - cairo -- cairo bindings (Sampo Vuori)
continuation-based web framework (Chris Double) - calendar -- timestamp/calendar with timezones (Doug Coleman)
- concurrency -- Erlang/Termite-style concurrency (Chris Double)
- contrib/crypto/ -- MD5 and SHA1 cryptographic hashes (Doug Coleman) - coroutines -- coroutines (Chris Double)
- crypto -- Various cryptographic algorithms (Doug Coleman)
- contrib/factory/ -- X11 window manager (Eduardo Cavazos) - dlists -- double-linked-lists (Mackenzie Straight)
- factory -- X11 window manager (Eduardo Cavazos)
- contrib/httpd/ -- HTTP server and client (Slava Pestov, Chris Double) - gap-buffer -- Efficient text editor buffer (Alex Chapman)
- hexdump -- Hexdump routine (Doug Coleman)
- contrib/math/ -- extended math library (Doug Coleman) - httpd -- Web framework (HTTP server, client, XML parser, HTML generation...) (Slava Pestov, Chris Double, Daniel Ehrenberg)
- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis)
- contrib/parser-combinators/ -- Lazy lists and Haskell-style parser - math -- extended math library (Doug Coleman, Slava Pestov)
combinators (Chris Double) - parser-combinators -- Haskell-style parser combinators (Chris Double)
- postgresql -- PostgreSQL binding (Doug Coleman)
- contrib/postgresql/ -- PostgreSQL binding (Doug Coleman) - process -- Run external programs (Slava Pestov)
- random-tester -- Random compiler tester (Doug Coleman)
- contrib/random-tester/ -- Random compiler tester (Doug Coleman) - slate -- Graphics canvas for the UI (Eduardo Cavazos)
- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double)
- contrib/space-invaders/ -- Intel 8080-based Space Invaders arcade - splay-trees -- Splay trees (Mackenzie Straight)
machine emulator (Chris Double) - sqlite -- SQLite binding (Chris Double)
- x11 -- X Window System client library (Eduardo Cavazos)
- contrib/sqlite/ -- SQLite binding (Chris Double)
- contrib/x11 -- X Window System client library (Eduardo Cavazos)
- contrib/coroutines.factor -- coroutines (Chris Double)
- contrib/dlists.factor -- double-linked-lists (Mackenzie Straight)
- contrib/splay-trees.factor -- Splay trees (Mackenzie Straight)
- contrib/xml.factor -- XML parser and writer (Daniel Ehrenberg)

1082
contrib/aim/aim.factor
View File

File diff suppressed because it is too large Load Diff

9
contrib/aim/load.factor
View File

@ -1,9 +0,0 @@
IN: scratchpad
USING: kernel parser sequences words compiler ;
"/contrib/crypto/load.factor" run-resource
{
"net-bytes"
"aim"
} [ "/contrib/aim/" swap ".factor" append3 run-resource ] each

189
contrib/aim/net-bytes.factor
View File

@ -1,189 +0,0 @@
IN: aim-internals
USING: kernel sequences lists prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto arrays ;
SYMBOL: big-endian t big-endian set
SYMBOL: unscoped-stream
SYMBOL: unscoped-stack
! Examples:
! 1 2 3 4 4 >nvector .
! { 1 2 3 4 }
! { 1 2 3 4 } { >byte >short >int >long } papply .
! "\u0001\0\u0002\0\0\0\u0003\0\0\0\0\0\0\0\u0004"
! [ 1 >short 6 >long ] make-packet .
! "\0\u0001\0\0\0\0\0\0\0\u0006"
: int>ip ( n -- str )
[ HEX: ff000000 over bitand -24 shift unparse % CHAR: . ,
HEX: 00ff0000 over bitand -16 shift unparse % CHAR: . ,
HEX: 0000ff00 over bitand -8 shift unparse % CHAR: . ,
HEX: 000000ff bitand unparse % ] "" make ;
! doesn't compile
! : >nvector ( elems n -- )
! { } clone swap [ drop swap add ] each reverse ;
: 4vector ( elems -- )
V{ } clone 4 [ drop swap add ] each reverse ;
! TODO: make this work for types other than ""
: papply ( seq seq -- seq )
[ [ 2array >list call % ] 2each ] "" make ;
: writeln ( string -- )
write terpri ;
! NEEDS REFACTORING, GOSH!
! Hexdump
: (print-offset) ( lineno -- )
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
: (print-hex-digit) ( digit -- )
>hex 2 CHAR: 0 pad-left write ;
: (print-hex-line) ( lineno string -- )
over (print-offset)
dup length dup 16 =
[ [ 2dup swap nth (print-hex-digit) " " write ] repeat ] ! full line
[ ! partial line
[ 2dup swap nth (print-hex-digit) " " write ] repeat
dup length 16 swap - [ " " write ] repeat
] if
dup length
[ 2dup swap nth dup printable? [ write1 ] [ "." write drop ] if ] repeat
terpri drop ;
: (num-full-lines) ( bytes -- )
length 16 / floor ;
: (get-slice) ( lineno bytes -- <slice> )
>r dup 16 * dup 16 + r> <slice> ;
: (get-last-slice) ( bytes -- <slice> )
dup length dup 16 mod - over length rot <slice> ;
: (print-bytes) ( bytes -- )
dup (num-full-lines) [ over (get-slice) (print-hex-line) ] repeat
dup (num-full-lines) over (get-last-slice) dup empty? [ 3drop ] [ (print-hex-line) 2drop ] if ;
: (print-length) ( len -- )
[
"Length: " %
dup unparse %
", " %
>hex %
"h\n" %
] "" make write ;
: hexdump ( str -- )
dup length (print-length) (print-bytes) ;
: save-current-scope
unscoped-stack get [ V{ } clone unscoped-stack set ] unless
swap dup unscoped-stream set unscoped-stack get push ;
: set-previous-scope
unscoped-stack get dup length 1 > [
[ pop ] keep nip peek unscoped-stream set ] [
pop drop
] if ;
: with-unscoped-stream ( stream quot -- )
save-current-scope catch set-previous-scope
[ dup [ unscoped-stream get stream-close ] when rethrow ] when ;
: close-unscoped-stream ( -- )
unscoped-stream get stream-close ;
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ;
: endian> ( obj n -- str )
big-endian get [ be> ] [ le> ] if ;
: (>byte) ( byte -- str )
unit >string ;
: (>short) ( short -- str )
2 >endian ;
: (>int) ( int -- str )
4 >endian ;
: (>longlong) ( longlong -- str )
8 >endian ;
: (>u128) ( u128 -- str )
16 >endian ;
: (>cstring) ( str -- str )
"\0" append ;
: >byte ( byte -- )
(>byte) % ;
: >short ( short -- )
(>short) % ;
: >int ( int -- )
(>int) % ;
: >longlong ( longlong -- )
(>longlong) % ;
: >u128 ( u128 -- )
(>u128) % ;
: >cstring ( str -- )
(>cstring) % ;
! doesn't compile
! : make-packet ( quot -- )
! depth >r call depth r> - [ drop append ] each ;
: make-packet
"" make ;
: (head-short) ( str -- short )
2 swap head endian> ;
: (head-int) ( str -- int )
4 swap head endian> ;
: (head-longlong) ( str -- longlong )
8 swap head endian> ;
: (head-u128) ( str -- u128 )
16 swap head endian> ;
! 8 bits
: head-byte ( -- byte )
1 unscoped-stream get stream-read first ;
! 16 bits
: head-short ( -- short )
2 unscoped-stream get stream-read (head-short) ;
! 32 bits
: head-int ( -- int )
4 unscoped-stream get stream-read (head-int) ;
! 64 bits
: head-longlong ( -- longlong )
8 unscoped-stream get stream-read (head-longlong) ;
! 128 bits
: head-u128 ( -- u128 )
16 unscoped-stream get stream-read (head-u128) ;
: head-string ( n -- str )
unscoped-stream get stream-read >string ;
! : head-cstring ( -- str )
! head-byte ]
: head-contents ( -- str )
unscoped-stream get contents ;

10
contrib/all.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel modules words ;
REQUIRES: automata boids cairo calendar concurrency coroutines
crypto dlists embedded gap-buffer hexdump httpd math postgresql process
random-tester slate splay-trees sqlite topology units vars ;
"x11" vocab [
"factory" require
"x11" require
] when

188
contrib/automata.factor Normal file
View File

@ -0,0 +1,188 @@
! Copyright (C) 2006 Eduardo Cavazos.
! To run:
! USE: automata
! automata-window
REQUIRES: math slate vars ;
USING: parser kernel hashtables namespaces sequences math io
math-contrib threads strings arrays prettyprint
gadgets gadgets-editors gadgets-frames gadgets-buttons gadgets-grids
vars slate ;
IN: automata
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! set-rule
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: char>digit ( c -- i ) 48 - ;
: string>digits ( s -- seq ) >array [ char>digit ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: rule SYMBOL: rule-number
: init-rule ( -- ) 8 <hashtable> rule set ;
: rule-keys ( -- { ... } )
{ { 1 1 1 }
{ 1 1 0 }
{ 1 0 1 }
{ 1 0 0 }
{ 0 1 1 }
{ 0 1 0 }
{ 0 0 1 }
{ 0 0 0 } } ;
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
: set-rule ( n -- )
dup rule-number set
rule-values rule-keys [ rule get set-hash ] 2each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! step-capped-line
! step-wrapped-line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: map3-i ( seq -- i ) length 2 - ;
: map3-quot ( quot -- quot ) [ swap 3nth ] swap append ;
: map3 ( seq quot -- seq ) over map3-i swap map3-quot map-with ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: last ( seq -- elt ) dup length 1- swap nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pattern>state ( { a b c } -- state ) rule get hash ;
: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
dup last 1array swap dup first 1array append append ;
: step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
: step-capped-line ( line -- new-line ) cap-line step-line ;
: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Display the rule
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: random-line ( -- line ) window-width [ drop 2 random-int ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: center-i ( -- i ) window-width dup 2 / >fixnum ;
: center-line ( -- line ) center-i window-width [ = [ 1 ] [ 0 ] if ] map-with ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! show-line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: show-point ( { x y } p -- ) 1 = [ draw-point ] [ drop ] if ;
: (show-line) ( { x y } line -- ) [ dupd show-point { 1 0 } v+ ] each drop ;
: show-line ( y line -- ) 0 rot 2array swap (show-line) yield ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! run-rule
! start-random
! start-center
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: last-line
: estimate-capacity ( -- ) window-width window-height * 2 * capacity set ;
: check-capacity ( -- )
"capacity: " write capacity get number>string write terpri
"dlist length: " write dlist get length number>string write terpri ;
: start-slate ( -- )
estimate-capacity reset-slate
white set-clear-color black set-color clear-window ;
: finish-slate ( -- ) check-capacity flush-dlist flush-slate ;
: run-line ( line y -- line ) swap tuck show-line step-capped-line ;
: run-lines ( -- ) last-line> window-height [ run-line ] each >last-line ;
: run-rule ( -- ) start-slate run-lines finish-slate ;
: start-random ( -- ) random-line >last-line run-rule ;
: start-center ( -- ) center-line >last-line run-rule ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: random-item ( seq -- item ) dup length random-int swap nth ;
: interesting ( -- seq )
{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
: mild ( -- seq )
{ 6 9 11 57 62 74 118 } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : automata ( -- )
! <slate> dup self set "Cellular Automata" open-titled-window
! init-rule interesting random-item set-rule 1000 sleep start-random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! automata-window
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bind-button ( ns button -- )
tuck button-quot \ bind 3array >quotation swap set-button-quot ;
VARS: ns editor frame ;
: init-slate ( -- ) <slate> t over set-gadget-clipped? self set ;
: init-editor ( -- ) "" <editor> >editor ;
: set-editor-rule ( n -- ) number>string editor> set-editor-text ;
: open-rule ( -- ) editor> editor-text string>number set-rule start-center ;
: automata-window ( -- )
<frame> >frame
[ ] make-hash >ns
ns> [ init-rule init-slate init-editor ] bind
ns> [ editor> ] bind 1array
ns>
{ { "Open" [ open-rule ] }
{ "Center" [ start-center ] }
{ "Random" [ start-random ] }
{ "Continue" [ run-rule ] } }
[ first2 <bevel-button> tuck bind-button ]
map-with append make-pile 1 over set-pack-fill
frame> @left grid-add
ns> [ self get ] bind
frame> @center grid-add
frame> "Cellular Automata" open-titled-window
1000 sleep
ns> [ interesting random-item set-editor-rule open-rule ] bind ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
PROVIDE: automata ;

423
contrib/boids.factor Normal file
View File

@ -0,0 +1,423 @@
! Eduardo Cavazos - wayo.cavazos@gmail.com
! To run the demo do:
! USE: boids
! boids-window
!
! There are currently a few bugs. To work around them and to get better
! results, increase the size of the window (larger than 400x400 is
! good). Then press the "Reset" button to start the demo over.
REQUIRES: math slate vars ;
USING: generic threads namespaces math kernel sequences arrays gadgets
math-contrib slate vars ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: separation-radius
SYMBOL: alignment-radius
SYMBOL: cohesion-radius
SYMBOL: separation-view-angle
SYMBOL: alignment-view-angle
SYMBOL: cohesion-view-angle
SYMBOL: separation-weight
SYMBOL: alignment-weight
SYMBOL: cohesion-weight
: init-variables ( -- )
25 separation-radius set
50 alignment-radius set
75 cohesion-radius set
180 separation-view-angle set
180 alignment-view-angle set
180 cohesion-view-angle set
1.0 separation-weight set
1.0 alignment-weight set
1.0 cohesion-weight set ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: world-size
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: boid pos vel ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: time-slice
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! random-boid and random-boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: random-range ( a b -- n ) 1 + dupd swap - random-int + ;
: random-pos ( -- pos ) world-size get [ random-int ] map ;
: random-vel ( -- vel ) 2 >array [ drop -10 10 random-range ] map ;
: random-boid ( -- boid ) random-pos random-vel <boid> ;
: random-boids ( n -- boids ) [ drop random-boid ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! draw-boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boid-point-a ( boid -- a ) boid-pos ;
: boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize 20 v*n v+ ;
: boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
: draw-boid ( boid -- ) boid-points draw-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: distance ( boid boid -- n ) boid-pos swap boid-pos v- norm ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
: relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: vsum ( vector-of-vectors --- vec ) { 0 0 } [ v+ ] reduce ;
: vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: subset-with ( obj seq quot -- seq ) [ dupd ] swap append subset ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: within-radius? ( self other radius -- ? ) >r distance r> <= ;
: within-view-angle? ( self other view-angle -- ? )
>r relative-angle r> 2 / <= ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: within-separation-radius? ( self other -- ? )
separation-radius get within-radius? ;
: within-separation-view? ( self other -- ? )
separation-view-angle get within-view-angle? ;
: within-separation-neighborhood? ( self other -- ? )
[ eq? not ] 2keep
[ within-separation-radius? ] 2keep
within-separation-view?
and and ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: within-alignment-radius? ( self other -- ? )
alignment-radius get within-radius? ;
: within-alignment-view? ( self other -- ? )
alignment-view-angle get within-view-angle? ;
: within-alignment-neighborhood? ( self other -- ? )
[ eq? not ] 2keep
[ within-alignment-radius? ] 2keep
within-alignment-view?
and and ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: within-cohesion-radius? ( self other -- ? )
cohesion-radius get within-radius? ;
: within-cohesion-view? ( self other -- ? )
cohesion-view-angle get within-view-angle? ;
: within-cohesion-neighborhood? ( self other -- ? )
[ eq? not ] 2keep
[ within-cohesion-radius? ] 2keep
within-cohesion-view?
and and ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: separation-force ( self -- force )
! boids get [ within-separation-neighborhood? ] subset-with
boids get [ >r dup r> within-separation-neighborhood? ] subset
dup length 0 =
[ drop drop { 0 0 } ]
[ average-position
>r boid-pos r> v-
normalize
separation-weight get
v*n ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: alignment-force ( self -- force )
! boids get [ within-alignment-neighborhood? ] subset-with
boids get [ >r dup r> within-alignment-neighborhood? ] subset swap drop
dup length 0 =
[ drop { 0 0 } ]
[ average-velocity
normalize
alignment-weight get
v*n ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cohesion-force ( self -- force )
! boids get [ within-cohesion-neighborhood? ] subset-with
boids get [ >r dup r> within-cohesion-neighborhood? ] subset
dup length 0 =
[ drop drop { 0 0 } ]
[ average-position
swap ! avg-pos self
boid-pos v-
normalize
cohesion-weight get
v*n ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! F = m a
!
! We let m be equal to 1 so then this is simply: F = a
: acceleration ( boid -- acceleration )
dup dup
separation-force rot
alignment-force rot
cohesion-force v+ v+ ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! iterate-boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: world-width ( -- w ) world-size get first ;
: world-height ( -- w ) world-size get second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: below? ( n a b -- ? ) drop < ;
: above? ( n a b -- ? ) nip > ;
: wrap ( n a b -- n )
{ { [ 3dup below? ]
[ 2nip ] }
{ [ 3dup above? ]
[ drop nip ] }
{ [ t ]
[ 2drop ] } }
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: wrap-x ( x -- x ) 0 world-width 1- wrap ;
: wrap-y ( y -- y ) 0 world-height 1- wrap ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : new-pos ( boid -- pos )
! dup >r boid-pos r> boid-vel time-slice get v*n v+ ;
! : new-vel ( boid -- vel )
! dup >r boid-vel r> acceleration time-slice get v*n v+ ;
! : new-vel ( boid -- vel )
! dup boid-vel swap acceleration time-slice get v*n v+ ;
! : wrap-x ( x -- x )
! dup 0 world-size get nth >= [ drop 0 ] when
! dup 0 < [ drop 0 world-size get nth 1 - ] when ;
! : wrap-y ( y -- y )
! dup 1 world-size get nth >= [ drop 0 ] when
! dup 0 < [ drop 1 world-size get nth 1 - ] when ;
: new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
! : new-vel ( boid -- vel ) dup acceleration time-slice> v*n swap boid-vel v+ ;
: new-vel ( boid -- vel )
dup acceleration time-slice> v*n swap boid-vel v+ normalize ;
: wrap-pos ( pos -- pos ) first2 wrap-y swap wrap-x swap 2array ;
: iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: iterate-boids ( -- ) boids get [ iterate-boid ] map boids set ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : draw-boids ( -- ) boids get [ draw-boid ] each flush-dpy ;
: draw-boids ( -- )
reset-slate white set-clear-color black set-color clear-window
boids get [ draw-boid ] each flush-dlist flush-slate ;
! : run-boids ( -- ) iterate-boids clear-window draw-boids 1 sleep run-boids ;
SYMBOL: stop?
: run-boids ( -- )
self get rect-dim world-size set
iterate-boids draw-boids 1 sleep
stop? get [ ] [ run-boids ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boids-go ( -- )
init-variables
0.1 time-slice set
! 1.0 >min-speed
! 1.0 >max-speed
<slate> dup self set open-window
100 capacity set
self get rect-dim world-size set
50 random-boids boids set
1000 sleep
f stop? set
run-boids ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Boids ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: gadgets-frames gadgets-labels gadgets-theme gadgets-grids
gadgets-editors gadgets-buttons ;
! USING: kernel arrays gadgets gadgets-labels gadgets-editors vars ;
TUPLE: field label editor quot ;
VAR: field
C: field ( label-text editor-text quot -- <field> )
[ field ]
[ field> set-field-quot
<editor> field> set-field-editor
<label> field> set-field-label
field> field-label field> field-editor 2array make-shelf
field> set-gadget-delegate
field> ]
let ;
M: field gadget-gestures
drop H{ { T{ key-down f f "RETURN" } [ dup field-quot call ] } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bind] ( ns quot -- quot ) \ bind 3array >quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VARS: ns frame ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: number-symbol-field ( label init symbol -- <field> )
1array >quotation [ set ] append
[ field-editor editor-text string>number ]
swap append
ns> swap [bind]
<field> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-slate ( -- ) <slate> t over set-gadget-clipped? self set ;
: boids-window ( -- )
<frame> >frame
[ ] make-hash >ns
ns> [ init-slate
init-variables
10 time-slice set
100 capacity set
{ 100 100 } world-size set
50 random-boids boids set
f stop? set
] bind
"Weight" <label> dup title-theme 1array
"Alignment: " "1" alignment-weight number-symbol-field
"Cohesion: " "1" cohesion-weight number-symbol-field
"Separation: " "1" separation-weight number-symbol-field
3array append
"Radius" <label> dup title-theme 1array
"Alignment: " "50" alignment-radius number-symbol-field
"Cohesion: " "75" cohesion-radius number-symbol-field
"Separation: " "25" separation-radius number-symbol-field
3array append
"View angle" <label> dup title-theme 1array
"Alignment: " "180" alignment-view-angle number-symbol-field
"Cohesion: " "180" cohesion-view-angle number-symbol-field
"Separation: " "180" separation-view-angle number-symbol-field
3array append
"" <label> dup title-theme 1array
"Time slice: " "10" time-slice number-symbol-field 1array
"Stop" ns> [ t stop? set ] [bind] <bevel-button>
"Start" ns> [ f stop? set [ run-boids ] in-thread ] [bind] <bevel-button>
"Reset" ns> [ 50 random-boids boids set ] [bind] <bevel-button>
3array
append append append append append
make-pile 1 over set-pack-fill frame> @left grid-add
ns> [ self get ] bind frame> @center grid-add
frame> "Boids" open-titled-window
ns> [ 1000 sleep [ run-boids ] in-thread ] bind
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Comments from others:
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! slava foo get blah foo set ==> foo [ blah ] change
! slava dup >r blah r> ==> [ blah ] keep
! : execute-with ( item [ word word ... ] -- results ... )
! [ over >r execute r> ] each drop ;
PROVIDE: boids ;

127
contrib/cairo/cairo.factor
View File

@ -1,25 +1,12 @@
! Cairo stuff ! Cairo binding
!
! To run this code, bootstrap Factor like so:
!
! ./f boot.image.le32
! -libraries:sdl:name=libSDL.so
! -libraries:sdl-gfx:name=libSDL_gfx
! -libraries:cairo:name=libcairo
!
! (But all on one line)
!
IN: cairo IN: cairo
USING: hashtables ; USE: hashtables
USE: compiler USE: compiler
USE: alien USE: alien
USE: errors USE: errors
USE: kernel USE: kernel
USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
USE: sdl
USE: vectors USE: vectors
USE: prettyprint USE: prettyprint
USE: io USE: io
@ -190,174 +177,174 @@ C-ENUM:
; ;
: cairo_create ( cairo_surface_t -- cairo_t ) : cairo_create ( cairo_surface_t -- cairo_t )
"cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ; compiled "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
: cairo_destroy ( cairo_t -- ) : cairo_destroy ( cairo_t -- )
"void" "cairo" "cairo_destroy" [ "cairo_t*" ] ; compiled "void" "cairo" "cairo_destroy" [ "cairo_t*" ] ;
: cairo_set_operator ( cairo_t cairo_operator_t -- ) : cairo_set_operator ( cairo_t cairo_operator_t -- )
"void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] ; compiled "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] ;
: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t) : cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t)
"void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ; compiled "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ;
: cairo_set_source_rgb ( cairo_t red green blue -- ) : cairo_set_source_rgb ( cairo_t red green blue -- )
"void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ;
: cairo_set_source_rgba ( cairo_t red green blue alpha -- ) : cairo_set_source_rgba ( cairo_t red green blue alpha -- )
"void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
: cairo_set_source_surface ( cairo_t cairo_surface_t x y -- ) : cairo_set_source_surface ( cairo_t cairo_surface_t x y -- )
"void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
: cairo_set_tolerance ( cairo_t tolerance -- ) : cairo_set_tolerance ( cairo_t tolerance -- )
"void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_set_antialias ( cairo_t cairo_antialias_t -- ) : cairo_set_antialias ( cairo_t cairo_antialias_t -- )
"void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ; compiled "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ;
: cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- ) : cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- )
"void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ; compiled "void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ;
: cairo_set_line_width ( cairo_t width -- ) : cairo_set_line_width ( cairo_t width -- )
"void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_set_line_cap ( cairo_t cairo_line_cap_t -- ) : cairo_set_line_cap ( cairo_t cairo_line_cap_t -- )
"void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ; compiled "void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ;
: cairo_set_line_join ( cairo_t cairo_line_join_t -- ) : cairo_set_line_join ( cairo_t cairo_line_join_t -- )
"void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ; compiled "void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ;
: cairo_set_dash ( cairo_t dashes num_dashes offset -- ) : cairo_set_dash ( cairo_t dashes num_dashes offset -- )
"void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ;
: cairo_set_miter_limit ( cairo_t limit -- ) : cairo_set_miter_limit ( cairo_t limit -- )
"void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_translate ( cairo_t x y -- ) : cairo_translate ( cairo_t x y -- )
"void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_scale ( cairo_t sx sy -- ) : cairo_scale ( cairo_t sx sy -- )
"void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_rotate ( cairo_t angle -- ) : cairo_rotate ( cairo_t angle -- )
"void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ;
! cairo path creating functions ! cairo path creating functions
: cairo_new_path ( cairo_t -- ) : cairo_new_path ( cairo_t -- )
"void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ;
: cairo_move_to ( cairo_t x y -- ) : cairo_move_to ( cairo_t x y -- )
"void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_line_to ( cairo_t x y -- ) : cairo_line_to ( cairo_t x y -- )
"void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- ) : cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- )
"void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_arc ( cairo_t xc yc radius angle1 angle2 -- ) : cairo_arc ( cairo_t xc yc radius angle1 angle2 -- )
"void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- ) : cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- )
"void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_rel_move_to ( cairo_t dx dy -- ) : cairo_rel_move_to ( cairo_t dx dy -- )
"void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_rel_line_to ( cairo_t dx dy -- ) : cairo_rel_line_to ( cairo_t dx dy -- )
"void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- ) : cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- )
"void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_rectangle ( cairo_t x y width height -- ) : cairo_rectangle ( cairo_t x y width height -- )
"void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
: cairo_close_path ( cairo_t -- ) : cairo_close_path ( cairo_t -- )
"void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ;
! painting functions ! painting functions
: cairo_paint ( cairo_t -- ) : cairo_paint ( cairo_t -- )
"void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ;
: cairo_paint_with_alpha ( cairo_t alpha -- ) : cairo_paint_with_alpha ( cairo_t alpha -- )
"void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_mask ( cairo_t cairo_pattern_t -- ) : cairo_mask ( cairo_t cairo_pattern_t -- )
"void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ; compiled "void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ;
: cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- ) : cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- )
"void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
: cairo_stroke ( cairo_t -- ) : cairo_stroke ( cairo_t -- )
"void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ;
: cairo_stroke_preserve ( cairo_t -- ) : cairo_stroke_preserve ( cairo_t -- )
"void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ;
: cairo_fill ( cairo_t -- ) : cairo_fill ( cairo_t -- )
"void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ;
: cairo_fill_preserve ( cairo_t -- ) : cairo_fill_preserve ( cairo_t -- )
"void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ;
: cairo_copy_page ( cairo_t -- ) : cairo_copy_page ( cairo_t -- )
"void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ;
: cairo_show_page ( cairo_t -- ) : cairo_show_page ( cairo_t -- )
"void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ;
! insideness testing ! insideness testing
: cairo_in_stroke ( cairo_t x y -- t/f ) : cairo_in_stroke ( cairo_t x y -- t/f )
"int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ;
: cairo_in_fill ( cairo_t x y -- t/f ) : cairo_in_fill ( cairo_t x y -- t/f )
"int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ; compiled "int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ;
! rectangular extents ! rectangular extents
: cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- ) : cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- )
"void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
: cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- ) : cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- )
"void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
! clipping ! clipping
: cairo_reset_clip ( cairo_t -- ) : cairo_reset_clip ( cairo_t -- )
"void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ;
: cairo_clip ( cairo_t -- ) : cairo_clip ( cairo_t -- )
"void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ;
: cairo_clip_preserve ( cairo_t -- ) : cairo_clip_preserve ( cairo_t -- )
"void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ;
: cairo_set_source ( cairo_t cairo_pattern_t -- ) : cairo_set_source ( cairo_t cairo_pattern_t -- )
"void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ; compiled "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ;
: cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t ) : cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t )
"void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ; compiled "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ;
: cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t ) : cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t )
"void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status ) : cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status )
"uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ; compiled "uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ;
: cairo_show_text ( cairo_t msg_utf8 -- ) : cairo_show_text ( cairo_t msg_utf8 -- )
"void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ; compiled "void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ;
: cairo_text_path ( cairo_t msg_utf8 -- ) : cairo_text_path ( cairo_t msg_utf8 -- )
"void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ; compiled "void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ;
: cairo_select_font_face ( cairo_t family font_slant font_weight -- ) : cairo_select_font_face ( cairo_t family font_slant font_weight -- )
"void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ; compiled "void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ;
: cairo_set_font_size ( cairo_t scale -- ) : cairo_set_font_size ( cairo_t scale -- )
"void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ; compiled "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_identity_matrix ( cairo_t -- ) : cairo_identity_matrix ( cairo_t -- )
"void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ; compiled "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;

14
contrib/cairo/load.factor
View File

@ -1,13 +1,3 @@
IN: scratchpad USING: alien ;
USING: alien kernel parser compiler words sequences ;
{ PROVIDE: cairo { "cairo.factor" } ;
{ "cairo" "libcairo" }
{ "sdl-gfx" "libSDL_gfx" }
{ "sdl" "libSDL" }
} [ first2 add-simple-library ] each
{
"cairo"
"cairo_sdl"
} [ "/contrib/cairo/" swap ".factor" append3 run-resource ] each

276
contrib/calendar/calendar.factor Normal file
View File

@ -0,0 +1,276 @@
USING: arrays errors generic hashtables io kernel math
namespaces sequences strings prettyprint inspector ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
TUPLE: dt year month day hour minute second ;
SYMBOL: gmt-offset
7 gmt-offset set-global
: month-names
{
"Not a month" "January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
} ;
: months-abbreviations
{
"Not a month"
"Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
} ;
: day-names
{
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
} ;
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
: average-month ( -- x )
#! length of average month in days
30.41666666666667 ;
: time>array ( dt -- vec ) tuple>array 2 swap tail ;
: compare-timestamps ( tuple tuple -- n )
[ time>array ] 2apply <=> ;
SYMBOL: a
SYMBOL: b
SYMBOL: c
SYMBOL: d
SYMBOL: e
SYMBOL: y
SYMBOL: m
: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
[
14 pick - 12 /i a set
pick 4800 + a get - y set
over 12 a get * + 3 - m set
2nip 153 m get * 2 + 5 /i + 365 y get * +
y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
] with-scope ;
: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
[
32044 + a set
4 a get * 3 + 146097 /i b set
a get 146097 b get * 4 /i - c set
4 c get * 3 + 1461 /i d set
c get 1461 d get * 4 /i - e set
5 e get * 2 + 153 /i m set
100 b get * d get + 4800 -
m get 10 /i + m get 3 +
12 m get 10 /i * -
e get 153 m get * 2 + 5 /i - 1+
] with-scope ;
: set-date ( year month day timestamp -- )
[ set-timestamp-day ] keep
[ set-timestamp-month ] keep
set-timestamp-year ;
: set-time ( hour minute second timestamp -- )
[ set-timestamp-second ] keep
[ set-timestamp-minute ] keep
set-timestamp-hour ;
: date ( timestamp -- year month day )
[ timestamp-year ] keep
[ timestamp-month ] keep
timestamp-day ;
: time ( timestamp -- hour minute second )
[ timestamp-hour ] keep
[ timestamp-minute ] keep
timestamp-second ;
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
: weeks ( n -- dt ) 7 * zero-dt [ set-dt-day ] keep ;
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
: julian-day-number>timestamp ( n -- timestamp )
julian-day-number>date 0 0 0 0 <timestamp> ;
GENERIC: +year ( timestamp x -- timestamp )
GENERIC: +month ( timestamp x -- timestamp )
GENERIC: +day ( timestamp x -- timestamp )
GENERIC: +hour ( timestamp x -- timestamp )
GENERIC: +minute ( timestamp x -- timestamp )
GENERIC: +second ( timestamp x -- timestamp )
: /rem ( f n -- q r )
#! q is positive or negative, r is positive from 0 <= r < n
[ /f floor >bignum ] 2keep rem ;
: float>whole-part ( float -- int float )
[ floor >bignum ] keep dupd swap - ;
: leap-year? ( year -- ? )
dup 100 mod zero? 400 4 ? mod zero? ;
: adjust-leap-year ( timestamp -- timestamp )
dup date 29 = swap 2 = and swap leap-year? not and [
dup >r timestamp-year 3 1 r> [ set-date ] keep
] when ;
M: integer +year ( timestamp n -- timestamp )
over timestamp-year + swap [ set-timestamp-year ] keep
adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
float>whole-part rot swap 365.2425 * +day swap +year ;
M: integer +month ( timestamp n -- timestamp )
over timestamp-month + 12 /rem
dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
+year ;
M: real +month ( timestamp n -- timestamp )
float>whole-part rot swap average-month * +day swap +month ;
M: integer +day ( timestamp n -- timestamp )
swap [
date julian-day-number + julian-day-number>timestamp
] keep swap >r time r> [ set-time ] keep ;
M: real +day ( timestamp n -- timestamp )
float>whole-part rot swap 24 * +hour swap +day ;
M: integer +hour ( timestamp n -- timestamp )
over timestamp-hour + 24 /rem pick set-timestamp-hour
+day ;
M: real +hour ( timestamp n -- timestamp )
float>whole-part rot swap 60 * +minute swap +hour ;
M: integer +minute ( timestamp n -- timestamp )
over timestamp-minute + 60 /rem pick
set-timestamp-minute +hour ;
M: real +minute ( timestamp n -- timestamp )
float>whole-part rot swap 60 * +second swap +minute ;
M: number +second ( timestamp n -- timestamp )
over timestamp-second + 60 /rem >r >bignum r>
pick set-timestamp-second +minute ;
: +dt ( timestamp dt -- timestamp )
dupd
[ dt-second +second ] keep
[ dt-minute +minute ] keep
[ dt-hour +hour ] keep
[ dt-day +day ] keep
[ dt-month +month ] keep
dt-year +year
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
: make-timestamp ( year month day hour minute second gmt-offset -- timestamp )
<timestamp> [ 0 seconds +dt ] keep
[ = [ "invalid timestamp" throw ] unless ] keep ;
: array>dt ( vec -- dt ) { dt f } swap append >tuple ;
: +dts ( dt dt -- dt ) [ time>array ] 2apply v+ array>dt ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
#! data
time>array
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
[ / ] 2map sum ;
: dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
: dt>minutes ( dt -- x ) dt>years 525949.2 * ;
: dt>seconds ( dt -- x ) dt>years 31556952 * ;
: convert-timezone ( timestamp n -- timestamp )
[ over timestamp-gmt-offset - hours +dt ] keep
over set-timestamp-gmt-offset ;
: >local-time ( timestamp -- timestamp )
gmt-offset get convert-timezone ;
: >gmt ( timestamp -- timestamp )
0 convert-timezone ;
: gmt ( -- timestamp )
#! GMT time, right now
1970 1 1 0 0 0 0 <timestamp> millis 1000 /f seconds +dt ;
: timestamp- ( timestamp timestamp -- dt )
[ >gmt time>array ] 2apply v- array>dt ;
: now ( -- timestamp ) gmt >local-time ;
: before ( dt -- -dt ) time>array [ neg ] map array>dt ;
: from-now ( dt -- timestamp ) now swap +dt ;
: ago ( dt -- timestamp ) before from-now ;
: days-in-year ( year -- n ) leap-year? 366 365 ? ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
: days-in-month ( year month -- n )
swap leap-year? [
[ day-counts nth ] keep 2 = [ 1+ ] when
] [
day-counts nth
] if ;
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
>r dup 2 <= [ 12 + >r 1- r> ] when
>r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
[ 1+ 3 * 5 /i + ] keep 2 * + r>
1+ + 7 mod ;
: day-of-week ( timestamp -- n )
[ timestamp-year ] keep
[ timestamp-month ] keep
timestamp-day
zeller-congruence ;
: day-of-year ( timestamp -- n )
[
[ timestamp-year leap-year? ] keep
[ date 3array ] keep timestamp-year 3 1 3array <=>
0 >= and 1 0 ?
] keep
[ timestamp-month day-counts head-slice sum + ] keep
timestamp-day + ;
: print-day ( n -- )
number>string dup length 2 < [ bl ] when write ;
: print-month ( year month -- )
[ month-names nth write bl . ] 2keep
[ 1 zeller-congruence ] 2keep
days-in-month day-abbreviations2 " " join print
over [ " " write ] times
[
[ 1+ print-day ] keep
1+ + 7 mod zero? [ terpri ] [ bl ] if
] each-with terpri ;
: print-year ( year -- )
12 [ 1+ print-month terpri ] each-with ;
: timestamp>http-string ( timestamp -- string )
#! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
>gmt
[
dup day-of-week day-abbreviations3 nth write ", " write
dup timestamp-day unparse write bl
dup timestamp-month months-abbreviations nth write bl
dup timestamp-year unparse write bl
dup timestamp-hour unparse 2 CHAR: 0 pad-left write ":" write
dup timestamp-minute unparse 2 CHAR: 0 pad-left write ":" write
dup timestamp-second >fixnum unparse 2 CHAR: 0 pad-left write " GMT" write
] string-out ;

6
contrib/calendar/load.factor Normal file
View File

@ -0,0 +1,6 @@
PROVIDE: calendar
{
"calendar.factor"
} {
"test/calendar.factor"
} ;

126
contrib/calendar/test/calendar.factor Normal file
View File

@ -0,0 +1,126 @@
USING: arrays calendar errors kernel math sequences test ;
[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test
[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 leap-year? ] unit-test
[ t ] [ 2000 leap-year? ] unit-test
[ f ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt
2006 10 10 0 0 1 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt
2006 10 10 0 1 40 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt
2006 10 9 23 58 20 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt
2006 10 11 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt
2006 10 10 0 10 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt
2006 10 10 0 10 30 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt
2006 10 10 0 0 45 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt
2006 10 9 23 59 15 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt
2006 10 15 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt
2006 10 9 23 50 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt
2006 10 9 22 20 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt
2006 1 1 1 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt
2006 1 1 12 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt
2006 1 4 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt
2004 12 31 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt
2006 12 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt
2008 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt
2007 2 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt
2006 2 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt
2005 12 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt
2005 11 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt
2004 12 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt
2004 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt
2005 3 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt
2003 3 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt
1906 1 1 0 0 0 0 make-timestamp = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test
[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test
[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test
[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt
2009 1 1 0 0 10 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt
1998 12 31 23 59 50 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone
2004 1 1 11 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone
2004 1 1 16 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone
2004 1 1 13 30 0 0 make-timestamp = ] unit-test

22
contrib/concurrency/concurrency-examples.factor
View File

@ -23,8 +23,9 @@
! !
! Examples of using the concurrency library. ! Examples of using the concurrency library.
IN: concurrency-examples IN: concurrency-examples
USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists USING: concurrency dlists errors gadgets gadgets-labels
math math-contrib namespaces opengl prettyprint sequences threads ; gadgets-panes gadgets-theme io kernel math namespaces opengl
prettyprint sequences threads ;
: (logger) ( mailbox -- ) : (logger) ( mailbox -- )
#! Using the given mailbox, start a thread which #! Using the given mailbox, start a thread which
@ -34,10 +35,10 @@ math math-contrib namespaces opengl prettyprint sequences threads ;
: logger ( -- mailbox ) : logger ( -- mailbox )
#! Start a logging thread, which will log messages to the #! Start a logging thread, which will log messages to the
#! console that are put in the returned mailbox. #! console that are put in the returned mailbox.
make-mailbox dup [ (logger) ] cons in-thread ; make-mailbox dup [ (logger) ] curry in-thread ;
: (pong-server0) ( -- ) : (pong-server0) ( -- )
receive uncons "ping" = [ receive second "ping" = [
"pong" swap send (pong-server0) "pong" swap send (pong-server0)
] [ ] [
"Pong server shutting down" swap send "Pong server shutting down" swap send
@ -146,28 +147,23 @@ M: crash-command run-rpc-command ( command -- shutdown? result )
: test-add ( process -- ) : test-add ( process -- )
[ [
"add" [ 1 2 3 ] <rpc-command> swap send-synchronous . "add" [ 1 2 3 ] <rpc-command> swap send-synchronous .
] cons spawn drop ; ] curry spawn drop ;
: test-crash ( process -- ) : test-crash ( process -- )
[ [
"crash" f <rpc-command> swap send-synchronous . "crash" f <rpc-command> swap send-synchronous .
] cons spawn drop ; ] curry spawn drop ;
! ****************************** ! ******************************
! Experimental code below ! Experimental code below
! ****************************** ! ******************************
USE: gadgets
USE: gadgets-labels
USE: gadgets-presentations
USE: gadgets-layouts
USE: generic
TUPLE: promised-label promise font color ; TUPLE: promised-label promise font color ;
C: promised-label ( promise -- promised-label ) C: promised-label ( promise -- promised-label )
dup delegate>gadget dup label-theme dup delegate>gadget dup label-theme
[ set-promised-label-promise ] keep [ set-promised-label-promise ] keep
[ [ dup promised-label-promise ?promise drop relayout ] cons spawn drop ] keep ; [ [ dup promised-label-promise ?promise drop relayout ] curry spawn drop ] keep ;
: promised-label-text ( promised-label -- text ) : promised-label-text ( promised-label -- text )
promised-label-promise dup promise-fulfilled? [ promised-label-promise dup promise-fulfilled? [
@ -196,4 +192,4 @@ M: promised-label set-label-font set-promised-label-font ;
1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; 1 sleep dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
: test-promise-ui ( -- ) : test-promise-ui ( -- )
<promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] cons spawn drop ; <promise> dup <promised-label> gadget. [ 15 fib unparse swap fulfill ] curry spawn drop ;

29
contrib/concurrency/concurrency-tests.factor
View File

@ -23,8 +23,7 @@
! !
IN: concurrency IN: concurrency
USING: kernel concurrency concurrency-examples threads vectors USING: kernel concurrency concurrency-examples threads vectors
sequences lists namespaces test errors dlists strings sequences namespaces test errors dlists strings math words ;
math words ;
[ "junk" ] [ [ "junk" ] [
<dlist> <dlist>
@ -81,9 +80,9 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry in-thread
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry in-thread
2dup [ mailbox-get swap push ] cons cons in-thread 2dup [ mailbox-get swap push ] curry curry in-thread
1 over mailbox-put 1 over mailbox-put
2 over mailbox-put 2 over mailbox-put
3 swap mailbox-put 3 swap mailbox-put
@ -92,9 +91,9 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 2 3 } ] [ [ V{ 1 2 3 } ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
1 over mailbox-put 1 over mailbox-put
2 over mailbox-put 2 over mailbox-put
3 swap mailbox-put 3 swap mailbox-put
@ -103,10 +102,10 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector> 0 <vector>
make-mailbox make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ integer? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread 2dup [ [ string? ] swap mailbox-get? swap push ] curry curry in-thread
1 over mailbox-put 1 over mailbox-put
"junk" over mailbox-put "junk" over mailbox-put
[ 456 ] over mailbox-put [ 456 ] over mailbox-put
@ -174,8 +173,8 @@ USING: kernel concurrency concurrency-examples threads vectors
[ V{ 50 50 50 } ] [ [ V{ 50 50 50 } ] [
0 <vector> 0 <vector>
<promise> <promise>
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
2dup [ ?promise swap push ] cons cons spawn drop 2dup [ ?promise swap push ] curry curry spawn drop
50 swap fulfill 50 swap fulfill
] unit-test ] unit-test

33
contrib/concurrency/concurrency.factor
View File

@ -23,7 +23,7 @@
! !
! Concurrency library for Factor based on Erlang/Termite style ! Concurrency library for Factor based on Erlang/Termite style
! concurrency. ! concurrency.
USING: kernel lists generic threads io namespaces errors words USING: kernel generic threads io namespaces errors words
math sequences hashtables strings vectors dlists ; math sequences hashtables strings vectors dlists ;
IN: concurrency IN: concurrency
@ -158,17 +158,14 @@ TUPLE: process node links pid mailbox ;
#! that process terminates. #! that process terminates.
localnode swap unit gensym unparse make-mailbox <process> ; localnode swap unit gensym unparse make-mailbox <process> ;
#! The 'self-process' variable holds the currently executing process.
SYMBOL: self-process
: self ( -- process ) : self ( -- process )
#! Returns the contents of the 'self-process' variables which #! Returns the contents of the 'self-process' variables which
#! is the process object for the current process. #! is the process object for the current process.
self-process get ; \ self get ;
: init-main-process ( -- ) : init-main-process ( -- )
#! Setup the main process. #! Setup the main process.
make-process self-process set ; make-process \ self set-global ;
init-main-process init-main-process
@ -176,7 +173,7 @@ init-main-process
#! Calls the quotation with 'self' set #! Calls the quotation with 'self' set
#! to the given process. #! to the given process.
[ [
self-process set \ self set
] make-hash ] make-hash
swap bind ; swap bind ;
@ -224,7 +221,7 @@ TUPLE: linked-exception error ;
#! Same as spawn but if the quotation throws an error that #! Same as spawn but if the quotation throws an error that
#! is uncaught, that error gets propogated to the process #! is uncaught, that error gets propogated to the process
#! performing the spawn-link. #! performing the spawn-link.
[ catch [ rethrow-linked ] when* ] cons [ catch [ rethrow-linked ] when* ] curry
[ in-thread ] self make-linked-process [ with-process ] over slip ; [ in-thread ] self make-linked-process [ with-process ] over slip ;
#! A common operation is to send a message to a process containing #! A common operation is to send a message to a process containing
@ -248,11 +245,7 @@ TUPLE: tagged-message data from tag ;
#! 'match-quot' is a quotation with stack effect ( msg -- ). It #! 'match-quot' is a quotation with stack effect ( msg -- ). It
#! will be called with the message on the top of the stack if #! will be called with the message on the top of the stack if
#! the 'pred' word returned true. #! the 'pred' word returned true.
uncons >r dupd execute [ [ first execute ] 2keep rot [ second call ] [ 2drop ] if ;
r> car call
] [
r> 2drop
] if ;
: recv ( forms -- ) : recv ( forms -- )
#! Get a message from the processes mailbox. Compare it against the #! Get a message from the processes mailbox. Compare it against the
@ -289,7 +282,7 @@ TUPLE: tagged-message data from tag ;
#! is matched up with the request by generating a message tag #! is matched up with the request by generating a message tag
#! which should be sent back with the reply. #! which should be sent back with the reply.
>r tag-message [ tagged-message-tag ] keep r> send >r tag-message [ tagged-message-tag ] keep r> send
unit [ car tag-match? ] cons receive-if tagged-message-data ; unit [ first tag-match? ] curry receive-if tagged-message-data ;
: reply ( tagged-message message -- ) : reply ( tagged-message message -- )
#! Replies to the tagged-message which should have been a result of a #! Replies to the tagged-message which should have been a result of a
@ -321,7 +314,7 @@ SYMBOL: quit-cc
[ [
(spawn-server) (spawn-server)
"Exiting process: " write self process-pid print "Exiting process: " write self process-pid print
] cons spawn ; ] curry spawn ;
: spawn-linked-server ( quot -- process ) : spawn-linked-server ( quot -- process )
#! Similar to 'spawn-server' but the parent process will be linked #! Similar to 'spawn-server' but the parent process will be linked
@ -329,7 +322,7 @@ SYMBOL: quit-cc
[ [
(spawn-server) (spawn-server)
"Exiting process: " write self process-pid print "Exiting process: " write self process-pid print
] cons spawn-link ; ] curry spawn-link ;
: send-reply ( message pred quot -- ) : send-reply ( message pred quot -- )
#! The intent of this word is to provde an easy way to #! The intent of this word is to provde an easy way to
@ -379,7 +372,7 @@ SYMBOL: quit-cc
#! and jumping back into it from a spawn and keeping the 'self' #! and jumping back into it from a spawn and keeping the 'self'
#! variable correct. It's a workaround until I can find out how to #! variable correct. It's a workaround until I can find out how to
#! stop 'self' from being clobbered back to its old value. #! stop 'self' from being clobbered back to its old value.
[ ] callcc1 dup process? [ self-process set f ] when ; [ ] callcc1 dup process? [ \ self set-global f ] when ;
: call-server-cc ( server-cc -- ) : call-server-cc ( server-cc -- )
#! Calls the server continuation passing the current 'self' #! Calls the server continuation passing the current 'self'
@ -392,7 +385,7 @@ SYMBOL: quit-cc
#! ?future. If the quotation has completed the result will be returned. #! ?future. If the quotation has completed the result will be returned.
#! If not, the process will block until the quotation completes. #! If not, the process will block until the quotation completes.
#! 'quot' must have stack effect ( -- X ). #! 'quot' must have stack effect ( -- X ).
[ call self send ] cons spawn ; [ self send ] append spawn ;
: ?future ( future -- result ) : ?future ( future -- result )
#! Block the process until the future has completed and then place the #! Block the process until the future has completed and then place the
@ -443,7 +436,7 @@ SYMBOL: lazy-quot
[ tagged-message? [ [ drop t ] [ get call ] send-reply ] ] [ tagged-message? [ [ drop t ] [ get call ] send-reply ] ]
] recv ] recv
] with-scope ] with-scope
] cons spawn ; ] curry spawn ;
: ?lazy ( lazy -- result ) : ?lazy ( lazy -- result )
#! Given a process spawned using 'lazy', evaluate it and return the result. #! Given a process spawned using 'lazy', evaluate it and return the result.

8
contrib/concurrency/load.factor
View File

@ -1,5 +1,5 @@
IN: scratchpad REQUIRES: dlists ;
USING: kernel parser compiler words sequences ;
"/contrib/dlists.factor" run-resource PROVIDE: concurrency
"/contrib/concurrency/concurrency.factor" run-resource { "concurrency.factor" }
{ "concurrency-examples.factor" "concurrency-tests.factor" } ;

8
contrib/coroutines.factor
View File

@ -22,7 +22,7 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! !
IN: coroutines IN: coroutines
USING: kernel lists generic ; USING: kernel generic ;
TUPLE: coroutine resumecc exitcc ; TUPLE: coroutine resumecc exitcc ;
@ -32,7 +32,7 @@ TUPLE: coroutine resumecc exitcc ;
#! on the stack and an initial value (received from coresume) #! on the stack and an initial value (received from coresume)
#! when first resumed. ie. The quotation should have stack #! when first resumed. ie. The quotation should have stack
#! effect ( co value -- ). #! effect ( co value -- ).
f f <coroutine> dup rot cons over set-coroutine-resumecc ; f f <coroutine> dup rot curry over set-coroutine-resumecc ;
: coresume ( v co -- result ) : coresume ( v co -- result )
#! Resume a coroutine with 'v' as the first item on the #! Resume a coroutine with 'v' as the first item on the
@ -48,7 +48,7 @@ TUPLE: coroutine resumecc exitcc ;
#! Suspend a coroutine, leaving the value 'v' on the #! Suspend a coroutine, leaving the value 'v' on the
#! stack when control is passed to the 'coresume' caller. #! stack when control is passed to the 'coresume' caller.
[ [
[ continue-with ] cons [ continue-with ] curry
over set-coroutine-resumecc over set-coroutine-resumecc
coroutine-exitcc continue-with coroutine-exitcc continue-with
] callcc1 rot drop ; ] callcc1 rot drop ;
@ -69,3 +69,5 @@ test2 f swap coresume . f swap coresume . f swap coresume . drop
test3 f swap coresume . f swap coresume . f swap coresume . drop test3 f swap coresume . f swap coresume . f swap coresume . drop
PROVIDE: coroutines ;

8
contrib/crypto/blum-blum-shub.factor
View File

@ -14,8 +14,7 @@ IN: crypto
generate-bbs-primes * [ find-relative-prime ] keep <bbs> ; generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
IN: crypto-internals IN: crypto-internals
SYMBOL: blum-blum-shub 256 make-bbs global [ blum-blum-shub set ] bind SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global
IN: crypto
: next-bbs-bit ( bbs -- bit ) : next-bbs-bit ( bbs -- bit )
#! x = x^2 mod n, return low bit of calculated x #! x = x^2 mod n, return low bit of calculated x
@ -26,5 +25,10 @@ SYMBOL: temp-bbs
: (bbs-bits) ( numbits bbs -- n ) : (bbs-bits) ( numbits bbs -- n )
temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ; temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
IN: crypto
: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ; : random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
: random-bbs-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ; : random-bbs-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;
: random-int ( n -- n )
#! Cryptographically secure random number using Blum-Blum-Shub 256
[ log2 1+ random-bbs-bits ] keep mod ;

2
contrib/crypto/common.factor
View File

@ -1,5 +1,5 @@
IN: crypto-internals IN: crypto-internals
USING: kernel io strings sequences namespaces math parser lists ; USING: kernel io strings sequences namespaces math parser ;
: w+ ( int -- int ) + HEX: ffffffff bitand ; inline : w+ ( int -- int ) + HEX: ffffffff bitand ; inline
: nth-int ( string n -- int ) 2 shift dup 4 + rot <slice> le> ; inline : nth-int ( string n -- int ) 2 shift dup 4 + rot <slice> le> ; inline

44
contrib/crypto/load.factor
View File

@ -1,28 +1,36 @@
IN: scratchpad REQUIRES: math ;
USING: kernel parser sequences words compiler ;
"/contrib/math/load.factor" run-resource PROVIDE: crypto {
"common.factor"
{ "base64.factor"
"common" "barrett.factor"
"base64" "montgomery.factor"
"barrett" "random.factor"
"montgomery" "miller-rabin.factor"
"random"
"miller-rabin"
! Rngs ! Rngs
"blum-blum-shub" "blum-blum-shub.factor"
! Hash ! Hash
"crc32" "crc32.factor"
"md5" "md5.factor"
"sha1" "sha1.factor"
! Block ciphers ! Block ciphers
"rc4" "rc4.factor"
! Public key ! Public key
"rsa" "rsa.factor"
} [ "/contrib/crypto/" swap ".factor" append3 run-resource ] each } {
"test/common.factor"
"test/md5.factor"
"test/sha1.factor"
"test/base64.factor"
"test/miller-rabin.factor"
"test/crc32.factor"
"test/rsa.factor"
"test/barrett.factor"
"test/montgomery.factor"
"test/blum-blum-shub.factor"
} ;

2
contrib/crypto/md5.factor
View File

@ -1,4 +1,4 @@
USING: kernel io strings sequences namespaces math parser lists crypto ; USING: kernel io strings sequences namespaces math parser crypto ;
IN: crypto-internals IN: crypto-internals
SYMBOL: a SYMBOL: a

11
contrib/crypto/miller-rabin.factor
View File

@ -50,8 +50,9 @@ SYMBOL: trials
IN: crypto IN: crypto
: miller-rabin* ( n trials -- bool ) : miller-rabin* ( n num-trials -- bool )
#! Probailistic primality test for n > 2, with trials as a parameter #! Probailistic primality test for n > 2, with num-trials as a parameter
over 2 > [ "miller-rabin error: must call with n > 2" throw ] unless
[ init-miller-rabin (miller-rabin) ] with-scope ; [ init-miller-rabin (miller-rabin) ] with-scope ;
: miller-rabin ( n -- bool ) : miller-rabin ( n -- bool )
@ -70,7 +71,11 @@ IN: crypto
large-random-bits next-miller-rabin-prime ; large-random-bits next-miller-rabin-prime ;
: random-miller-rabin-prime==3(mod4) ( numbits -- p ) : random-miller-rabin-prime==3(mod4) ( numbits -- p )
dup random-miller-rabin-prime dup 4 mod 3 = [ drop random-miller-rabin-prime==3(mod4) ] [ nip ] if ; dup random-miller-rabin-prime dup 4 mod 3 = [
drop random-miller-rabin-prime==3(mod4)
] [
nip
] if ;
: (find-relative-prime) ( m g -- p ) : (find-relative-prime) ( m g -- p )
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ; 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;

4
contrib/crypto/random.factor
View File

@ -1,5 +1,5 @@
USING: kernel math sequences namespaces errors hashtables words arrays parser USING: kernel math math-contrib sequences namespaces errors
compiler syntax lists io threads ; hashtables words arrays parser compiler syntax io threads ;
IN: crypto IN: crypto
: make-bits ( quot numbits -- n | quot: -- 0/1 ) : make-bits ( quot numbits -- n | quot: -- 0/1 )
0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ; 0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ;

2
contrib/crypto/sha1.factor
View File

@ -1,5 +1,5 @@
USING: kernel io strings sequences namespaces math parser USING: kernel io strings sequences namespaces math parser
lists vectors hashtables kernel-internals math-contrib crypto ; vectors hashtables kernel-internals math-contrib crypto ;
IN: crypto-internals IN: crypto-internals
! Implemented according to RFC 3174. ! Implemented according to RFC 3174.

38
contrib/crypto/test.factor
View File

@ -1,38 +0,0 @@
USING: kernel math test namespaces crypto ;
[ HEX: 1f63edfb7e838622c7412eafaf0439cf0cdf3aae8bdd09e2de69b509a53883a83560d5ce50ea039e4 ] [ HEX: 827c67f31b2b46afa49ed95d7f7a3011e5875f7052d4c55437ce726d3c6ce0dc9c445fda63b6dc4e 16 barrett-mu ] unit-test
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> ] unit-test
[ "" ] [ "" >base64 base64> ] unit-test
[ "a" ] [ "a" >base64 base64> ] unit-test
[ "ab" ] [ "ab" >base64 base64> ] unit-test
[ "abc" ] [ "abc" >base64 base64> ] unit-test
[ HEX: 7155b978fed765e2ec80b472b4eae1154d2f75dd753e7efaca0449b8eaf7c047f94564302c80c717 ] [ HEX: c8d30cdd849cc1cbccf75340f903cde3acc0e7b5e0326aa91f82f442cc1ab23f66cf042c2af22a0b montgomery-r^2 ] unit-test
[ HEX: 5aee1477 ] [ HEX: d681fab9 32 montgomery-n0' ] unit-test
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] "" make nip string>sha1str ] unit-test
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-miller-rabin-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-miller-rabin-prime ] unit-test
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
[ 0 ] [ "" >crc32 ] unit-test
[ HEX: cbf43926 ] [ "123456789" >crc32 ] unit-test

4
contrib/crypto/test/barrett.factor Normal file
View File

@ -0,0 +1,4 @@
USING: kernel math test namespaces crypto ;
[ HEX: 1f63edfb7e838622c7412eafaf0439cf0cdf3aae8bdd09e2de69b509a53883a83560d5ce50ea039e4 ] [ HEX: 827c67f31b2b46afa49ed95d7f7a3011e5875f7052d4c55437ce726d3c6ce0dc9c445fda63b6dc4e 16 barrett-mu ] unit-test

8
contrib/crypto/test/base64.factor Normal file
View File

@ -0,0 +1,8 @@
USING: kernel math test namespaces crypto ;
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> ] unit-test
[ "" ] [ "" >base64 base64> ] unit-test
[ "a" ] [ "a" >base64 base64> ] unit-test
[ "ab" ] [ "ab" >base64 base64> ] unit-test
[ "abc" ] [ "abc" >base64 base64> ] unit-test

5
contrib/crypto/test/blum-blum-shub.factor Normal file
View File

@ -0,0 +1,5 @@
USING: kernel math test namespaces crypto crypto-internals ;
[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test

15
contrib/crypto/test/common.factor Normal file
View File

@ -0,0 +1,15 @@
USING: kernel math test namespaces crypto ;
[ 0 ] [ 1 0 0 bitroll ] unit-test
[ 1 ] [ 1 0 1 bitroll ] unit-test
[ 1 ] [ 1 1 1 bitroll ] unit-test
[ 1 ] [ 1 0 2 bitroll ] unit-test
[ 1 ] [ 1 0 1 bitroll ] unit-test
[ 1 ] [ 1 20 2 bitroll ] unit-test
[ 1 ] [ 1 8 8 bitroll ] unit-test
[ 1 ] [ 1 -8 8 bitroll ] unit-test
[ 1 ] [ 1 -32 8 bitroll ] unit-test
[ 128 ] [ 1 -1 8 bitroll ] unit-test
[ 8 ] [ 1 3 32 bitroll ] unit-test

5
contrib/crypto/test/crc32.factor Normal file
View File

@ -0,0 +1,5 @@
USING: kernel math test namespaces crypto ;
[ 0 ] [ "" >crc32 ] unit-test
[ HEX: cbf43926 ] [ "123456789" >crc32 ] unit-test

10
contrib/crypto/test/md5.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel math test namespaces crypto ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test

10
contrib/crypto/test/miller-rabin.factor Normal file
View File

@ -0,0 +1,10 @@
USING: errors kernel math test namespaces crypto ;
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ "miller-rabin error: must call with n > 2" ] [ [ 2 miller-rabin ] catch ] unit-test
[ t ] [ 3 miller-rabin ] unit-test
[ f ] [ 36 miller-rabin ] unit-test
[ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-miller-rabin-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-miller-rabin-prime ] unit-test

8
contrib/crypto/test/montgomery.factor Normal file
View File

@ -0,0 +1,8 @@
USING: kernel math test namespaces crypto ;
[ HEX: 7155b978fed765e2ec80b472b4eae1154d2f75dd753e7efaca0449b8eaf7c047f94564302c80c717 ] [ HEX: c8d30cdd849cc1cbccf75340f903cde3acc0e7b5e0326aa91f82f442cc1ab23f66cf042c2af22a0b montgomery-r^2 ] unit-test
[ HEX: 5aee1477 ] [ HEX: d681fab9 32 montgomery-n0' ] unit-test

7
contrib/crypto/test/rsa.factor Normal file
View File

@ -0,0 +1,7 @@
USING: kernel math test namespaces crypto ;
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
[ 123456789 ] [ 130 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test

7
contrib/crypto/test/sha1.factor Normal file
View File

@ -0,0 +1,7 @@
USING: kernel math test namespaces crypto ;
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] "" make nip string>sha1str ] unit-test

5
contrib/dlists.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005 Mackenzie Straight. ! Copyright (C) 2005 Mackenzie Straight.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: dlists USING: generic kernel math ; IN: dlists
USING: generic kernel math modules ;
! Double-linked lists. ! Double-linked lists.
@ -60,3 +61,5 @@ C: dlist-node
: dlist-length ( dlist -- length ) : dlist-length ( dlist -- length )
0 swap [ drop 1 + ] dlist-each ; 0 swap [ drop 1 + ] dlist-each ;
PROVIDE: dlists ;

13
contrib/httpd/embedded.factor → contrib/embedded.factor
View File

@ -1,5 +1,5 @@
IN: embedded IN: embedded
USING: sequences kernel parser math namespaces io lists ; USING: sequences kernel parser math namespaces io ;
! if example.fhtml contains: ! if example.fhtml contains:
! <html> ! <html>
@ -49,17 +49,14 @@ USING: sequences kernel parser math namespaces io lists ;
: parse-embedded ( string -- quot ) : parse-embedded ( string -- quot )
#! simple example: "numbers: <% 3 [ 1 + pprint ] each %>" #! simple example: "numbers: <% 3 [ 1 + pprint ] each %>"
#! => "\"numbers: \" write 3 [ 1 + pprint ] each" #! => "\"numbers: \" write 3 [ 1 + pprint ] each"
[ embedded>factor ] f make ; [ embedded>factor ] [ ] make ;
: eval-embedded ( string -- ) parse-embedded call ; : eval-embedded ( string -- ) parse-embedded call ;
: open-embedded-file ( filename -- str )
<file-reader> lines "\n" join ;
: with-embedded-file ( filename quot -- ) : with-embedded-file ( filename quot -- )
[ [
over file set ! so that reload works properly over file set ! so that reload works properly
>r <file-reader> lines "\n" join r> call >r <file-reader> contents r> call
] with-scope ; ] with-scope ;
: parse-embedded-file ( filename -- quot ) : parse-embedded-file ( filename -- quot )
@ -68,3 +65,7 @@ USING: sequences kernel parser math namespaces io lists ;
: run-embedded-file ( filename -- ) : run-embedded-file ( filename -- )
[ eval-embedded ] with-embedded-file ; [ eval-embedded ] with-embedded-file ;
: embedded-convert ( infile outfile -- )
<file-writer> [ run-embedded-file ] with-stream ;
PROVIDE: embedded ;

81
contrib/factor.el Normal file
View File

@ -0,0 +1,81 @@
(require 'comint)
(define-derived-mode factor-listener-mode comint-mode "Factor listener"
(setq comint-prompt-regexp "^ "))
(defvar factor-binary "/scratch/factor-darcs/repos/Factor/f")
(defvar factor-image "/scratch/factor-darcs/repos/Factor/factor.image")
(defun factor-server ()
(interactive)
(make-comint "factor-server" factor-binary nil factor-image "-shell=tty")
(comint-send-string "*factor-server*" "USE: jedit telnet\n"))
;; (defun factor-listener ()
;; (interactive)
;; (factor-server)
;; (sleep-for 0 500)
;; (switch-to-buffer (make-comint "factor-listener" '("localhost" . 9999)))
;; (rename-uniquely)
;; (factor-listener-mode))
(defun factor-listener ()
(interactive)
(factor-server)
(sleep-for 0 1000)
(if (get-buffer "*factor-listener*")
(save-excursion
(set-buffer "*factor-listener*")
(rename-uniquely)))
(switch-to-buffer (make-comint "factor-listener" '("localhost" . 9999)))
(factor-listener-mode))
(defun factor-listener-restart ()
(interactive)
(factor-server)
(sleep-for 0 1000)
(make-comint-in-buffer
"factor-listener" (current-buffer) '("localhost" . 9999)))
(defun load-factor-file (file-name)
(interactive "fLoad Factor file: ")
(comint-send-string nil (format "\"%s\" run-file\n" file-name)))
(defun factor-update-stack-buffer (&optional string)
(interactive)
(save-excursion
(set-buffer (get-buffer-create "*factor-stack*"))
(erase-buffer)
(comint-redirect-send-command-to-process
".s" "*factor-stack*" "*factor-listener*" nil)))
(defvar factor-update-stackp nil "*")
(defun factor-send-input ()
(interactive)
(comint-send-input)
(if factor-update-stackp
(progn (sleep-for 0 250) (factor-update-stack-buffer))))
(defun factor-synopsis ()
(interactive)
(message
(first
(comint-redirect-results-list-from-process
(get-buffer-process "*factor-listener*")
(format "\\ %s synopsis print" (thing-at-point 'symbol))
;; "[ ]*\\(.*\\)\n"
"\\(.*\\)\n"
1))))
(fset 'factor-comment-line "\C-a! ")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mode
;; syntax table
;; (push '("\\.factor\\'" . factor-mode) auto-mode-alist)
;; synopsis of word at point

347
contrib/factory/factory.factor
View File

@ -1,6 +1,6 @@
USING: kernel alien compiler namespaces generic math sequences hashtables io USING: kernel alien compiler namespaces generic math sequences hashtables io
arrays words prettyprint lists concurrency arrays words prettyprint concurrency process
process rectangle xlib x concurrent-widgets ; vars rectangle x11 x concurrent-widgets ;
IN: factory IN: factory
@ -15,6 +15,8 @@ DEFER: layout-frame
DEFER: mapped-windows DEFER: mapped-windows
DEFER: workspace-1 DEFER: workspace-2 DEFER: workspace-3 DEFER: workspace-4 DEFER: workspace-1 DEFER: workspace-2 DEFER: workspace-3 DEFER: workspace-4
DEFER: switch-to DEFER: switch-to
DEFER: update-title
DEFER: delete-frame
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -47,62 +49,91 @@ create-gc dup
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: MouseMask VARS: event frame push position ;
[ ButtonPressMask
ButtonReleaseMask
PointerMotionMask ] 0 [ execute bitor ] reduce ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: drag-mouse-loop ( push last quot -- push release ) : event-type ( -- type ) event> XAnyEvent-type ;
MouseMask mask-event XAnyEvent-type ! push last quot type
{ { [ dup MotionNotify = ]
[ drop 3dup call nip mouse-sensor swap drag-mouse-loop ] }
{ [ dup ButtonRelease = ]
[ drop 3dup nip f swap call 2drop
mouse-sensor ungrab-server CurrentTime ungrab-pointer flush-dpy ] }
{ [ t ]
[ drop "drag-mouse-loop ignoring event" print flush drag-mouse-loop ] }
} cond ;
: drag-mouse ( quot -- push release )
MouseMask grab-pointer grab-server mouse-sensor f rot drag-mouse-loop ;
: drag-mouse% [ drag-mouse ] with-window-object ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ((draw-move-outline)) ( a b - ) : drag-offset ( -- offset ) position> push> v- ;
swap v- window-position v+ window-size <rect> root get draw-rect+ ;
: (draw-move-outline) ( push last -- )
dupd dup [ ((draw-move-outline)) ] [ 2drop ] if
mouse-sensor ((draw-move-outline)) flush-dpy ;
: draw-move-outline ( push last -- )
drag-gc get [ (draw-move-outline) ] with-gcontext ;
: drag-move-window ( -- )
[ draw-move-outline ] drag-mouse swap v- window-position v+ move-window ;
: drag-move-window% [ drag-move-window raise-window ] with-window-object ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ((draw-resize-outline)) ( bottom-right -- ) : draw-rubber-band ( <rect> -- )
window-position v- window-position swap <rect> root get draw-rect+ ; root get [ drag-gc get [ draw-rect ] with-gcontext ] with-win ;
: (draw-resize-outline) ( push last -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
nip dup [ ((draw-resize-outline)) ] [ drop ] if ! drag-move-frame
mouse-sensor ((draw-resize-outline)) flush-dpy ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-resize-outline ( push last -- ) : draw-frame-outline ( -- )
drag-gc get [ (draw-resize-outline) ] with-gcontext ; drag-offset frame> window-position% v+ frame> window-size% <rect>
draw-rubber-band ;
: drag-resize-window ( -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ draw-resize-outline ] drag-mouse nip window-position v- resize-window ;
: drag-resize-window% [ drag-resize-window ] with-window-object ; : drag-move-frame-loop ( -- )
next-event >event
{ { [ event-type MotionNotify = ]
[ draw-frame-outline
event> XMotionEvent-root-position >position
draw-frame-outline
drag-move-frame-loop ] }
{ [ event-type ButtonRelease = ]
[ draw-frame-outline
drag-offset frame> window-position% v+ frame> move-window% ] }
{ [ t ]
[ "[drag-move-frame-loop] Ignoring event type: " write
event-type event-type>name write terpri flush
drag-move-frame-loop ] } }
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: drag-move-frame ( event <wm-frame> -- )
[ >frame >event
event> XButtonEvent-root-position >push
event> XButtonEvent-root-position >position
draw-frame-outline
drag-move-frame-loop
frame> raise-window% ]
with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! drag-size-frame
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-size-outline ( -- )
frame> window-position% position> over v- <rect> draw-rubber-band ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: drag-size-frame-loop ( -- )
next-event >event
{ { [ event-type MotionNotify = ]
[ draw-size-outline
event> XMotionEvent-root-position >position
draw-size-outline
drag-size-frame-loop ] }
{ [ event-type ButtonRelease = ]
[ draw-size-outline
position> frame> window-position% v- frame> resize-window%
frame> layout-frame ] }
{ [ t ]
[ "[drag-size-frame-loop] ignoring event" print flush
drag-size-frame-loop ] } }
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: drag-size-frame ( event <wm-frame> -- )
[ >frame >event
event> XButtonEvent-root-position >position
draw-size-outline
drag-size-frame-loop ]
with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -121,32 +152,24 @@ GENERIC: execute-size-request
TUPLE: wm-root ; TUPLE: wm-root ;
: create-wm-root ( window -- ) : wm-root-mask ( -- mask )
>r dpy get r> <window> ! <window> [ SubstructureRedirectMask
<wm-root> ! <window> <wm-root> SubstructureNotifyMask
[ set-delegate ] keep ! <wm-root> ButtonPressMask
[ add-to-window-table ] keep ! <wm-root> ButtonReleaseMask
KeyPressMask
KeyReleaseMask ] bitmask ;
[ SubstructureRedirectMask : create-wm-root ( window-id -- <wm-root> )
SubstructureNotifyMask dpy get swap <window> <wm-root> tuck set-delegate dup add-to-window-table
ButtonPressMask wm-root-mask over select-input% ;
ButtonReleaseMask
KeyPressMask
KeyReleaseMask ] 0 [ execute bitor ] reduce ! <wm-frame> mask
over select-input% ; ! <wm-frame>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! M: wm-root handle-map-request-event ! M: wm-root handle-map-request-event
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: id>obj ( id -- obj ) : id>obj ( id -- obj )
dup ! id id dup window-table get hash dup [ nip ] [ drop dpy get swap <window> ] if ;
window-table get hash ! id obj-or-f
dup
[ swap drop ]
[ drop >r dpy get r> <window> ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -253,6 +276,12 @@ M: wm-root handle-configure-request-event ( event wm-root -- )
! M: wm-root handle-button-press-event ! M: wm-root handle-button-press-event
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: XButtonEvent-position ( event -- { x y } )
dup XButtonEvent-x swap XButtonEvent-y 2array ;
: XButtonEvent-root-position ( event -- { x y } )
dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
M: wm-root handle-button-press-event ( event wm-root -- ) M: wm-root handle-button-press-event ( event wm-root -- )
drop ! event drop ! event
@ -281,36 +310,39 @@ M: wm-root handle-button-press-event ( event wm-root -- )
! M: wm-root handle-key-press-event ! M: wm-root handle-key-press-event
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: f1-keycode 67 f1-keycode set-global : True 1 ;
SYMBOL: f2-keycode 68 f2-keycode set-global : False 0 ;
SYMBOL: f3-keycode 69 f3-keycode set-global
SYMBOL: f4-keycode 70 f4-keycode set-global : f1-keycode ( -- code ) 67 ;
: f2-keycode ( -- code ) 68 ;
: f3-keycode ( -- code ) 69 ;
: f4-keycode ( -- code ) 70 ;
: grab-keys ( -- ) : grab-keys ( -- )
f1-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key f1-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
f2-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key f2-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
f3-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key f3-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
f4-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key ; f4-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key ;
M: wm-root handle-key-press-event ( event wm-root -- ) M: wm-root handle-key-press-event ( event wm-root -- )
drop drop
{ { [ dup XKeyEvent-keycode f1-keycode get = ] [ workspace-1 get switch-to ] } { { [ dup XKeyEvent-keycode f1-keycode = ] [ workspace-1 get switch-to ] }
{ [ dup XKeyEvent-keycode f2-keycode get = ] [ workspace-2 get switch-to ] } { [ dup XKeyEvent-keycode f2-keycode = ] [ workspace-2 get switch-to ] }
{ [ dup XKeyEvent-keycode f3-keycode get = ] [ workspace-3 get switch-to ] } { [ dup XKeyEvent-keycode f3-keycode = ] [ workspace-3 get switch-to ] }
{ [ dup XKeyEvent-keycode f4-keycode get = ] [ workspace-4 get switch-to ] } { [ dup XKeyEvent-keycode f4-keycode = ] [ workspace-4 get switch-to ] }
{ [ t ] [ "wm-root ignoring key press" print drop ] } } cond ; { [ t ] [ "wm-root ignoring key press" print drop ] } } cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: wm-child ; TUPLE: wm-child ;
: create-wm-child ( id -- <wm-child> ) : create-wm-child ( window-id -- <wm-child> )
>r dpy get r> <window> <wm-child> ! <window> <wm-child> dpy get swap <window> <wm-child> tuck set-delegate dup add-to-window-table ;
[ set-delegate ] keep
[ add-to-window-table ] keep ;
M: wm-child handle-property-event ( child event -- ) M: wm-child handle-property-event ( event <wm-child> -- )
"A <wm-child> received a property event" print flush drop drop ; "A <wm-child> received a property event" print flush
nip
window-parent% window-table get hash dup [ update-title ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -318,68 +350,62 @@ TUPLE: wm-frame child ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: create-wm-frame ( child -- <wm-frame> ) : wm-frame-mask ( -- mask )
>r create-window-object r> ! <window> child [ SubstructureRedirectMask
<wm-frame> ! <window> <wm-frame> SubstructureNotifyMask
[ set-delegate ] keep ! <wm-frame> ExposureMask
[ add-to-window-table ] keep ! <wm-frame> ButtonPressMask
ButtonReleaseMask
[ SubstructureRedirectMask PointerMotionMask
SubstructureNotifyMask EnterWindowMask ] bitmask ;
ExposureMask
ButtonPressMask
ButtonReleaseMask
EnterWindowMask ] 0 [ execute bitor ] reduce ! <wm-frame> mask
over select-input% ; ! <wm-frame> : create-wm-frame ( <wm-child> -- <wm-frame> )
<wm-frame> create-window-object over set-delegate dup add-to-window-table
wm-frame-mask over select-input% ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: update-title ( <wm-frame> -- )
dup clear-window%
{ 5 1 } swap dup wm-frame-child fetch-name% swap draw-string-top-left% ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VARS: child frame button ;
: manage-window ( window -- ) : manage-window ( window -- )
flush-dpy flush-dpy grab-server flush-dpy
grab-server create-wm-child dup create-wm-frame
flush-dpy [ child frame ]
[ "cornflowerblue" lookup-color frame> set-window-background%
create-wm-child ! child child> add-to-save-set%
create-wm-frame ! frame child> window-position% frame> move-window%
0 child> set-window-border-width%
dup "cornflowerblue" lookup-color swap set-window-background% frame> child> reparent-window%
child> window-size% { 10 20 } v+ frame> resize-window%
dup wm-frame-child add-to-save-set% ! frame { 5 15 } child> move-window%
"" frame> [ delete-frame ] curry create-button
dup wm-frame-child window-position% ! frame position [ button ]
over ! frame position frame [ frame> button> reparent-window%
move-window% { 9 9 } button> resize-window%
frame> window-width% 9 - 5 - 3 2array button> move-window%
dup wm-frame-child 0 swap set-window-border-width% NorthEastGravity button> set-window-gravity%
dup dup wm-frame-child ! frame frame child black-pixel get button> set-window-background% ]
reparent-window% let
PropertyChangeMask child> select-input%
dup wm-frame-child window-size% ! frame child-size frame> map-subwindows%
{ 20 20 } v+ ! frame child-size+ frame> map-window%
over ! frame child-size+ frame frame> update-title
resize-window% flush-dpy 0 sync-dpy ungrab-server flush-dpy ]
let ;
dup wm-frame-child { 10 10 } swap move-window%
dup map-window%
dup map-subwindows%
dup wm-frame-child PropertyChangeMask swap select-input%
flush-dpy
0 sync-dpy
ungrab-server
flush-dpy ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: destroy-window-event-match? ( event <wm-frame> -- ? ) : destroy-window-event-match? ( event <wm-frame> -- ? )
window-id swap XDestroyWindowEvent-window = ; window-id swap XDestroyWindowEvent-window = ;
M: wm-frame handle-destroy-window-event ( event <wm-frame> -- ) M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
2dup destroy-window-event-match? 2dup destroy-window-event-match? [ destroy-window% drop ] [ 2drop ] if ;
[ destroy-window% drop ] [ drop drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -393,7 +419,7 @@ M: wm-frame handle-map-request-event ( event <wm-frame> -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: map-event-match? ( event <wm-frame> -- ? ) : map-event-match? ( event <wm-frame> -- ? )
window-id swap XMapEvent-window = ; window-id swap XMapEvent-window = ;
M: wm-frame handle-map-event ( event <wm-frame> -- ) M: wm-frame handle-map-event ( event <wm-frame> -- )
2dup map-event-match? 2dup map-event-match?
@ -442,7 +468,7 @@ M: wm-frame size-request-size ( event frame -- size )
dup wm-frame-child -rot size-request-size swap resize-window% ; dup wm-frame-child -rot size-request-size swap resize-window% ;
: execute-size-request/frame ( event frame ) : execute-size-request/frame ( event frame )
dup -rot size-request-size { 20 20 } v+ swap resize-window% ; dup -rot size-request-size { 10 20 } v+ swap resize-window% ;
M: wm-frame execute-size-request ( event frame ) M: wm-frame execute-size-request ( event frame )
2dup execute-size-request/child execute-size-request/frame ; 2dup execute-size-request/child execute-size-request/frame ;
@ -464,14 +490,10 @@ M: wm-frame handle-unmap-event ( event frame )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: drag-move-frame ( frame -- ) drag-move-window% ;
: drag-resize-frame ( frame -- ) dup drag-resize-window% layout-frame ;
M: wm-frame handle-button-press-event ( event frame ) M: wm-frame handle-button-press-event ( event frame )
over XButtonEvent-button ! event frame button over XButtonEvent-button ! event frame button
{ { [ dup Button1 = ] [ drop nip drag-move-frame ] } { { [ dup Button1 = ] [ drop drag-move-frame ] }
{ [ dup Button2 = ] [ drop nip drag-resize-frame ] } { [ dup Button2 = ] [ drop drag-size-frame ] }
{ [ dup Button3 = ] [ drop nip unmap-window% ] } { [ dup Button3 = ] [ drop nip unmap-window% ] }
{ [ t ] [ drop drop drop ] } } { [ t ] [ drop drop drop ] } }
cond ; cond ;
@ -486,18 +508,30 @@ M: wm-frame handle-enter-window-event ( event frame )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: wm-frame handle-property-event ( event frame ) M: wm-frame handle-property-event ( event frame -- )
"Inside handle-property-event" print flush drop drop ; "Inside handle-property-event" print flush 2drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: layout-frame ( frame -- ) M: wm-frame handle-expose-event ( event frame -- )
dup wm-frame-child { 10 10 } swap move-window% nip dup clear-window% update-title ;
dup wm-frame-child ! frame child
over window-size% ! frame child size ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ 20 20 } v- ! frame child child-size
swap resize-window% ! frame : frame-position-child ( frame -- ) wm-frame-child { 5 15 } swap move-window% ;
drop ;
: frame-fit-child ( frame -- )
dup window-size% { 10 20 } v- swap wm-frame-child resize-window% ;
: layout-frame ( frame -- ) dup frame-position-child frame-fit-child ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: WM_PROTOCOLS
SYMBOL: WM_DELETE_WINDOW
: delete-frame ( frame -- ) wm-frame-child window-id
[ WM_PROTOCOLS get WM_DELETE_WINDOW get send-client-message ] with-win ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Workspaces ! Workspaces
@ -562,7 +596,8 @@ SYMBOL: window-list
: setup-window-list ( -- ) : setup-window-list ( -- )
create-menu window-list set-global create-menu window-list set-global
"black" lookup-color window-list get set-window-background% ; "black" lookup-color window-list get set-window-background%
300 window-list get set-menu-item-width ;
: not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ; : not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ;
@ -574,7 +609,7 @@ SYMBOL: window-list
[ ] [ drop "*untitled*" ] if ! window-list frame name [ ] [ drop "*untitled*" ] if ! window-list frame name
swap ! window-list name frame swap ! window-list name frame
[ map-window% ] ! window-list name frame [ map-window% ] [ map-window% ] ! window-list name frame [ map-window% ]
cons ! window-list name action curry ! window-list name action
pick ! window-list name action window-list pick ! window-list name action window-list
add-popup-menu-item ; add-popup-menu-item ;
@ -607,8 +642,16 @@ SYMBOL: window-list
root get [ black-pixel get set-window-background clear-window ] with-win root get [ black-pixel get set-window-background clear-window ] with-win
root get create-wm-root root get create-wm-root
root get [ grab-keys ] with-win root get [ grab-keys ] with-win
"WM_PROTOCOLS" False intern-atom WM_PROTOCOLS set
"WM_DELETE_WINDOW" False intern-atom WM_DELETE_WINDOW set
"cornflowerblue" lookup-color menu-enter-color set
"white" lookup-color menu-leave-color set
setup-root-menu setup-root-menu
setup-window-list setup-window-list
setup-workspace-menu setup-workspace-menu
manage-existing-windows manage-existing-windows
[ concurrent-event-loop ] spawn ; [ concurrent-event-loop ] spawn ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
IN: shells USE: listener : factory f start-factory listener ;

3
contrib/factory/load.factor Normal file
View File

@ -0,0 +1,3 @@
REQUIRES: process concurrency x11 vars ;
PROVIDE: factory { "factory.factor" } ;

19
contrib/gap-buffer/circular-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: kernel test sequences sequences-internals circular ;
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap circular@ drop ] unit-test
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap circular@ drop ] unit-test
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
[ "test" ] [ "test" <circular> "" like ] unit-test
[ "test" <circular> 5 swap nth ] unit-test-fails
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> f like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start f like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start f like ] unit-test
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth "" like ] unit-test
[ "foo" <circular> CHAR: b 3 rot set-nth ] unit-test-fails
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe "" like ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth "" like ] unit-test

25
contrib/gap-buffer/circular.factor Normal file
View File

@ -0,0 +1,25 @@
USING: kernel sequences math generic sequences-internals ;
IN: circular
! a circular sequence wraps another sequence, but begins at an arbitrary
! element in the underlying sequence.
TUPLE: circular start ;
C: circular ( seq circular -- circular )
0 over set-circular-start [ set-delegate ] keep ;
: circular@ ( n circular -- n seq )
[ tuck circular-start + swap length mod ] keep delegate ;
M: circular nth ( n seq -- elt ) bounds-check circular@ nth ;
M: circular nth-unsafe ( n seq -- elt ) circular@ nth-unsafe ;
M: circular set-nth ( elt n seq -- ) bounds-check circular@ set-nth ;
M: circular set-nth-unsafe ( elt n seq -- ) circular@ set-nth-unsafe ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
[ circular@ drop ] keep set-circular-start ;

41
contrib/gap-buffer/gap-buffer-tests.factor Normal file
View File

@ -0,0 +1,41 @@
USING: kernel sequences test gap-buffer strings math ;
IN: gb-tests
! test copy-elements
[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
! test sequence protocol (like, length, nth, set-nth)
[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
! test move-gap-back-inside
[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
! test move-gap-forward-inside
[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
! test move-gap-back-around
[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
! test move-gap-forward-around
[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
! test changing buffer contents
[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
! test inserting multiple elements in different places. buffer should grow
[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
! test deleting elements. buffer should shrink
[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
! more testing of nth and set-nth
[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
! test stack/queue operations
[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test

241
contrib/gap-buffer/gap-buffer.factor Normal file
View File

@ -0,0 +1,241 @@
! gap buffer -- Alex Chapman (chapman.alex@gmail.com)
! largely influenced by Strandh and Villeneuve's Flexichain
! for a good introduction see:
! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
USING: kernel arrays sequences sequences-internals circular math generic ;
IN: gap-buffer
! gap-start -- the first element of the gap
! gap-end -- the first element after the gap
! expand-factor -- should be > 1
! min-size -- < 5 is not sensible
TUPLE: gb
gap-start
gap-end
expand-factor
min-size ;
: required-space ( n gb -- n )
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
C: gb ( seq gb -- gb )
5 over set-gb-min-size
1.5 over set-gb-expand-factor
[ >r length r> set-gb-gap-start ] 2keep
[ swap length over required-space swap set-gb-gap-end ] 2keep
[
over length over required-space rot { } like resize-array <circular> swap set-delegate
] keep ;
M: gb like ( seq gb -- seq ) drop <gb> ;
: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
: buffer-length ( gb -- n ) delegate length ;
M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
: position>index ( n gb -- n )
2dup gb-gap-start >= [
gap-length +
] [ drop ] if ;
: gb@ ( n gb -- n seq ) [ position>index ] keep delegate ;
M: gb nth ( n gb -- elt ) bounds-check gb@ nth-unsafe ;
M: gb nth-unsafe ( n gb -- elt ) gb@ nth-unsafe ;
M: gb set-nth ( elt n seq -- ) bounds-check gb@ set-nth-unsafe ;
M: gb set-nth-unsafe ( elt n seq -- ) gb@ set-nth-unsafe ;
! ------------- moving the gap -------------------------------
: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
: copy-elements-back ( dst start seq n -- )
dup 0 > [
>r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
] [ 3drop drop ] if ;
: copy-elements-forward ( dst start seq n -- )
dup 0 > [
>r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
] [ 3drop drop ] if ;
: copy-elements ( dst start end seq -- )
pick pick > [
>r dupd - r> swap copy-elements-forward
] [
>r over - r> swap copy-elements-back
] if ;
! the gap can be moved either forward or back. Moving the gap 'inside' means
! moving elements across the gap. Moving the gap 'around' means changing the
! start of the circular buffer to avoid moving as many elements.
! We decide which method (inside or around) to pick based on the number of
! elements that will need to be moved. We always try to move as few elements as
! possible.
: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
: move-gap-back-inside? ( i gb -- i gb ? )
#! is it cheaper to move the gap inside than around?
2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
: move-gap-forward-inside? ( i gb -- i gb ? )
#! is it cheaper to move the gap inside than around?
2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
: move-gap-forward-inside ( i gb -- )
[ dup gap-length neg swap gb-gap-end rot ] keep delegate copy-elements ;
: move-gap-back-inside ( i gb -- )
[ dup gap-length swap gb-gap-start 1- rot 1- ] keep delegate copy-elements ;
: move-gap-forward-around ( i gb -- )
0 over move-gap-back-inside [
dup buffer-length [
swap gap-length - neg swap
] keep
] keep [
delegate copy-elements
] keep dup gap-length swap delegate change-circular-start ;
: move-gap-back-around ( i gb -- )
dup buffer-length over move-gap-forward-inside [
length swap -1
] keep [
delegate copy-elements
] keep dup length swap delegate change-circular-start ;
: move-gap-forward ( i gb -- )
move-gap-forward-inside? [
move-gap-forward-inside
] [
move-gap-forward-around
] if ;
: move-gap-back ( i gb -- )
move-gap-back-inside? [
move-gap-back-inside
] [
move-gap-back-around
] if ;
: (move-gap) ( i gb -- )
move-gap? [
move-gap-forward? [
move-gap-forward
] [
move-gap-back
] if
] [ 2drop ] if ;
: fix-gap ( n gb -- )
2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
: move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
! ------------ resizing -------------------------------------
: enough-room? ( n gb -- ? )
#! is there enough room to add 'n' elements to gb?
tuck length + swap buffer-length <= ;
: set-new-gap-end ( array gb -- )
[ buffer-length swap length swap - ] keep
[ gb-gap-end + ] keep set-gb-gap-end ;
: after-gap ( gb -- gb )
dup gb-gap-end swap delegate tail ;
: before-gap ( gb -- gb )
dup gb-gap-start swap head ;
: copy-after-gap ( array gb -- )
#! copy everything after the gap in 'gb' into the end of 'array',
#! and change 'gb's gap-end to reflect the gap-end in 'array'
dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> copy-into ;
: copy-before-gap ( array gb -- )
#! copy everything before the gap in 'gb' into the start of 'array'
before-gap 0 -rot copy-into ; ! gap start doesn't change
: resize-buffer ( gb new-size -- )
f <array> swap 2dup copy-before-gap 2dup copy-after-gap
>r <circular> r> set-delegate ;
: decrease-buffer-size ( gb -- )
#! the gap is too big, so resize to something sensible
dup length over required-space resize-buffer ;
: increase-buffer-size ( n gb -- )
#! increase the buffer to fit at least 'n' more elements
tuck length + over required-space resize-buffer ;
: gb-too-big? ( gb -- ? )
dup buffer-length over gb-min-size > [
dup length over buffer-length rot gb-expand-factor sq / <
] [ drop f ] if ;
: maybe-decrease ( gb -- )
dup gb-too-big? [
decrease-buffer-size
] [ drop ] if ;
: ensure-room ( n gb -- )
#! ensure that ther will be enough room for 'n' more elements
2dup enough-room? [ 2drop ] [
increase-buffer-size
] if ;
! ------- editing operations ---------------
G: insert* 2 standard-combination ;
: prepare-insert ( seq position gb -- seq gb )
tuck move-gap over length over ensure-room ;
: insert-elements ( seq gb -- )
dup gb-gap-start swap delegate rot copy-into ;
: increment-gap-start ( gb n -- )
over gb-gap-start + swap set-gb-gap-start ;
M: sequence insert* ( seq position gb -- )
prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ;
M: object insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
: delete* ( position gb -- )
tuck move-gap dup gb-gap-end 1+ over set-gb-gap-end maybe-decrease ;
! -------- stack/queue operations -----------
: push-start ( obj gb -- ) 0 swap insert* ;
: push-end ( obj gb -- ) [ length ] keep insert* ;
: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
: pop-start ( gb -- elem ) 0 swap pop-elem ;
: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
: rotate ( n gb -- )
dup length 1 > [
swap dup 0 > [
[ dup [ pop-end ] keep push-start ]
] [
neg [ dup [ pop-start ] keep push-end ]
] if times drop
] [ 2drop ] if ;

3
contrib/gap-buffer/load.factor Normal file
View File

@ -0,0 +1,3 @@
PROVIDE: gap-buffer
{ "circular.factor" "gap-buffer.factor" }
{ "circular-tests.factor" "gap-buffer-tests.factor" } ;

26
contrib/hexdump/hexdump.factor Normal file
View File

@ -0,0 +1,26 @@
USING: io kernel math namespaces prettyprint sequences strings ;
IN: hexdump-internals
: .header ( len -- )
"Length: " write dup unparse write ", " write >hex write "h" write terpri ;
: .offset ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
: .h-pad ( digit -- ) >hex 2 CHAR: 0 pad-left write ;
: .line ( str n -- )
.offset [ [ .h-pad " " write ] each ] keep
16 over length - [ " " write ] times
[ dup printable? [ drop CHAR: . ] unless ch>string write ] each
terpri ;
IN: hexdump
: hexdump ( str -- str )
#! Write hexdump to a string
[
dup length .header
16 swap group dup length [ .line ] 2each
] string-out ;
: .hexdump ( str -- )
#! Print hexdump
hexdump write ;

5
contrib/hexdump/load.factor Normal file
View File

@ -0,0 +1,5 @@
PROVIDE: hexdump {
"hexdump.factor"
} {
"test/hexdump.factor"
} ;

8
contrib/hexdump/test/hexdump.factor Normal file
View File

@ -0,0 +1,8 @@
IN: temporary
USING: hexdump kernel sequences test ;
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test

106
contrib/httpd/browser-responder.factor
View File

@ -1,64 +1,41 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! ! See http://factorcode.org/license.txt for BSD license.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! A Smalltalk-like browser that runs in the httpd server using
! cont-responder facilities.
!
IN: browser-responder IN: browser-responder
USING: cont-responder hashtables help html io kernel lists USING: hashtables help html httpd io kernel memory namespaces
memory namespaces prettyprint sequences words xml ; prettyprint sequences words xml ;
: option ( current text -- ) : option ( current text -- )
#! Output the HTML option tag for the given text. If #! Output the HTML option tag for the given text. If
#! it is equal to the current string, make the option selected. #! it is equal to the current string, make the option selected.
2dup = [ <option tuck = [ "yes" =selected ] when option>
"<option selected>" write chars>entities write
] [ </option> ;
"<option>" write
] if
chars>entities write
"</option>\n" write drop ;
: vocab-list ( vocab -- ) : options ( current seq -- ) [ option ] each-with ;
#! Write out the HTML for the list of vocabularies. Make the currently
#! selected vocab be 'vocab'. : list ( current seq name -- )
<select "vocab" =name "width: 200px; " =style "20" =size "document.forms.main.submit()" =onchange select> <select =name "width: 200px;" =style "20" =size "document.forms.main.submit()" =onchange select>
vocabs [ over swap option ] each drop options
</select> ; </select> ;
: word-list ( vocab word -- ) : current-vocab ( -- string )
#! Write out the HTML for the list of words in a vocabulary. Make the 'word' item "vocab" query-param [ "kernel" ] unless* ;
#! the currently selected option.
<select "word" =name "width: 200px; " =style "20" =size "document.forms.main.submit()" =onchange select>
swap words natural-sort
[ word-name over swap option ] each drop
</select> ;
: word-source ( vocab word -- ) : current-word ( -- word )
"word" query-param "vocab" query-param lookup ;
: vocab-list ( -- )
current-vocab vocabs "vocab" list ;
: word-list ( -- )
current-word [ word-name ] [ f ] if*
current-vocab vocab hash-keys natural-sort "word" list ;
: word-source ( -- )
#! Write the source for the given word from the vocab as HTML. #! Write the source for the given word from the vocab as HTML.
swap lookup [ [ (help) ] with-html-stream ] when* ; current-word [ [ see-help ] with-html-stream ] when* ;
: browser-body ( vocab word -- ) : browser-body ( -- )
#! Write out the HTML for the body of the main browser page. #! Write out the HTML for the body of the main browser page.
<table "100%" =width table> <table "100%" =width table>
<tr> <tr>
@ -67,25 +44,24 @@ memory namespaces prettyprint sequences words xml ;
<th> "Documentation" write </th> <th> "Documentation" write </th>
</tr> </tr>
<tr> <tr>
<td "top" =valign "width: 200px;" =style td> over vocab-list </td> <td "top" =valign "width: 200px;" =style td>
<td "top" =valign "width: 200px;" =style td> 2dup word-list </td> vocab-list
</td>
<td "top" =valign "width: 200px;" =style td>
word-list
</td>
<td "top" =valign td> word-source </td> <td "top" =valign td> word-source </td>
</tr> </tr>
</table> ; </table> ;
: browser-title ( vocab word -- ) : browser-title ( -- str )
#! Output the HTML title for the browser. current-word
[ "Factor Browser - " % swap % " - " % % ] "" make ; [ synopsis ] [ "IN: " current-vocab append ] if* ;
: browse ( vocab word -- )
#! Display a Smalltalk like browser for exploring words.
[
2dup browser-title [
<form "main" =name "" =action "get" =method form> browser-body </form>
] html-document
] show-final ;
: browser-responder ( -- ) : browser-responder ( -- )
#! Start the Smalltalk-like browser. #! Display a Smalltalk like browser for exploring words.
"vocab" "query" get hash [ "browser-responder" ] unless* serving-html browser-title [
"word" "query" get hash [ "browse" ] unless* browse ; <form "main" =name "" =action "get" =method form>
browser-body
</form>
] html-document ;

124
contrib/httpd/callback-responder.factor Normal file
View File

@ -0,0 +1,124 @@
! Copyright (C) 2004 Chris Double.
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: callback-responder
USING: hashtables html http httpd io kernel math namespaces
sequences ;
#! Name of the variable holding the continuation used to exit
#! back to the httpd responder.
SYMBOL: exit-continuation
#! Tuple to hold global request data. This gets passed to
#! the continuation when resumed so it can restore things
#! like 'stdio' so it writes to the correct socket.
TUPLE: request stream exitcc method url raw-query query header response ;
C: request ( -- request )
[ stdio get swap set-request-stream ] keep
[ "method" get swap set-request-method ] keep
[ "request" get swap set-request-url ] keep
[ "raw-query" get swap set-request-raw-query ] keep
[ "query" get swap set-request-query ] keep
[ "header" get swap set-request-header ] keep
[ "response" get swap set-request-response ] keep
[ exit-continuation get swap set-request-exitcc ] keep ;
: restore-request ( -- )
request get
dup request-stream stdio set
dup request-method "method" set
dup request-raw-query "raw-query" set
dup request-query "query" set
dup request-header "header" set
dup request-response "response" set
request-exitcc exit-continuation set ;
: update-request ( request new-request -- )
[ request-stream over set-request-stream ] keep
[ request-method over set-request-method ] keep
[ request-url over set-request-url ] keep
[ request-raw-query over set-request-raw-query ] keep
[ request-query over set-request-query ] keep
[ request-header over set-request-header ] keep
[ request-response over set-request-response ] keep
request-exitcc swap set-request-exitcc ;
: with-exit-continuation ( quot -- )
#! Call the quotation with the variable exit-continuation bound
#! such that when the exit continuation is called, computation
#! will resume from the end of this 'with-exit-continuation' call.
[
exit-continuation set call exit-continuation get continue
] callcc0 drop ;
: expiry-timeout ( -- ms ) 900 1000 * ;
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
: callback-table ( -- <hashtable> )
#! Return the global table of continuations
\ callback-table get-global ;
: reset-callback-table ( -- )
#! Create the initial global table
H{ } clone \ callback-table set-global ;
reset-callback-table
#! Tuple for holding data related to a callback.
TUPLE: item quot expire? request id time-added ;
C: item ( quot data data-quot expire? id -- item )
millis over set-item-time-added
[ set-item-id ] keep
[ set-item-request ] keep
[ set-item-expire? ] keep
[ set-item-quot ] keep ;
: expired? ( item -- ? )
#! Return true if the callback item is expirable
#! and has expired (ie. was added to the table more than
#! timeout milliseconds ago).
[ item-time-added expiry-timeout + millis < ] keep
item-expire? and ;
: expire-callbacks ( -- )
#! Expire all continuations in the continuation table
#! if they are 'timeout-seconds' old (ie. were added
#! more than 'timeout-seconds' ago.
callback-table clone [
expired? [ callback-table remove-hash ] [ drop ] if
] hash-each ;
: id>url ( id -- string )
#! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML.
"/responder/callback/?id=" swap url-encode append ;
: register-callback ( quot expire? -- url )
#! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true.
request get get-random-id [ <item> ] keep
[ callback-table set-hash ] keep
id>url ;
: register-html-callback ( quot expire? -- url )
>r [ serving-html ] swap append r> register-callback ;
: callback-responder ( -- )
expire-callbacks
"id" query-param callback-table hash [
[
dup item-request [
<request> update-request
] when*
item-quot call
exit-continuation get continue
] with-exit-continuation drop
] [
"404 Callback not available" httpd-error
] if* ;

301
contrib/httpd/cont-responder.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: http httpd math namespaces io USING: http httpd math namespaces io strings kernel html hashtables
lists strings kernel html hashtables parser generic sequences callback-responder ;
parser generic sequences ;
IN: cont-responder IN: cont-responder
#! Used inside the session state of responders to indicate whether the #! Used inside the session state of responders to indicate whether the
@ -11,176 +10,11 @@ IN: cont-responder
#! true after each request. #! true after each request.
SYMBOL: post-refresh-get? SYMBOL: post-refresh-get?
: expiry-timeout ( -- timeout-seconds )
#! Number of seconds to timeout continuations in
#! continuation table. This value will need to be
#! tuned. I leave it at 24 hours but it can be
#! higher/lower as needed. Default to 15 minutes for
#! testing.
900 ;
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
SYMBOL: table
: continuation-table ( -- <hashtable> )
#! Return the global table of continuations
table get-global ;
: reset-continuation-table ( -- )
#! Create the initial global table
continuation-table clear-hash ;
H{ } clone table set-global
#! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ;
: continuation-item ( expire? quot id -- <item> )
#! A continuation item is the actual item stored
#! in the continuation table. It contains the id,
#! quotation/continuation, time added, etc. If
#! expire? is true then the continuation will
#! be expired after a certain amount of time.
millis <item> ;
: seconds>millis ( seconds -- millis )
#! Convert a number of seconds to milliseconds
1000 * ;
: expired? ( timeout-seconds <item> -- bool )
#! Return true if the continuation item is expirable
#! and has expired (ie. was added to the table more than
#! timeout milliseconds ago).
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
: expire-continuations ( timeout-seconds -- )
#! Expire all continuations in the continuation table
#! if they are 'timeout-seconds' old (ie. were added
#! more than 'timeout-seconds' ago.
continuation-table clone [
swapd expired? [
continuation-table remove-hash
] [
drop
] if
] hash-each-with ;
: expirable ( quot -- t quot )
#! Set the stack up for a register-continuation call
#! so that the given quotation is registered that it can
#! be expired.
t swap ;
: permanent ( quot -- f quot )
#! Set the stack up for a register-continuation call
#! so that the given quotation is never expired after
#! registration.
f swap ;
: register-continuation ( expire? quot -- id )
#! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true.
get-random-id
[ continuation-item ] keep ( item id -- )
[ continuation-table set-hash ] keep ;
: register-continuation* ( expire? quots -- id )
#! Like register-continuation but registers a quotation
#! that will call all quotations in the list, in the order given.
concat register-continuation ;
: get-continuation-item ( id -- <item> )
#! Get the continuation item associated with the id.
continuation-table hash ;
: id>url ( id -- string )
#! Convert the continuation id to an URL suitable for
#! embedding in an HREF or other HTML.
url-encode "?id=" swap append ;
DEFER: show-final
DEFER: show
TUPLE: resume value stdio ;
: (expired-page-handler) ( alist -- )
#! Display a page has expired message.
#! TODO: Need to handle this better to enable
#! returning back to root continuation.
<html>
<body>
<p> "This page has expired." write </p>
</body>
</html> flush ;
: expired-page-handler ( alist -- )
[ (expired-page-handler) ] show-final ;
: >callable ( quot|interp|f -- interp ) : >callable ( quot|interp|f -- interp )
dup continuation? [ dup continuation? [
[ continue-with ] cons [ continue ] curry
] when ; ] when ;
: get-registered-continuation ( id -- cont )
#! Return the continuation or quotation
#! associated with the given id.
#! TODO: handle expired pages better.
expiry-timeout expire-continuations
get-continuation-item [
item-quot
] [
[ (expired-page-handler) ]
] if* >callable ;
: resume-continuation ( resumed-data id -- )
#! Call the continuation associated with the given id,
#! with 'value' on the top of the stack.
get-registered-continuation call ;
#! Name of the variable holding the continuation used to exit
#! back to the httpd responder, returning any generated HTML.
SYMBOL: exit-cc
: exit-continuation ( -- exit )
#! Get the current exit continuation
exit-cc get ;
: call-exit-continuation ( value -- )
#! Call the exit continuation, passing it the given value on the
#! top of the stack.
exit-cc get continue-with ;
: with-exit-continuation ( quot -- )
#! Call the quotation with the variable exit-cc bound such that when
#! the exit continuation is called, computation will resume from the
#! end of this 'with-exit-continuation' call, with the value passed
#! to the exit continuation on the top of the stack.
[ exit-cc set call f call-exit-continuation ] callcc1 nip ;
#! Name of variable holding the 'callback' continuation, used for
#! returning back to previous 'show' calls.
SYMBOL: callback-cc
: store-callback-cc ( -- )
#! Store the current continuation in the variable 'callback-cc'
#! so it can be returned to later by callbacks. Note that it
#! recalls itself when the continuation is called to ensure that
#! it resets its value back to the most recent show call.
[ ( 0 -- )
[ ( 0 1 -- )
callback-cc set ( 0 -- )
stdio get swap continue-with
] callcc1
nip
dup resume-stdio stdio set
resume-value call
store-callback-cc stdio get
] callcc1 stdio set ;
: forward-to-url ( url -- ) : forward-to-url ( url -- )
#! When executed inside a 'show' call, this will force a #! When executed inside a 'show' call, this will force a
#! HTTP 302 to occur to instruct the browser to forward to #! HTTP 302 to occur to instruct the browser to forward to
@ -188,7 +22,7 @@ SYMBOL: callback-cc
[ [
"HTTP/1.1 302 Document Moved\nLocation: " % % "HTTP/1.1 302 Document Moved\nLocation: " % %
"\nContent-Length: 0\nContent-Type: text/plain\n\n" % "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
] "" make write "" call-exit-continuation ; ] "" make write exit-continuation get continue ;
: forward-to-id ( id -- ) : forward-to-id ( id -- )
#! When executed inside a 'show' call, this will force a #! When executed inside a 'show' call, this will force a
@ -196,50 +30,68 @@ SYMBOL: callback-cc
#! the request URL. #! the request URL.
>r "request" get r> id>url append forward-to-url ; >r "request" get r> id>url append forward-to-url ;
: redirect-to-here ( -- ) SYMBOL: current-show
#! Force a redirect to the client browser so that the browser
#! goes to the current point in the code. This forces an URL
#! change on the browser so that refreshing that URL will
#! immediately run from this code point. This prevents the
#! "this request will issue a POST" warning from the browser
#! and prevents re-running the previous POST logic. This is
#! known as the 'post-refresh-get' pattern.
post-refresh-get? get [
[
expirable register-continuation forward-to-id
] callcc1 resume-stdio stdio set
] [
t post-refresh-get? set
] if ;
: (show) ( quot -- namespace ) : store-current-show ( -- )
#! Store the current continuation in the variable 'current-show'
#! so it can be returned to later by href callbacks. Note that it
#! recalls itself when the continuation is called to ensure that
#! it resets its value back to the most recent show call.
[ ( 0 -- )
[ ( 0 1 -- )
current-show set ( 0 -- )
continue
] callcc1 ( 0 [ ] == )
nip
restore-request
call
store-current-show
] callcc0 restore-request ;
: redirect-to-here ( -- )
#! Force a redirect to the client browser so that the browser
#! goes to the current point in the code. This forces an URL
#! change on the browser so that refreshing that URL will
#! immediately run from this code point. This prevents the
#! "this request will issue a POST" warning from the browser
#! and prevents re-running the previous POST logic. This is
#! known as the 'post-refresh-get' pattern.
post-refresh-get? get [
[
>callable t register-callback forward-to-url
] callcc1 drop restore-request
] [
t post-refresh-get? set
] if ;
: (show) ( quot -- hashtable )
#! See comments for show. The difference is the #! See comments for show. The difference is the
#! quotation MUST set the content-type using 'serving-html' #! quotation MUST set the content-type using 'serving-html'
#! or similar. #! or similar.
store-callback-cc redirect-to-here store-current-show redirect-to-here
[ [
expirable register-continuation id>url swap >callable t register-callback swap with-scope
with-scope "" call-exit-continuation exit-continuation get continue
] callcc1 ] callcc0 drop restore-request "response" get ;
nip dup resume-stdio stdio set resume-value ;
: show ( quot -- namespace ) : show ( quot -- namespace )
#! Call the quotation with the URL associated with the current #! Call the quotation with the URL associated with the current
#! continuation. All output from the quotation goes to the client #! continuation. All output from the quotation goes to the client
#! browser. When the URL is later referenced then #! browser. When the URL is later referenced then
#! computation will resume from this 'show' call with a namespace on #! computation will resume from this 'show' call with a hashtable on
#! the stack containing any query or post parameters. #! the stack containing any query or post parameters.
#! 'quot' has stack effect ( url -- )
#! NOTE: On return from 'show' the stack is exactly the same as #! NOTE: On return from 'show' the stack is exactly the same as
#! initial entry with 'quot' popped off an <namespace> put on. Even #! initial entry with 'quot' popped off and the hashtable pushed on. Even
#! if the quotation consumes items on the stack. #! if the quotation consumes items on the stack.
\ serving-html swons (show) ; [ serving-html ] swap append (show) ;
: (show-final) ( quot -- namespace ) : (show-final) ( quot -- namespace )
#! See comments for show-final. The difference is the #! See comments for show-final. The difference is the
#! quotation MUST set the content-type using 'serving-html' #! quotation MUST set the content-type using 'serving-html'
#! or similar. #! or similar.
store-callback-cc redirect-to-here store-current-show redirect-to-here
with-scope "" call-exit-continuation ; with-scope exit-continuation get continue ;
: show-final ( quot -- namespace ) : show-final ( quot -- namespace )
#! Similar to 'show', except the quotation does not receive the URL #! Similar to 'show', except the quotation does not receive the URL
@ -248,45 +100,24 @@ SYMBOL: callback-cc
#! when a page is to be displayed with no further action to occur. Its #! when a page is to be displayed with no further action to occur. Its
#! use is an optimisation to save having to generate and save a continuation #! use is an optimisation to save having to generate and save a continuation
#! in that special case. #! in that special case.
\ serving-html swons (show-final) ; #! 'quot' has stack effect ( -- ).
[ serving-html ] swap append (show-final) ;
#! Name of variable for holding initial continuation id that starts #! Name of variable for holding initial continuation id that starts
#! the responder. #! the responder.
SYMBOL: root-continuation SYMBOL: root-callback
: id-or-root ( -- id )
#! Return the continuation id for the current requested continuation
#! or the root continuation if no id is supplied.
"id" "query" get hash [ root-continuation get ] unless* ;
: cont-get/post-responder ( id-or-f -- ) : cont-get/post-responder ( id-or-f -- )
#! httpd responder that retrieves a continuation and calls it. #! httpd responder that handles the root continuation request.
#! The continuation id must be in a query parameter called 'id'. #! The requests for actual continuation are processed by the
#! If it does not exist the root continuation is called. If #! 'callback-responder'.
#! no root continuation exists the expired continuation handler [
#! should be called. [ f post-refresh-get? set <request> request set root-callback get call ] with-scope
[ exit-continuation get continue
drop [ ] with-exit-continuation drop ;
"response" get stdio get <resume>
id-or-root [
resume-continuation
] [
(expired-page-handler) "" call-exit-continuation
] if*
] with-exit-continuation drop
] with-scope ;
: callback-quot ( quot -- quot )
#! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
[
, \ stdio , \ get , \ <resume> , callback-cc get ,
\ continue-with ,
] [ ] make ;
: quot-url ( quot -- url ) : quot-url ( quot -- url )
callback-quot expirable register-continuation id>url ; current-show get [ continue-with ] curry curry t register-callback ;
: quot-href ( text quot -- ) : quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href, #! Write to standard output an HTML HREF where the href,
@ -296,27 +127,17 @@ SYMBOL: root-continuation
#! stack. #! stack.
<a quot-url =href a> write </a> ; <a quot-url =href a> write </a> ;
: init-session-namespace ( <resume> -- )
#! Setup the initial session namespace. Currently this only
#! sets the redirect flag so that the initial request of the
#! responder will not do a post-refresh-get style redirect.
#! This prevents the initial request to a responder from redirecting
#! to an URL with a continuation id. This word must be run from
#! within the session namespace.
f post-refresh-get? set dup resume-stdio stdio set ;
: install-cont-responder ( name quot -- ) : install-cont-responder ( name quot -- )
#! Install a cont-responder with the given name #! Install a cont-responder with the given name
#! that will initially run the given quotation. #! that will initially run the given quotation.
#! #!
#! Convert the quotation so it is run within a session namespace #! Convert the quotation so it is run within a session namespace
#! and that namespace is initialized first. #! and that namespace is initialized first.
\ init-session-namespace swons [ , \ with-scope , ] [ ] make
[ [
[ cont-get/post-responder ] "get" set [ cont-get/post-responder ] "get" set
[ cont-get/post-responder ] "post" set [ cont-get/post-responder ] "post" set
swap "responder" set swap "responder" set
permanent register-continuation root-continuation set root-callback set
] make-responder ; ] make-responder ;
: simple-page ( title quot -- ) : simple-page ( title quot -- )

4
contrib/httpd/darcs-responder.factor
View File

@ -1,4 +1,4 @@
USING: cont-responder io kernel namespaces sequences xml ; USING: httpd io kernel namespaces sequences xml ;
SYMBOL: darcs-directory SYMBOL: darcs-directory
@ -53,4 +53,4 @@ SYMBOL: rss-feed-description
: darcs-rss-feed darcs-changelog changelog>rss-feed print ; : darcs-rss-feed darcs-changelog changelog>rss-feed print ;
"darcs" [ darcs-rss-feed ] install-cont-responder "darcs" [ darcs-rss-feed ] add-simple-responder

29
contrib/httpd/default-responders.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: httpd IN: httpd
USING: io browser-responder cont-responder file-responder USING: browser-responder callback-responder file-responder
help-responder inspect-responder kernel namespaces prettyprint ; help-responder inspect-responder io kernel namespaces
prettyprint ;
#! Remove all existing responders, and create a blank #! Remove all existing responders, and create a blank
#! responder table. #! responder table.
@ -10,30 +11,32 @@ global [
H{ } clone responders set H{ } clone responders set
! 404 error message pages are served by this guy ! 404 error message pages are served by this guy
"404" [ no-such-responder ] install-cont-responder "404" [ no-such-responder ] add-simple-responder
! Online help browsing ! Online help browsing
"help" [ help-responder ] install-cont-responder "help" [ help-responder ] add-simple-responder
! Used by other responders
"callback" [ callback-responder ] add-simple-responder
! Javascript source used by ajax libraries ! Javascript source used by ajax libraries
"javascript" [ "resources" [
[ [
"contrib/httpd/javascript/" resource-path "" resource-path "doc-root" set
"doc-root" set
file-responder file-responder
] with-scope ] with-scope
] install-cont-responder ] add-simple-responder
! Global variables ! Global variables
"inspector" [ inspect-responder ] install-cont-responder "inspector" [ inspect-responder ] add-simple-responder
! Servers Factor word definitions from the image. ! Servers Factor word definitions from the image.
"browser" [ browser-responder ] install-cont-responder "browser" [ browser-responder ] add-simple-responder
! Serves files from a directory stored in the "doc-root" ! Serves files from a directory stored in the "doc-root"
! variable. You can set the variable in the global namespace, ! variable. You can set the variable in the global namespace,
! or inside the responder. ! or inside the responder.
"file" [ file-responder ] install-cont-responder "file" [ file-responder ] add-simple-responder
! The root directory is served by... ! The root directory is served by...
"file" set-default-responder "file" set-default-responder

23
contrib/httpd/examples/cont-examples.factor
View File

@ -24,11 +24,11 @@
! Simple test applications ! Simple test applications
IN: cont-examples IN: cont-examples
USE: cont-responder USE: cont-responder
USE: hashtables
USE: html USE: html
USE: kernel USE: kernel
USE: io USE: io
USE: html USE: html
USE: lists
USE: strings USE: strings
USE: math USE: math
USE: namespaces USE: namespaces
@ -40,24 +40,24 @@ USE: sequences
#! Display a page with some text to test the cont-responder. #! Display a page with some text to test the cont-responder.
#! The page has a link to the 'next' continuation. #! The page has a link to the 'next' continuation.
[ [
<h1> over write </h1>
swap [ swap [
<a =href a> "Next" write </a> <a =href a> "Next" write </a>
] html-document ] html-document
] show drop drop ; ] show 2drop ;
: display-get-name-page ( -- name ) : display-get-name-page ( -- name )
#! Display a page prompting for input of a name and return that name. #! Display a page prompting for input of a name and return that name.
[ [
"Enter your name" [ "Enter your name" [
<h1> swap write </h1>
<form "post" =method =action form> <form "post" =method =action form>
"Name: " write "Name: " write
<input "text" =type "name" =name "20" =size input/> <input "text" =type "name" =name "20" =size input/>
<input "submit" =type "Ok" =value input/> <input "submit" =type "Ok" =value input/>
</form> </form>
] html-document ] html-document
] show [ ] show "name" swap hash ;
"name" get
] bind ;
: test-cont-responder ( - ) : test-cont-responder ( - )
#! Test the cont-responder responder by displaying a few pages in a row. #! Test the cont-responder responder by displaying a few pages in a row.
@ -67,22 +67,21 @@ USE: sequences
: test-cont-responder2 ( - ) : test-cont-responder2 ( - )
#! Test the cont-responder responder by displaying a few pages in a loop. #! Test the cont-responder responder by displaying a few pages in a loop.
[ "one" "two" "three" "four" ] [ display-page [ .s ] string-out display-page ] each [ "one" "two" "three" "four" ] [ display-page ] each
"Done!" display-page ; "Done!" display-page ;
: test-cont-responder3 ( - ) : test-cont-responder3 ( - )
#! Test the quot-href word by displaying a menu of the current #! Test the quot-href word by displaying a menu of the current
#! test words. Note that we drop the 'url' argument to the show #! test words. Note that we use show-final as we don't link to a 'next' page.
#! quotation as we don't link to a 'next' page.
[ [
drop
"Menu" [ "Menu" [
<h1> "Menu" write </h1>
<ol> <ol>
<li> "Test responder1" [ test-cont-responder ] quot-href </li> <li> "Test responder1" [ test-cont-responder ] quot-href </li>
<li> "Test responder2" [ [ .s ] string-out display-page test-cont-responder2 [ .s ] string-out display-page ] quot-href </li> <li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
</ol> </ol>
] html-document ] html-document
] show drop ; ] show-final ;
: counter-example ( count - ) : counter-example ( count - )
#! Display a counter which can be incremented or decremented #! Display a counter which can be incremented or decremented
@ -119,6 +118,6 @@ USE: sequences
! Install the examples ! Install the examples
"counter1" [ drop 0 counter-example ] install-cont-responder "counter1" [ drop 0 counter-example ] install-cont-responder
"counter2" [ drop counter-example2 ] install-cont-responder "counter2" [ drop counter-example2 ] install-cont-responder
"test1" [ drop test-cont-responder ] install-cont-responder "test1" [ test-cont-responder ] install-cont-responder
"test2" [ drop test-cont-responder2 ] install-cont-responder "test2" [ drop test-cont-responder2 ] install-cont-responder
"test3" [ drop test-cont-responder3 ] install-cont-responder "test3" [ drop test-cont-responder3 ] install-cont-responder

113
contrib/httpd/examples/cont-testing.factor
View File

@ -1,113 +0,0 @@
! cont-testing
!
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Words for testing continuation based responders at the console
! prompt.
!
! To start a 'test' session use '<cont-test-state>' to push the
! continuation responder state on the stack.
!
! Then use 'test-cont-function' to call a continuation responder word.
! All output will go to the console. From this output you will see
! links that you can 'visit' by doing a simulated click. Use the
! 'test-cont-click' function by passing the state, the 'id' of the click
! continuation, and 'f' or a hashtable containing the post data. The output
! from this will be displayed.
!
! eg.
! <cont-test-state> [ test-cont-responder ] test-cont-function
! => HTTP/1.1 302 Document Moved
! Location: ?id=8506502852110820
! Content-Length: 0
! Content-Type: text/plain
!
! "8506502852110820" f test-cont-click
! => HTTP/1.0 200 Document follows
! Content-Type: text/html
!
! <html><head><title>Page one</title></head><body>
! <h1>Page one</h1><a href='?id=5431597582800278'>Next</a>
! </body></html>
!
! "5431597582800278" f test-cont-click
! => HTTP/1.1 302 Document Moved
! Location: ?id=7944183606904129
! Content-Length: 0
! Content-Type: text/plain
!
! "7944183606904129" f test-cont-click
! => HTTP/1.0 200 Document follows
! Content-Type: text/html
!
! <html><head><title>Enter your name</title></head>
! <body><h1>Enter your name</h1>
! <form method='post' action='?id=8503790719833723'>
! Name: <input type='text' name='name'size='20'>
! <input type='submit' value='Ok'>
! </form></body></html>
!
! "8503790719833723" [ [[ "name" "Chris" ]] ] alist>hash test-cont-click
! => HTTP/1.1 302 Document Moved
! Location: ?id=8879727708050260
! Content-Length: 0
! Content-Type: text/plain
!
! "8879727708050260" f test-cont-click
! => HTTP/1.0 200 Document follows
! Content-Type: text/html
!
! <html><head><title>Hello Chris</title></head>
! <body><h1>Hello Chris</h1>
! <a href='?id=0937854264503953'>Next</a>
! </body></html>
!
! etc.
IN: cont-responder
USE: namespaces
USE: kernel
USE: io
: <cont-test-state> ( -- <state> )
#! Create a namespace holding data required
#! for testing continuation based responder functions
#! at the interpreter console.
[
reset-continuation-table
init-session-namespace
] make-hash ;
: test-cont-function ( <state> quot -- <state> )
#! Call a continuation responder function with required
#! plumbing set up so output is displayed to the console.
swap dup >r [
[ call ] with-exit-continuation
] bind write drop r> ;
: test-cont-click ( <state> id data -- <state> )
#! Test function to 'click' a continuation with the given
#! 'id' and post data. Display the results on the console.
rot dup >r [
[ swap resume-continuation ] with-exit-continuation
] bind write 2drop r> ;

217
contrib/httpd/examples/eval-responder.factor
View File

@ -1,217 +0,0 @@
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! An httpd responder that allows executing simple definitions.
!
IN: eval-responder
USE: html
USE: cont-responder
USE: kernel
USE: namespaces
USE: io
USE: parser
USE: lists
USE: errors
USE: strings
USE: prettyprint
USE: words
USE: vectors
USE: sequences
USE: hashtables
: <evaluator> ( stack msg history -- )
#! Create an 'evaluator' object that holds
#! the current stack, output and history for
#! do-eval.
[
"history" set
"output" set
"stack" set
] make-hash ;
: display-eval-form ( url -- )
#! Display the components for allowing entry of
#! factor words to be evaluated.
<form "main" =name "post" =method =action form>
[
[
<textarea "eval" =name "10" =rows "40" =cols textarea>
"" write
</textarea>
]
[
<input "submit" =type "Evaluate" =value "e" =accesskey input/>
]
] vertical-layout
</form>
"<script language='javascript'>document.forms.main.eval.focus()</script>" write ;
: escape-quotes ( string -- string )
#! Replace occurrences of single quotes with
#! backslash quote.
[
[ dup H{ { CHAR: ' "\\'" } { CHAR: " "\\\"" } } hash [ % ] [ % ] ?if ] each
] "" make ;
: make-eval-javascript ( string -- string )
#! Give a string return some javascript that when
#! executed will set the eval textarea to that string.
[ "document.forms.main.eval.value=\"" % escape-quotes % "\"" % ] "" make ;
: write-eval-link ( string -- )
#! Given text to evaluate, create an A HREF link which when
#! clicked sets the eval textarea to that value.
<a "#" =href dup make-eval-javascript =onclick a> write </a> ;
: display-stack ( list -- )
#! Write out html to display the stack.
<table "1" =border table>
<tr> <th> "Callstack" write </th> </tr>
[ <tr> <td> [ unparse write ] string-out write-eval-link </td> </tr> ] each
</table> ;
: display-clear-history-link ( -- )
#! Write out html to display a link that will clear
#! the history list.
" (" write
"Clear" [ [ ] "history" set ] quot-href
")" write ;
: display-history ( list -- )
#! Write out html to display the history.
<table "1" =border table>
<tr> <th> "History" write display-clear-history-link </th> </tr>
[ <tr> <td> write-eval-link </td> </tr> ] each
</table> ;
: usages. ( word -- )
#! Write to output the words that use the given word, one
#! per line.
usages [ . ] each ;
: html-for-word-source ( word-string -- )
#! Return an html fragment dispaying the source
#! of the given word.
dup dup
[
"browser" "responder" set
<table "1" =border table>
<tr> <th "2" =colspan th> "Source" write </th> </tr>
<tr> <td "2" =colspan td> [ [ parse ] catch [ "No such word" write ] [ car see ] if ] with-html-stream </td> </tr>
<tr> <th> "Apropos" write </th> <th> "Usages" write </th> </tr>
<tr> <td "top" =valign td> [ apropos ] with-html-stream </td>
<td "top" =valign td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-html-stream </td>
</tr>
</table>
] make-hash ;
: display-last-output ( string -- )
#! Write out html to display the last output.
<table "1" =border table>
<tr> <th> "Last Output" write </th> </tr>
<tr> <td> <pre> write </pre> </td> </tr>
</table> ;
: get-expr-to-eval ( -- string )
#! Show a page to the user requesting the form to be
#! evaluated. Return the form as a string. Assumes
#! an evaluator is on the namestack.
[
<html>
<head>
<title> "Factor Evaluator" write </title>
</head>
<body>
"Use Alt+E to evaluate, or press 'Evaluate'" paragraph
[
[ display-eval-form ]
[ "stack" get display-stack ]
[ "history" get display-history ]
] horizontal-layout
"output" get display-last-output
</body>
</html>
] show [
"eval" get
] bind ;
: >pop> dup pop* ;
: infra ( list quot -- list )
#! Call the quotation using 'list' as the datastack
#! return the result datastack as a list.
datastack >r
swap >vector tuck push
set-datastack call datastack >list
r> >pop> >pop> tuck push set-datastack ;
: do-eval ( list string -- list )
#! Evaluate the expression in 'string' using 'list' as
#! the datastack. Return the resulting stack as a list.
parse infra ;
: do-eval-to-string ( list string -- list string )
#! Evaluate expression using 'list' as the current callstack.
#! All output should go to a string which is returned on the
#! callstack along with the resulting datastack as a list.
[
"browser" "responder" set
1024 <sbuf> dup >r <html-stream> [
do-eval
] with-stream r> >string
] with-scope ;
: forever ( quot -- )
#! The code is evaluated in an infinite loop. Typically, a
#! continuation is used to escape the infinite loop.
#!
#! This combinator will not compile.
dup slip forever ;
: cons@ ( value name -- )
#! Get the value of the variable named by 'name'
#! from the current namespace and cons 'value' to its
#! current value.
dup get rot swons swap set ;
: run-eval-requester ( evaluator -- )
#! Enter a loop request an expression to
#! evaluate, and displaying the results.
[
[
get-expr-to-eval dup "history" cons@
"stack" get swap do-eval-to-string
"output" set "stack" set
] forever
] bind ;
: eval-responder ( evaluator -- )
#! Run an eval-responder using the given evaluation details.
[
[
run-eval-requester
] catch
dup [ show-message-page ] [ drop ] if
] forever ;
"eval" [ [ ] "None" [ ] <evaluator> eval-responder ] install-cont-responder

2
contrib/httpd/examples/load.factor
View File

@ -6,6 +6,4 @@ USING: words kernel parser sequences io compiler ;
{ {
"cont-examples" "cont-examples"
"cont-numbers-game" "cont-numbers-game"
"eval-responder"
"cont-testing"
} [ "/contrib/httpd/examples/" swap ".factor" append3 run-resource ] each } [ "/contrib/httpd/examples/" swap ".factor" append3 run-resource ] each

53
contrib/httpd/file-responder.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004,2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: file-responder IN: file-responder
USING: cont-responder html httpd io kernel lists math namespaces USING: embedded errors html httpd io kernel math namespaces parser
parser sequences strings ; sequences strings ;
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
[ "" ] unless* "doc-root" get swap append ; [ "" ] unless* "doc-root" get swap append ;
@ -20,12 +20,19 @@ parser sequences strings ;
<file-reader> stdio get stream-copy <file-reader> stdio get stream-copy
] if ; ] if ;
SYMBOL: page
: run-page ( filename -- )
dup
[ [ dup page set run-embedded-file ] with-scope ] try
drop ;
: include-page ( filename -- )
"doc-root" get swap path+ run-page ;
: serve-file ( filename -- ) : serve-file ( filename -- )
dup mime-type dup "application/x-factor-server-page" = [ dup mime-type dup "application/x-factor-server-page" =
drop run-file [ drop serving-html run-page ] [ serve-static ] if ;
] [
serve-static
] if ;
: list-directory ( directory -- ) : list-directory ( directory -- )
serving-html serving-html
@ -35,13 +42,15 @@ parser sequences strings ;
"request" get [ dup log-message directory. ] simple-html-document "request" get [ dup log-message directory. ] simple-html-document
] if ; ] if ;
: find-index ( filename -- path )
{ "index.html" "index.fhtml" }
[ dupd path+ exists? ] find nip
dup [ path+ ] [ nip ] if ;
: serve-directory ( filename -- ) : serve-directory ( filename -- )
dup "/" tail? [ dup "/" tail? [
dup "index.html" append dup exists? [ dup find-index
nip serve-file [ serve-file ] [ list-directory ] ?if
] [
drop list-directory
] if
] [ ] [
drop directory-no/ drop directory-no/
] if ; ] if ;
@ -50,14 +59,12 @@ parser sequences strings ;
dup directory? [ serve-directory ] [ serve-file ] if ; dup directory? [ serve-directory ] [ serve-file ] if ;
: file-responder ( -- ) : file-responder ( -- )
[ "doc-root" get [
"doc-root" get [ "argument" get serving-path dup exists? [
"argument" get serving-path dup exists? [ serve-object
serve-object
] [
drop "404 not found" httpd-error
] if
] [ ] [
"404 doc-root not set" httpd-error drop "404 not found" httpd-error
] if ] if
] (show-final) ; ] [
"404 doc-root not set" httpd-error
] if ;

18
contrib/httpd/help-responder.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2006 Slava Pestov. ! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: help-responder IN: help-responder
USING: cont-responder hashtables help html kernel namespaces USING: hashtables help html httpd io kernel namespaces sequences ;
sequences ;
: help-responder ( filename -- ) : help-topic
[ "topic" query-param dup empty? [ drop "handbook" ] when ;
"topic" "query" get hash
dup empty? [ drop "handbook" ] when : help-responder ( -- )
dup article-title serving-html
[ [ (help) ] with-html-stream ] html-document help-topic dup article-title [
] show-final ; [ help ] with-html-stream
] html-document ;

33
contrib/httpd/html-tags.factor
View File

@ -1,32 +1,11 @@
! cont-html v0.6 ! cont-html v0.6
! !
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! ! See http://factorcode.org/license.txt for BSD license.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: html IN: html
USE: prettyprint USE: prettyprint
USE: strings USE: strings
USE: lists
USE: kernel USE: kernel
USE: io USE: io
USE: namespaces USE: namespaces
@ -86,7 +65,7 @@ SYMBOL: html
: def-for-html-word-<foo> ( name -- ) : def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned #! Return the name and code for the <foo> patterned
#! word. #! word.
dup <foo> swap [ <foo> write-html ] cons html-word dup <foo> swap [ <foo> write-html ] curry html-word
define-open ; define-open ;
: <foo "<" swap append ; : <foo "<" swap append ;
@ -94,7 +73,7 @@ SYMBOL: html
: def-for-html-word-<foo ( name -- ) : def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned #! Return the name and code for the <foo patterned
#! word. #! word.
<foo dup [ write-html ] cons html-word drop ; <foo dup [ write-html ] curry html-word drop ;
: foo> ">" append ; : foo> ">" append ;
@ -108,14 +87,14 @@ SYMBOL: html
: def-for-html-word-</foo> ( name -- ) : def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned #! Return the name and code for the </foo> patterned
#! word. #! word.
</foo> dup [ write-html ] cons html-word define-close ; </foo> dup [ write-html ] curry html-word define-close ;
: <foo/> [ "<" % % "/>" % ] "" make ; : <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- ) : def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned #! Return the name and code for the <foo/> patterned
#! word. #! word.
dup <foo/> swap [ <foo/> write-html ] cons html-word drop ; dup <foo/> swap [ <foo/> write-html ] curry html-word drop ;
: foo/> "/>" append ; : foo/> "/>" append ;
@ -172,5 +151,5 @@ SYMBOL: html
"size" "href" "class" "border" "rows" "cols" "size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "width" "selected"
] [ define-attribute-word ] each ] [ define-attribute-word ] each

91
contrib/httpd/html.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2006 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: cont-responder generic hashtables help http inspector io USING: callback-responder generic hashtables help http inspector
kernel lists prototype-js math namespaces sequences strings io kernel math namespaces prototype-js sequences strings styles
styles words xml ; words xml ;
IN: html IN: html
: hex-color, ( triplet -- ) : hex-color, ( triplet -- )
@ -18,9 +18,9 @@ IN: html
: style-css, ( flag -- ) : style-css, ( flag -- )
dup dup
{ italic bold-italic } member? { italic bold-italic } member?
[ "font-style: italic; " % ] when "font-style: " % "italic" "normal" ? % "; " %
{ bold bold-italic } member? { bold bold-italic } member?
[ "font-weight: bold; " % ] when ; "font-weight: " % "bold" "normal" ? % "; " % ;
: size-css, ( size -- ) : size-css, ( size -- )
"font-size: " % # "pt; " % ; "font-size: " % # "pt; " % ;
@ -81,23 +81,6 @@ IN: html
<div =style div> call </div> <div =style div> call </div>
] if ; ] if ;
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
#! links.
"doc-root" get [
?head [ "/" ?head drop ] when
] when* "/" ?tail drop ;
: file-link-href ( path -- href )
[ "/" % resolve-file-link url-encode % ] "" make ;
: file-link-tag ( style quot -- )
over file swap hash [
<a file-link-href =href a> call </a>
] [
call
] if* ;
: do-escaping ( string style -- string ) : do-escaping ( string style -- string )
html swap hash [ chars>entities ] unless ; html swap hash [ chars>entities ] unless ;
@ -117,6 +100,17 @@ M: link browser-link-href
"/responder/help/" swap "topic" associate build-url "/responder/help/" swap "topic" associate build-url
] if ; ] if ;
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
#! links.
"doc-root" get [
?head [ "/" ?head drop ] when
] when* "/" ?tail drop ;
M: pathname browser-link-href
pathname-string
"/" swap resolve-file-link url-encode append ;
: object-link-tag ( style quot -- ) : object-link-tag ( style quot -- )
presented pick hash browser-link-href presented pick hash browser-link-href
[ <a =href a> call </a> ] [ call ] if* ; [ <a =href a> call </a> ] [ call ] if* ;
@ -139,31 +133,30 @@ M: html-stream stream-write1 ( char stream -- )
M: html-stream stream-write ( str stream -- ) M: html-stream stream-write ( str stream -- )
>r chars>entities r> delegate-write ; >r chars>entities r> delegate-write ;
: with-html-style ( quot style stream -- )
[ [ swap span-tag ] object-link-tag ] with-stream* ; inline
M: html-stream with-stream-style ( quot style stream -- )
[ drop call ] -rot with-html-style ;
M: html-stream stream-format ( str style stream -- ) M: html-stream stream-format ( str style stream -- )
[ [ do-escaping stdio get delegate-write ] -rot
[ with-html-style ;
[
[
do-escaping stdio get delegate-write
] span-tag
] file-link-tag
] object-link-tag
] with-stream* ;
: with-html-stream ( quot -- ) : with-html-stream ( quot -- )
stdio get <html-stream> swap with-stream* ; stdio get <html-stream> swap with-stream* ;
: make-outliner-quot : make-outliner-quot
[ [
<div "padding-left:10px;" =style div> <div "padding-left: 20px; " =style div>
with-html-stream with-html-stream
</div> </div>
] curry [ , \ show-final , ] [ ] make ; ] curry ;
: html-outliner ( caption contents -- ) : html-outliner ( caption contents -- )
"+ " get-random-id dup >r "+ " get-random-id dup >r
rot make-outliner-quot updating-anchor call rot make-outliner-quot updating-anchor call
<span r> =id span> </span> ; <span r> =id "display: none; " =style span> </span> ;
: outliner-tag ( style quot -- ) : outliner-tag ( style quot -- )
outline pick hash [ html-outliner ] [ call ] if* ; outline pick hash [ html-outliner ] [ call ] if* ;
@ -179,6 +172,31 @@ M: html-stream with-nested-stream ( quot style stream -- )
] outliner-tag ] outliner-tag
] with-stream* ; ] with-stream* ;
: border-spacing-css,
"padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str )
[
H{
{ table-border [ border-css, ] }
{ table-gap [ border-spacing-css, ] }
} hash-apply
] "" make ;
: table-attrs ( style -- )
table-style " border-collapse: collapse;" append =style ;
M: html-stream with-stream-table ( grid quot style stream -- )
[
<table dup table-attrs table> rot [
<tr> [
<td "top" =valign over table-style =style td>
pick H{ } swap with-nesting
</td>
] each </tr>
] each 2drop </table>
] with-stream* ;
M: html-stream stream-terpri [ <br/> ] with-stream* ; M: html-stream stream-terpri [ <br/> ] with-stream* ;
: default-css ( -- ) : default-css ( -- )
@ -186,7 +204,7 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
"A:link { text-decoration: none; color: black; }" print "A:link { text-decoration: none; color: black; }" print
"A:visited { text-decoration: none; color: black; }" print "A:visited { text-decoration: none; color: black; }" print
"A:active { text-decoration: none; color: black; }" print "A:active { text-decoration: none; color: black; }" print
"A:hover, A:hover { text-decoration: none; color: black; }" print "A:hover, A:hover { text-decoration: underline; color: black; }" print
</style> ; </style> ;
: xhtml-preamble : xhtml-preamble
@ -195,7 +213,7 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
: html-document ( title quot -- ) : html-document ( title quot -- )
xhtml-preamble xhtml-preamble
swap chars>entities dup swap chars>entities
<html> <html>
<head> <head>
<title> write </title> <title> write </title>
@ -203,7 +221,6 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
include-prototype-js include-prototype-js
</head> </head>
<body> <body>
<h1> write </h1>
call call
</body> </body>
</html> ; </html> ;

2
contrib/httpd/http-common.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2005 Slava Pestov ! Copyright (C) 2003, 2005 Slava Pestov
IN: http IN: http
USING: errors hashtables io kernel lists math namespaces parser USING: errors hashtables io kernel math namespaces parser
sequences strings ; sequences strings ;
: header-line ( line -- ) : header-line ( line -- )

2
contrib/httpd/httpd.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2005 Slava Pestov. ! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: httpd IN: httpd
USING: errors hashtables kernel lists namespaces io strings USING: errors hashtables kernel namespaces io strings
threads http sequences ; threads http sequences ;
: (url>path) ( uri -- path ) : (url>path) ( uri -- path )

11
contrib/httpd/inspect-responder.factor
View File

@ -1,16 +1,15 @@
! Copyright (C) 2006 Slava Pestov. ! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: inspect-responder IN: inspect-responder
USING: cont-responder generic hashtables help html inspector USING: callback-responder generic hashtables help html httpd
kernel lists namespaces sequences ; inspector kernel namespaces sequences ;
! Mini object inspector ! Mini object inspector
: http-inspect ( obj -- ) : http-inspect ( obj -- )
"Inspecting " over summary append dup summary [ describe ] simple-html-document ;
[ describe ] simple-html-document ;
M: general-t browser-link-href M: general-t browser-link-href
[ [ http-inspect ] show-final ] curry quot-url ; [ http-inspect ] curry t register-html-callback ;
: inspect-responder ( url -- ) : inspect-responder ( url -- )
[ global http-inspect ] show-final ; serving-html global http-inspect ;

48
contrib/httpd/load.factor
View File

@ -1,28 +1,30 @@
IN: scratchpad USING: io ;
USING: words kernel parser sequences io compiler ;
{ REQUIRES: embedded ;
"mime"
"xml"
"http-common"
"html-tags"
"responder"
"httpd"
"cont-responder"
"prototype-js"
"html"
"file-responder"
"help-responder"
"inspect-responder"
"browser-responder"
"default-responders"
"http-client"
"test/html" PROVIDE: httpd {
"test/http-client" "mime.factor"
"test/httpd" "xml.factor"
"test/url-encoding" "http-common.factor"
} [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each "html-tags.factor"
"responder.factor"
"httpd.factor"
"callback-responder.factor"
"cont-responder.factor"
"prototype-js.factor"
"html.factor"
"file-responder.factor"
"help-responder.factor"
"inspect-responder.factor"
"browser-responder.factor"
"default-responders.factor"
"http-client.factor"
} {
"test/html.factor"
"test/http-client.factor"
"test/httpd.factor"
"test/url-encoding.factor"
} ;
"To start the HTTP server, issue the following command in the listener:" print "To start the HTTP server, issue the following command in the listener:" print
" USE: httpd" print " USE: httpd" print

4
contrib/httpd/mime.factor
View File

@ -28,7 +28,7 @@ H{
{ "gz" "application/octet-stream" } { "gz" "application/octet-stream" }
{ "pdf" "application/pdf" } { "pdf" "application/pdf" }
{ "factor" "text/plain" } { "factor" "text/plain" }
{ "factsp" "application/x-factor-server-page" } { "fhtml" "application/x-factor-server-page" }
} "mime-types" global set-hash } "mime-types" global set-hash

20
contrib/httpd/prototype-js.factor
View File

@ -5,23 +5,35 @@
! For information and license details for protoype ! For information and license details for protoype
! see http://prototype.conio.net ! see http://prototype.conio.net
IN: prototype-js IN: prototype-js
USING: io httpd cont-responder html kernel lists namespaces strings ; USING: callback-responder html httpd io kernel namespaces
strings ;
: include-prototype-js ( -- ) : include-prototype-js ( -- )
#! Write out the HTML script tag to include the prototype #! Write out the HTML script tag to include the prototype
#! javascript library. #! javascript library.
<script "text/javascript" =type "/responder/javascript/prototype.js" =src script> <script "text/javascript" =type "/responder/resources/contrib/httpd/javascript/prototype.js"
=src script>
</script> ; </script> ;
: updating-javascript ( id quot -- string ) : updating-javascript ( id quot -- string )
#! Return the javascript code to perform the updating #! Return the javascript code to perform the updating
#! ajax call. #! ajax call.
quot-url swap t register-html-callback swap
[ "new Ajax.Updater(\"" % % "\",\"" % % "\", { method: \"get\" });" % ] "" make ; [ "new Ajax.Updater(\"" % % "\",\"" % % "\", { method: \"get\" });" % ] "" make ;
: toggle-javascript ( string id -- string )
[
"if(Element.visible(\"" % dup % "\"))" %
"Element.hide(\"" % dup % "\");" %
"else {" %
swap %
" Element.show(\"" % % "\"); }" %
] "" make ;
: updating-anchor ( text id quot -- ) : updating-anchor ( text id quot -- )
#! Write the HTML for an anchor that when clicked will #! Write the HTML for an anchor that when clicked will
#! call the given quotation on the server. The output generated #! call the given quotation on the server. The output generated
#! from that quotation will replace the DOM element on the page with #! from that quotation will replace the DOM element on the page with
#! the given id. The 'text' is the anchor text. #! the given id. The 'text' is the anchor text.
<a updating-javascript =onclick a> write </a> ; over >r updating-javascript r> toggle-javascript
<a =onclick a> write </a> ;

14
contrib/httpd/responder.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: httpd IN: httpd
USING: arrays hashtables http kernel lists math namespaces USING: arrays hashtables html http io kernel math namespaces
parser sequences io strings ; parser sequences strings ;
! Variables ! Variables
SYMBOL: vhosts SYMBOL: vhosts
@ -15,7 +15,7 @@ SYMBOL: responders
"HTTP/1.0 " write print print-header ; "HTTP/1.0 " write print print-header ;
: error-body ( error -- body ) : error-body ( error -- body )
"<html><body><h1>" swap "</h1></body></html>" append3 print ; <html> <body> <h1> write </h1> </body> </html> ;
: error-head ( error -- ) : error-head ( error -- )
dup log-error dup log-error
@ -91,10 +91,18 @@ SYMBOL: responders
! - header -- a hashtable of headers from the user's client ! - header -- a hashtable of headers from the user's client
! - response -- a hashtable of the POST request response ! - response -- a hashtable of the POST request response
: query-param ( key -- value ) "query" get hash ;
: add-responder ( responder -- ) : add-responder ( responder -- )
#! Add a responder object to the list. #! Add a responder object to the list.
"responder" over hash responders get set-hash ; "responder" over hash responders get set-hash ;
: add-simple-responder ( name quot -- )
[
[ drop ] swap append dup "get" set "post" set
"responder" set
] make-hash add-responder ;
: make-responder ( quot -- responder ) : make-responder ( quot -- responder )
[ [
( url -- ) ( url -- )

2
contrib/httpd/test/html.factor
View File

@ -15,7 +15,7 @@ USING: html http io kernel namespaces styles test xml ;
[ [
[ [
"/home/slava/doc/" "doc-root" set "/home/slava/doc/" "doc-root" set
"/home/slava/doc/foo/bar" file-link-href "/home/slava/doc/foo/bar" <pathname> browser-link-href
] with-scope ] with-scope
] unit-test ] unit-test

1
contrib/httpd/test/httpd.factor
View File

@ -6,7 +6,6 @@ USE: namespaces
USE: io USE: io
USE: test USE: test
USE: strings USE: strings
USE: lists
[ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n\n" ] [ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n\n" ]
[ [

369
contrib/httpd/xml.factor
View File

@ -1,75 +1,13 @@
USING: arrays errors generic hashtables io kernel lists math USING: arrays errors generic hashtables io kernel math
namespaces parser prettyprint sequences strings vectors words ; namespaces parser prettyprint sequences strings vectors words ;
IN: xml IN: xml
! * Simple SAX-ish parser
! -- Basic utility words
SYMBOL: code #! Source code SYMBOL: code #! Source code
SYMBOL: spot #! Current index of string SYMBOL: spot #! Current index of string
SYMBOL: version SYMBOL: version
SYMBOL: line SYMBOL: line
SYMBOL: column SYMBOL: column
: set-code ( string -- ) ! for debugging
code set [ spot line column ] [ 0 swap set ] each ;
: more? ( -- ? )
#! Return t if spot is not at the end of code
code get length spot get = not ;
: char ( -- char/f )
more? [ spot get code get nth ] [ f ] if ;
: incr-spot ( -- )
#! Increment spot.
spot [ 1 + ] change
char "\n\r" member? [
0 column set
line
] [
column
] if [ 1 + ] change ;
: skip-until ( quot -- | quot: char -- ? )
more? [
char swap [ call ] keep swap [ drop ] [
incr-spot skip-until
] if
] [ drop ] if ; inline
: take-until ( quot -- string | quot: char -- ? )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
spot get >r skip-until r>
spot get code get subseq ; inline
: pass-blank ( -- )
#! Advance code past any whitespace, including newlines
[ blank? not ] skip-until ;
: string-matches? ( string -- ? )
spot get dup pick length + code get subseq = ;
DEFER: <xml-string-error>
: (take-until-string) ( string -- n )
more? [
dup string-matches? [
drop spot get
] [
incr-spot (take-until-string)
] if
] [ "Missing closing token" <xml-string-error> throw ] if ;
: take-until-string ( string -- string )
[ >r spot get r> (take-until-string) code get subseq ] keep
length spot [ + ] change ;
: in-range-seq? ( number { [[ min max ]] ... } -- ? )
[ uncons between? not ] all-with? not ;
! -- Error reporting ! -- Error reporting
TUPLE: xml-error line column ; TUPLE: xml-error line column ;
@ -111,6 +49,58 @@ M: xml-string-error error.
dup xml-error. dup xml-error.
xml-string-error-string print ; xml-string-error-string print ;
! -- Basic utility words
: set-code ( string -- ) ! for debugging
code set [ spot line column ] [ 0 swap set ] each ;
: more? ( -- ? )
#! Return t if spot is not at the end of code
code get length spot get = not ;
: char ( -- char/f )
more? [ spot get code get nth ] [ f ] if ;
: incr-spot ( -- )
#! Increment spot.
spot inc
char "\n\r" member? [ 0 column set line ] [ column ] if
inc ;
: skip-until ( quot -- | quot: char -- ? )
more? [
char swap [ call ] keep swap [ drop ] [
incr-spot skip-until
] if
] [ drop ] if ; inline
: take-until ( quot -- string | quot: char -- ? )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
spot get >r skip-until r>
spot get code get subseq ; inline
: pass-blank ( -- )
#! Advance code past any whitespace, including newlines
[ blank? not ] skip-until ;
: string-matches? ( string -- ? )
spot get dup pick length + code get subseq = ;
: (take-until-string) ( string -- n )
more? [
dup string-matches? [
drop spot get
] [
incr-spot (take-until-string)
] if
] [ "Missing closing token" <xml-string-error> throw ] if ;
: take-until-string ( string -- string )
[ >r spot get r> (take-until-string) code get subseq ] keep
length spot [ + ] change ;
! -- Parsing strings ! -- Parsing strings
: expect ( ch -- ) : expect ( ch -- )
@ -119,18 +109,20 @@ M: xml-string-error error.
] if incr-spot ; ] if incr-spot ;
: expect-string ( string -- ) : expect-string ( string -- )
>r spot get r> t over [ char incr-spot = and ] each [ 2drop ] [ >r spot get r> t over [ char incr-spot = and ] each [
2drop
] [
swap spot get code get subseq <expected> throw swap spot get code get subseq <expected> throw
] if ; ] if ;
: entities : entities
#! We have both directions here as a shortcut. #! We have both directions here as a shortcut.
H{ H{
{ "lt" CHAR: < } { "lt" CHAR: < }
{ "gt" CHAR: > } { "gt" CHAR: > }
{ "amp" CHAR: & } { "amp" CHAR: & }
{ "apos" CHAR: ' } { "apos" CHAR: ' }
{ "quot" CHAR: " } { "quot" CHAR: " }
{ CHAR: < "&lt;" } { CHAR: < "&lt;" }
{ CHAR: > "&gt;" } { CHAR: > "&gt;" }
{ CHAR: & "&amp;" } { CHAR: & "&amp;" }
@ -139,43 +131,59 @@ M: xml-string-error error.
} ; } ;
: parse-entity ( -- ch ) : parse-entity ( -- ch )
incr-spot [ CHAR: ; = ] take-until incr-spot incr-spot [ CHAR: ; = ] take-until "#" ?head [
dup first CHAR: # = [ "x" ?head 16 10 ? base>
1 swap tail "x" ?head 16 10 ? base>
] [ ] [
dup entities hash [ nip ] [ <no-entity> throw ] if* dup entities hash [ ] [ <no-entity> throw ] ?if
] if ; ] if ;
: (parse-text) ( vector -- vector ) : parsed-ch ( buf ch -- buf ) over push incr-spot ;
[ CHAR: & = ] take-until over push
char CHAR: & = [
parse-entity ch>string over push (parse-text)
] when ;
: parse-text ( string -- string ) : (parse-text) ( buf -- buf )
[ {
code set 0 spot set { [ more? not ] [ ] }
100 <vector> (parse-text) concat { [ char CHAR: < = ] [ ] }
] with-scope ; { [ char CHAR: & = ] [ parse-entity parsed-ch (parse-text) ] }
{ [ t ] [ char parsed-ch (parse-text) ] }
} cond ;
: get-text ( -- string ) : parse-text ( -- string )
[ CHAR: < = ] take-until parse-text ; SBUF" " clone (parse-text) >string ;
! -- Parsing tags ! -- Parsing tags
: in-range-seq? ( number { { min max } ... } -- ? )
[ first2 between? ] contains-with? ;
: name-start-char? ( ch -- ? ) : name-start-char? ( ch -- ? )
dup ":_" member? swap { {
[[ CHAR: A CHAR: Z ]] [[ CHAR: a CHAR: z ]] [[ HEX: C0 HEX: D6 ]] { CHAR: : CHAR: : }
[[ HEX: D8 HEX: F6 ]] [[ HEX: F8 HEX: 2FF ]] [[ HEX: 370 HEX: 37D ]] { CHAR: _ CHAR: _ }
[[ HEX: 37F HEX: 1FFF ]] [[ HEX: 200C HEX: 200D ]] [[ HEX: 2070 HEX: 218F ]] { CHAR: A CHAR: Z }
[[ HEX: 2C00 HEX: 2FEF ]] [[ HEX: 3001 HEX: D7FF ]] [[ HEX: F900 HEX: FDCF ]] { CHAR: a CHAR: z }
[[ HEX: FDF0 HEX: FFFD ]] [[ HEX: 10000 HEX: EFFFF ]] { HEX: C0 HEX: D6 }
} in-range-seq? or ; { HEX: D8 HEX: F6 }
{ HEX: F8 HEX: 2FF }
{ HEX: 370 HEX: 37D }
{ HEX: 37F HEX: 1FFF }
{ HEX: 200C HEX: 200D }
{ HEX: 2070 HEX: 218F }
{ HEX: 2C00 HEX: 2FEF }
{ HEX: 3001 HEX: D7FF }
{ HEX: F900 HEX: FDCF }
{ HEX: FDF0 HEX: FFFD }
{ HEX: 10000 HEX: EFFFF }
} in-range-seq? ;
: name-char? ( ch -- ? ) : name-char? ( ch -- ? )
dup name-start-char? over "-." member? or over HEX: B7 = or swap dup name-start-char? swap {
{ [[ CHAR: 0 CHAR: 9 ]] [[ HEX: 300 HEX: 36F ]] [[ HEX: 203F HEX: 2040 ]] } { CHAR: - CHAR: - }
in-range-seq? or ; { CHAR: . CHAR: . }
{ CHAR: 0 CHAR: 9 }
{ HEX: b7 HEX: b7 }
{ HEX: 300 HEX: 36F }
{ HEX: 203F HEX: 2040 }
} in-range-seq? or ;
: parse-name ( -- name ) : parse-name ( -- name )
char dup name-start-char? [ char dup name-start-char? [
@ -184,56 +192,70 @@ M: xml-string-error error.
"Malformed name" <xml-string-error> throw "Malformed name" <xml-string-error> throw
] if ; ] if ;
: parse-quot ( ch -- str )
incr-spot [ dupd = ] take-until parse-text nip incr-spot ;
: parse-prop-value ( -- str )
char dup "'\"" member? [
parse-quot
] [
"Attribute lacks quote" <xml-string-error> throw
] if ;
: parse-prop ( -- { name value } )
parse-name pass-blank CHAR: = expect pass-blank
parse-prop-value 2array pass-blank ;
TUPLE: opener name props ; TUPLE: opener name props ;
TUPLE: closer name ; TUPLE: closer name ;
TUPLE: contained name props ; TUPLE: contained name props ;
TUPLE: comment text ; TUPLE: comment text ;
TUPLE: directive text ;
: start-tag ( -- string ? ) : start-tag ( -- string ? )
#! Outputs the name and whether this is a closing tag #! Outputs the name and whether this is a closing tag
char CHAR: / = dup [ incr-spot ] when char CHAR: / = dup [ incr-spot ] when
parse-name swap ; parse-name swap ;
: (middle-tag) ( list -- list ) : (parse-quot) ( ch buf -- buf )
pass-blank char name-char? [ parse-prop swons (middle-tag) ] when ; {
{ [ more? not ] [ nip ] }
{ [ char pick = ] [ incr-spot nip ] }
{ [ char CHAR: & = ] [ parse-entity parsed-ch (parse-quot) ] }
{ [ t ] [ char parsed-ch (parse-quot) ] }
} cond ;
: middle-tag ( -- hash ) : parse-quot ( ch -- str )
f (middle-tag) alist>hash ; SBUF" " clone (parse-quot) >string ;
: end-tag ( string hash -- tag ) : parse-prop-value ( -- str )
pass-blank char CHAR: / = [ char dup "'\"" member? [
<contained> incr-spot incr-spot parse-quot
] [ ] [
<opener> "Attribute lacks quote" <xml-string-error> throw
] if ; ] if ;
: parse-prop ( -- name value )
parse-name pass-blank CHAR: = expect pass-blank
parse-prop-value 2array ;
: (middle-tag) ( seq -- seq )
pass-blank char name-char?
[ parse-prop over push (middle-tag) ] when ;
: middle-tag ( -- hash )
V{ } clone (middle-tag) alist>hash pass-blank ;
: end-tag ( string hash -- tag )
pass-blank char CHAR: / =
[ <contained> incr-spot ] [ <opener> ] if ;
: skip-comment ( -- comment ) : skip-comment ( -- comment )
"--" expect-string "--" take-until-string <comment> CHAR: > expect ; "--" expect-string
"--" take-until-string
<comment>
CHAR: > expect ;
: cdata ( -- string ) : cdata ( -- string )
"[CDATA[" expect-string "]]>" take-until-string ; "[CDATA[" expect-string "]]>" take-until-string ;
: cdata/comment ( -- object ) : directive ( -- object )
incr-spot char CHAR: - = [ skip-comment ] [ cdata ] if ; {
{ [ "--" string-matches? ] [ skip-comment ] }
{ [ "[CDATA[" string-matches? ] [ cdata ] }
{ [ t ] [ ">" take-until-string <directive> ] }
} cond ;
: make-tag ( -- tag/f ) : make-tag ( -- tag/f )
CHAR: < expect CHAR: < expect
char CHAR: ! = [ char CHAR: ! = [
cdata/comment incr-spot directive
] [ ] [
start-tag [ start-tag [
<closer> <closer>
@ -251,30 +273,11 @@ TUPLE: comment text ;
"version" swap hash [ version set ] when* "version" swap hash [ version set ] when*
] when ; ] when ;
: dip-ns ( quot -- )
n> slip >n ; inline
: (xml-each) ( quot -- )
get-text swap [ dip-ns ] keep
more? [
make-tag [ swap [ dip-ns ] keep ] when* (xml-each)
] [ drop ] if ; inline
: xml-each ( string quot -- | quot: node -- )
#! Quotation is called with each node: an opener, closer, contained,
#! comment, or string
#! Somewhat like SAX but vastly simplified.
[
swap code set
[ spot line column ] [ 0 swap set ] each
"1.0" version set
get-version (xml-each)
] with-scope ; inline
! * Data tree ! * Data tree
TUPLE: tag name props children ; TUPLE: tag name props children ;
! A stack of { tag children } pairs
SYMBOL: xml-stack SYMBOL: xml-stack
TUPLE: mismatched open close ; TUPLE: mismatched open close ;
@ -285,47 +288,62 @@ M: mismatched error.
TUPLE: unclosed tags ; TUPLE: unclosed tags ;
C: unclosed ( -- unclosed ) C: unclosed ( -- unclosed )
1 xml-stack get tail-slice [ car opener-name ] map 1 xml-stack get tail-slice [ first opener-name ] map
swap [ set-unclosed-tags ] keep ; swap [ set-unclosed-tags ] keep ;
M: unclosed error. M: unclosed error.
"Unclosed tags" print "Unclosed tags" print
"Tags: " print "Tags: " print
unclosed-tags [ " <" write write ">" print ] each ; unclosed-tags [ " <" write write ">" print ] each ;
: push-datum ( object -- ) : add-child ( object -- )
xml-stack get peek cdr push ; xml-stack get peek second push ;
: push-xml-stack ( object -- )
V{ } clone 2array xml-stack get push ;
GENERIC: process ( object -- ) GENERIC: process ( object -- )
M: string process push-datum ; M: f process drop ;
M: comment process push-datum ;
M: string process add-child ;
M: comment process add-child ;
M: directive process add-child ;
M: contained process M: contained process
[ contained-name ] keep contained-props 0 <vector> <tag> push-datum ; [ contained-name ] keep contained-props
V{ } clone <tag> add-child ;
M: opener process M: opener process
V{ } clone cons push-xml-stack ;
xml-stack get push ;
M: closer process M: closer process
closer-name xml-stack get pop uncons closer-name xml-stack get pop first2 >r [
>r [
opener-name [ opener-name [
2dup = [ 2drop ] [ swap <mismatched> throw ] if 2dup = [ 2drop ] [ swap <mismatched> throw ] if
] keep ] keep
] keep opener-props r> <tag> push-datum ; ] keep opener-props r> <tag> add-child ;
: initialize-xml-stack ( -- ) : init-xml-stack ( -- )
f V{ } clone cons unit >vector xml-stack set ; V{ } clone xml-stack set f push-xml-stack ;
: xml ( string -- tag ) : init-xml ( string -- )
code set
[ spot line column ] [ 0 swap set ] each
"1.0" version set
init-xml-stack ;
: (string>xml) ( -- )
parse-text process
more? [ make-tag process (string>xml) ] when ; inline
: string>xml ( string -- tag )
#! Produces a tree of XML nodes #! Produces a tree of XML nodes
[ [
initialize-xml-stack init-xml
[ process ] xml-each get-version (string>xml)
xml-stack get xml-stack get
dup length 1 = [ <unclosed> throw ] unless dup length 1 = [ <unclosed> throw ] unless
first cdr second first second
] with-scope ; ] with-scope ;
! * Printer ! * Printer
@ -356,16 +374,14 @@ M: tag (xml>string)
CHAR: < , CHAR: < ,
dup tag-name % dup tag-name %
dup tag-props print-props dup tag-props print-props
dup tag-children [ "" = not ] subset empty? [ dup tag-children [ empty? not ] contains?
drop "/>" % [ print-open/close ] [ drop "/>" % ] if ;
] [
print-open/close
] if ;
M: comment (xml>string) M: comment (xml>string)
"<!--" % "<!--" % comment-text % "-->" % ;
comment-text %
"-->" % ; M: object (xml>string)
[ (xml>string) ] each ;
: xml-preamble : xml-preamble
"<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>" ; "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>" ;
@ -374,13 +390,13 @@ M: comment (xml>string)
[ xml-preamble % (xml>string) ] "" make ; [ xml-preamble % (xml>string) ] "" make ;
: xml-reprint ( string -- string ) : xml-reprint ( string -- string )
xml xml>string ; string>xml xml>string ;
! * Easy XML generation for more literal things ! * Easy XML generation for more literal things
! should this be rewritten? ! should this be rewritten?
: text ( string -- ) : text ( string -- )
chars>entities push-datum ; chars>entities add-child ;
: tag ( string attr-quot contents-quot -- ) : tag ( string attr-quot contents-quot -- )
>r swap >r make-hash r> swap r> >r swap >r make-hash r> swap r>
@ -391,15 +407,15 @@ M: comment (xml>string)
: text-tag ( content name attr-quot -- ) [ text ] tag ; inline : text-tag ( content name attr-quot -- ) [ text ] tag ; inline
: comment ( string -- ) : comment ( string -- )
<comment> push-datum ; <comment> add-child ;
: make-xml ( quot -- vector ) : make-xml ( quot -- vector )
#! Produces a tree of XML from a quotation to generate it #! Produces a tree of XML from a quotation to generate it
[ [
initialize-xml-stack init-xml-stack
call call
xml-stack get xml-stack get
first cdr first first second first
] with-scope ; inline ] with-scope ; inline
! * System for words specialized on tag names ! * System for words specialized on tag names
@ -416,14 +432,3 @@ M: process-missing error.
>r dup tag-name r> hash* [ 2nip call ] [ >r dup tag-name r> hash* [ 2nip call ] [
drop <process-missing> throw drop <process-missing> throw
] if ; ] if ;
: PROCESS:
CREATE
dup H{ } clone "xtable" set-word-prop
dup literalize [ run-process ] cons define-compound ; parsing
: TAG:
scan scan-word [
swap "xtable" word-prop
rot "/" split [ >r 2dup r> swap set-hash ] each 2drop
] f ; parsing

41
library/bootstrap/win32-io.factor → contrib/lazy-lists/examples.factor
View File

@ -1,8 +1,6 @@
! :folding=indent:collapseFolds=1: ! Rewritten by Matthew Willis, July 2006
! $Id$
! !
! Copyright (C) 2003, 2004 Mackenzie Straight. ! Copyright (C) 2004 Chris Double.
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met: ! modification, are permitted provided that the following conditions are met:
@ -25,25 +23,26 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: io USING: lazy-lists math kernel sequences test ;
USE: compiler IN: lazy-examples
USE: namespaces
USE: kernel
USE: win32-io-internals
USE: win32-stream
USE: win32-api
: <file-reader> <win32-file-reader> ; : naturals 0 lfrom ;
: <file-writer> <win32-file-writer> ; : positves 1 lfrom ;
: <server> <win32-server> ; : evens 0 [ 2 + ] lfrom-by ;
: odds 1 lfrom [ 2 mod 1 = ] lsubset ;
: powers-of-2 1 [ 2 * ] lfrom-by ;
: ones 1 [ ] lfrom-by ;
: squares naturals [ dup * ] lmap ;
: first-five-squares 5 squares ltake list>array ;
IN: io-internals : divisible-by? ( a b -- bool )
#! Return true if a is divisible by b
mod 0 = ;
: io-multiplex ( timeout -- ) : filter-multiples ( n list - list )
#! FIXME: needs to work given a timeout #! Given a lazy list of numbers, filter multiples of n
dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io swap [ divisible-by? not ] curry lsubset ;
swap [ continue-with ] [ drop ] if* ;
: init-io ( -- ) : primes 2 lfrom [ filter-multiples ] lapply ;
win32-init-stdio ;
: first-ten-primes 10 primes ltake list>array ;

207
contrib/lazy-lists/lists.factor Normal file
View File

@ -0,0 +1,207 @@
! Updated by Matthew Willis, July 2006
!
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USING: kernel sequences math vectors arrays namespaces ;
IN: lazy-lists
TUPLE: promise quot forced? value ;
C: promise ( quot -- promise ) [ set-promise-quot ] keep ;
: force ( promise -- value )
#! Force the given promise leaving the value of calling the
#! promises quotation on the stack. Re-forcing the promise
#! will return the same value and not recall the quotation.
dup promise-forced? [
dup promise-quot call over set-promise-value
t over set-promise-forced?
] unless
promise-value ;
TUPLE: cons car cdr ;
: nil ( -- list )
#! The nil lazy list.
T{ promise f [ { } ] t { } } ;
: nil? ( list -- bool )
#! Is the given lazy cons the nil value
force { } = ;
: car ( list -- car )
#! Return the value of the head of the lazy list.
force cons-car ;
: cdr ( list -- cdr )
#! Return the rest of the lazy list.
#! This is itself a lazy list.
force cons-cdr ;
: cons ( car cdr -- list )
#! Given a car and cdr, both lazy values, return a lazy cons.
[ swap , , \ <cons> , ] [ ] make <promise> ;
: lunit ( obj -- list )
#! Given a value produce a lazy list containing that value.
nil cons ;
: lnth ( n list -- value )
#! Return the nth item in a lazy list
swap [ cdr ] times car ;
: uncons ( cons -- car cdr )
#! Return the car and cdr of the lazy list
force dup cons-car swap cons-cdr ;
: force-promise ( list-quot -- list )
#! Promises to force list-quot, which should be
#! a quot that produces a list.
#! This allows caching of the resultant list value.
[ call \ force , ] [ ] make <promise> ; inline
DEFER: lmap
: (lmap) ( list quot -- list )
over nil? [ drop ]
[
swap 2dup
cdr swap lmap >r
car swap call r>
cons
] if ;
: lmap ( list quot -- list )
#! Return a lazy list containing the collected result of calling
#! quot on the original lazy list.
[ swap , , \ (lmap) , ] force-promise ;
DEFER: ltake
: (ltake) ( n list -- list )
over 0 = [ 2drop nil ]
[ dup nil? [ nip ]
[
swap ( list n -- list )
1 - >r uncons r> swap ltake
cons
] if
] if ;
: ltake ( n list -- list )
#! Return a lazy list containing the first n items from
#! the original lazy list.
[ swap , , \ (ltake) , ] force-promise ;
DEFER: lsubset
: (lsubset) ( list pred -- list )
>r dup nil? [ r> drop ]
[
uncons swap dup r> dup >r call
[ swap r> lsubset cons ]
[ drop r> (lsubset) ] if
] if ;
: lsubset ( list pred -- list )
#! Return a lazy list containing the elements in llist
#! satisfying pred
[ swap , , \ (lsubset) , ] force-promise ;
: (list>backwards-vector) ( list -- vector )
dup nil? [ drop V{ } clone ]
[ uncons (list>backwards-vector) swap over push ] if ;
: list>vector ( list -- vector )
#! Convert a lazy list to a vector. This will cause
#! an infinite loop if the lazy list is an infinite list.
(list>backwards-vector) reverse ;
: list>array ( list -- array )
list>vector >array ;
DEFER: backwards-vector>list
: (backwards-vector>list) ( vector -- list )
dup empty? [ drop nil ]
[ dup pop swap backwards-vector>list cons ] if ;
: backwards-vector>list ( vector -- list )
[ , \ (backwards-vector>list) , ] force-promise ;
: array>list ( array -- list )
#! Convert a list to a lazy list.
reverse >vector backwards-vector>list ;
DEFER: lappend*
: (lappend*) ( lists -- list )
dup nil? [
uncons >r dup nil? [ drop r> (lappend*) ]
[ uncons r> cons lappend* cons ] if
] unless ;
: lappend* ( llists -- list )
#! Given a lazy list of lazy lists, concatenate them
#! together in a lazy fashion. The actual appending is
#! done lazily on iteration rather than immediately
#! so it works very fast no matter how large the lists.
[ , \ (lappend*) , ] force-promise ;
: lappend ( list1 list2 -- llist )
#! Concatenate two lazy lists such that they appear to be one big
#! lazy list.
lunit cons lappend* ;
: leach ( list quot -- )
#! Call the quotation on each item in the lazy list.
#! Warning: If the list is infinite then this will
#! never return.
swap dup nil? [ 2drop ] [
uncons swap pick call swap leach
] if ;
DEFER: lapply
: (lapply) ( list quot -- list )
over nil? [ drop ] [
swap dup car >r uncons pick call swap lapply
r> swap cons
] if ;
: lapply ( list quot -- list )
#! Returns a lazy list which is
#! (cons (car list)
#! (lapply (quot (car list) (cdr list)) quot))
#! This allows for complicated list functions
[ swap , , \ (lapply) , ] force-promise ;
DEFER: lfrom-by
: (lfrom-by) ( n quot -- list )
2dup call swap lfrom-by cons ;
: lfrom-by ( n quot -- list )
#! Return a lazy list of values starting from n, with
#! each successive value being the result of applying quot to
#! n.
[ swap , , \ (lfrom-by) , ] force-promise ;
: lfrom ( n -- list )
#! Return a lazy list of increasing numbers starting
#! from the initial value 'n'.
[ 1 + ] lfrom-by ;

7
contrib/lazy-lists/load.factor Normal file
View File

@ -0,0 +1,7 @@
PROVIDE: lazy-lists {
"lists.factor"
"examples.factor"
} {
"test/lists.factor"
"test/examples.factor"
} ;

0
contrib/parser-combinators/lazy.html → contrib/lazy-lists/old-doc.html
View File

6
contrib/lazy-lists/test/examples.factor Normal file
View File

@ -0,0 +1,6 @@
USING: lazy-examples lazy-lists test ;
IN: temporary
[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
[ { 2 3 5 7 11 13 17 19 23 29 } ] [ first-ten-primes ] unit-test

84
library/windows/win32-errors.factor → contrib/lazy-lists/test/lists.factor
View File

@ -1,8 +1,4 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2006 Matthew Willis.
! $Id$
!
! Copyright (C) 2004 Mackenzie Straight.
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met: ! modification, are permitted provided that the following conditions are met:
@ -25,46 +21,40 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: win32-api USING: lazy-lists test kernel math io ;
USE: errors IN: temporary
USE: kernel
USE: io-internals
USE: lists
USE: math
USE: parser
USE: alien
USE: words
USE: sequences
: CONSTANT: CREATE
[ [ [ swons ] each ] cons define-compound POSTPONE: parsing ]
[ ] ; parsing
CONSTANT: ERROR_SUCCESS 0 ;
CONSTANT: ERROR_HANDLE_EOF 38 ;
CONSTANT: ERROR_IO_PENDING 997 ;
CONSTANT: WAIT_TIMEOUT 258 ;
: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
: MAKELANGID ( primary sub -- lang )
10 shift bitor ;
: LANG_NEUTRAL 0 ;
: SUBLANG_DEFAULT 1 ;
: GetLastError ( -- int )
"int" "kernel32" "GetLastError" [ ] alien-invoke ;
: win32-error-message ( id -- string )
"char*" f "error_message" [ "int" ] alien-invoke ;
: win32-throw-error ( -- )
GetLastError win32-error-message throw ;
[ t ] [ nil nil? ] unit-test
[ 5 ] [ 5 lunit car ] unit-test
[ f ] [ nil nil cons nil? ] unit-test
[ 5 t ] [ 5 lunit uncons nil? ] unit-test
[ 6 ] [
5 6 lunit cons
1 swap lnth
] unit-test
[ 12 13 t ] [
5 6 lunit cons
[ 7 + ] lmap uncons uncons nil?
] unit-test
[ 5 6 t ] [
5 6 7 lunit cons cons 2 swap ltake
uncons uncons nil?
] unit-test
[ 6 7 t ] [ 5 6 7 lunit cons cons [ 5 > ] lsubset
uncons uncons nil? ] unit-test
[ 7 t ] [ 5 6 7 lunit cons cons [ 6 > ] lsubset
uncons nil? ] unit-test
[ 1 3 5 t ] [ { 1 3 5 } array>list
uncons uncons uncons nil? ] unit-test
[ { 1 3 5 } ] [ { 1 3 5 } array>list list>array ] unit-test
[ { 1 2 3 4 5 6 7 8 9 } ] [
{ 1 2 3 } array>list
{ 4 5 6 } array>list
{ 7 8 9 } array>list
lunit cons cons lappend* list>array ] unit-test
[ { 1 2 3 4 5 6 } ]
[ { 1 2 3 } array>list { 4 5 6 } array>list
lappend list>array ] unit-test
[ ] [ { 1 2 3 } array>list [ 3 + number>string print ] leach ] unit-test
[ { 1 2 3 4 } ]
[ 0 lfrom [ 5 < ] lsubset [ 0 > ] lsubset 4 swap ltake list>array ] unit-test

26
contrib/load.factor
View File

@ -1,26 +0,0 @@
! Load all contrib libs, compile them, and save a new image.
IN: scratchpad
USING: alien compiler kernel memory parser sequences words ;
{
"coroutines"
"dlists"
"splay-trees"
} [ "/contrib/" swap ".factor" append3 run-resource clear ] each
{ "cairo"
"math"
"concurrency"
"crypto"
"aim"
"httpd"
"units"
"sqlite"
"win32"
"x11"
! "factory" has a C component, ick.
"postgresql"
"parser-combinators"
"cont-responder"
"space-invaders"
} [ "/contrib/" swap "/load.factor" append3 run-resource clear ] each

19
contrib/math/combinatorics.factor
View File

@ -17,19 +17,24 @@ USING: kernel sequences errors namespaces math ;
#! calculate n! given n, k, k! #! calculate n! given n, k, k!
(k..n] product * ; (k..n] product * ;
: nCk ( n k -- nCk ) : nCk ( n k -- nCk )
#! uses the results from min(k!,(n-k)!) to compute max(k!,(n-k)!) #! uses the results from min(k!,(n-k)!) to compute max(k!,(n-k)!)
#! use max(k!,(n-k)!) to compute n! #! use max(k!,(n-k)!) to compute n!
2dup < [ "n >= k only" throw ] when 2dup < [
[ - ] 2keep rot 2dup < [ swap ] when 2drop 0
[ factorial ] keep over ] [
>r rot [ factorial-part ] keep rot pick >r factorial-part r> r> * / ; [ - ] 2keep rot 2dup < [ swap ] when
[ factorial ] keep over
>r rot [ factorial-part ] keep rot pick >r factorial-part r> r> * /
] if ;
: nPk ( n k -- nPk ) : nPk ( n k -- nPk )
#! uses the results from (n-k)! to compute n! #! uses the results from (n-k)! to compute n!
2dup < [ "n >= k only" throw ] when 2dup < [
2dup - nip [ factorial ] keep rot pick >r factorial-part r> / ; 2drop 0
] [
2dup - nip [ factorial ] keep rot pick >r factorial-part r> /
] if ;
: binomial ( n k -- nCk ) : binomial ( n k -- nCk )
#! same as nCk #! same as nCk

365
contrib/math/infix.factor
View File

@ -1,365 +0,0 @@
IN: infix
USING: arrays errors generic hashtables io kernel kernel-internals lists math math-contrib namespaces parser parser-combinators prettyprint sequences strings vectors words ;
: 2list ( x y -- [ x y ] ) f cons cons ;
! Tokenizer
TUPLE: tok char ;
TUPLE: brackets seq ender ;
SYMBOL: apostrophe
SYMBOL: code #! Source code
SYMBOL: spot #! Current index of string
: take-until ( quot -- parsed-stuff | quot: char -- ? )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
>r spot get code get 2dup r>
skip [ swap subseq ] keep
spot set ;
: parse-blank ( -- )
#! Advance code past any whitespace, including newlines
spot get code get [ blank? not ] skip spot set ;
: not-done? ( -- ? )
#! Return t if spot is not at the end of code
code get length spot get = not ;
: incr-spot ( -- )
#! Increment spot.
spot [ 1 + ] change ;
: parse-var ( -- variable-name )
#! Take a series of letters from code, advancing
#! spot and returning the letters.
[ letter? not ] take-until ;
: parse-num ( -- number )
#! Take a number from code, advancing spot and
#! returning the number.
[ "0123456789." member? not ] take-until string>number ;
: get-token ( -- char )
spot get code get nth ;
DEFER: token
: next-token ( list -- list )
#! Take one token from code and return it
parse-blank not-done? [
get-token token
] when ;
: token
{
{ [ dup letter? ] [ drop parse-var swons ] }
{ [ dup "0123456789." member? ] [ drop parse-num swons ] }
{ [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ <tok> swons incr-spot ] }
{ [ dup "([{" member? ] [ drop f incr-spot ] }
{ [ dup ")]}" member? ] [ <brackets> swons incr-spot ] }
{ [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
{ [ t ] [ "Bad character " swap ch>string append throw ] }
} cond next-token ;
: tokenize ( string -- tokens )
#! Tokenize a string, returning a list of tokens
[
code set 0 spot set
f next-token reverse
] with-scope ;
! Parser
TUPLE: apply func args ;
#! Function application
C: apply
>r [ ] subset r>
[ set-apply-args ] keep
[ set-apply-func ] keep ;
UNION: value number string ;
: semicolon ( -- semicolon )
#! The semicolon token
T{ tok f CHAR: ; } ;
: unswons uncons swap ;
: nest-apply ( [ ast ] -- apply )
unswons unit swap [
swap <apply> unit
] each car ;
GENERIC: parse-token ( ast tokens token -- ast tokens )
#! Take one or more tokens
DEFER: parse-tokens
: semicolon-split ( list -- [ ast ] )
reverse semicolon unit split [ parse-tokens ] map ;
M: value parse-token
swapd swons swap ;
M: brackets parse-token
swapd dup brackets-seq swap brackets-ender {
{ [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> <apply> swons ] }
{ [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
{ [ CHAR: ) = ] [ reverse parse-tokens swons ] }
} cond swap ;
M: object tok-char drop -1 ; ! Hack!
GENERIC: tok>string ( token/string -- string )
M: tok tok>string
tok-char ch>string ;
M: string tok>string ;
: binary-op ( ast tokens token -- ast )
>r >r unswons r> parse-tokens 2list r>
tok>string swap <apply> swons ;
: unary-op ( ast tokens token -- ast )
tok>string -rot nip
parse-tokens unit <apply> unit ;
: null-op ( ast tokens token -- ast )
nip tok-char ch>string swons ;
M: tok parse-token
over [
pick [
binary-op
] [
unary-op
] if
] [
null-op
] if f ;
( ast tokens token -- ast tokens )
M: symbol parse-token ! apostrophe
drop unswons >r parse-tokens >r unswons r> 2list r>
unit parse-tokens swap <apply> swons f ;
: (parse-tokens) ( ast tokens -- ast )
dup [
unswons parse-token (parse-tokens)
] [
drop
] if ;
: parse-tokens ( tokens -- ast )
#! Convert a list of tokens into an AST
f swap (parse-tokens) nest-apply ;
: parse-full ( string -- ast )
#! Convert a string into an AST
tokenize parse-tokens ;
! Compiler
GENERIC: compile-ast ( vars ast -- quot )
M: string compile-ast ! variables
swap index dup -1 = [
"Variable not found" throw
] [
[ swap array-nth ] cons
] if ;
: replace-with ( data -- [ drop data ] )
\ drop swap 2list ;
UNION: comp-literal number general-list ;
M: comp-literal compile-ast ! literal numbers
replace-with nip ;
: accumulator ( vars { asts } quot -- quot )
-rot [
[
\ dup ,
compile-ast %
dup %
] each-with
] [ ] make nip ;
M: vector compile-ast ! literal vectors
dup [ number? ] all? [
replace-with nip
] [
[ , ] accumulator [ { } make nip ] cons
] if ;
: infix-relation
#! Wraps operators like = and > so that if they're given
#! f as either argument, they return f, and they return f if
#! the operation yields f, but if it yields t, it returns the
#! left argument. This way, these types of operations can be
#! composed.
>r 2dup and not [
r> 3drop f
] [
dupd r> call [
drop f
] unless
] if ;
: functions
#! Regular functions
#! Gives quotation applicable to stack
H{
[ [[ "+" 2 ]] + ]
[ [[ "-" 2 ]] - ]
[ [[ ">" 2 ]] [ > ] infix-relation ]
[ [[ "<" 2 ]] [ < ] infix-relation ]
[ [[ "=" 2 ]] [ = ] infix-relation ]
[ [[ "-" 1 ]] neg ]
[ [[ "~" 1 ]] not ]
[ [[ "&" 2 ]] and ]
[ [[ "|" 2 ]] or ]
[ [[ "&" 1 ]] t [ and ] reduce ]
[ [[ "|" 1 ]] f [ or ] reduce ]
[ [[ "*" 2 ]] * ]
[ [[ "ln" 1 ]] log ]
[ [[ "plusmin" 2 ]] [ + ] 2keep - ]
[ [[ "@" 2 ]] swap nth ]
[ [[ "sqrt" 1 ]] sqrt ]
[ [[ "/" 2 ]] / ]
[ [[ "^" 2 ]] ^ ]
[ [[ "#" 1 ]] length ]
[ [[ "eq" 2 ]] eq? ]
[ [[ "*" 1 ]] first ]
[ [[ "+" 1 ]] flip ]
[ [[ "\\" 1 ]] <reversed> ]
[ [[ "sin" 1 ]] sin ]
[ [[ "cos" 1 ]] cos ]
[ [[ "tan" 1 ]] tan ]
[ [[ "max" 2 ]] max ]
[ [[ "min" 2 ]] min ]
[ [[ "," 2 ]] append ]
[ [[ "," 1 ]] concat ]
[ [[ "sn" 3 ]] -rot set-nth ]
[ [[ "prod" 1 ]] product ]
[ [[ "vec" 1 ]] >vector ]
} ;
: drc ( list -- list )
#! all of list except last element (backwards cdr)
dup cdr [
uncons drc cons
] [
drop f
] if ;
: map-with-left ( seq object quot -- seq )
[ swapd call ] cons swapd map-with ; inline
: high-functions
#! Higher-order functions
#! Gives quotation applicable to quotation and rest of stack
H{
[ [[ "!" 2 ]] 2map ]
[ [[ "!" 1 ]] map ]
[ [[ ">" 2 ]] map-with ]
[ [[ "<" 2 ]] map-with-left ]
[ [[ "^" 1 ]] all? ]
[ [[ "~" 1 ]] call not ]
[ [[ "~" 2 ]] call not ]
[ [[ "/" 2 ]] swapd reduce ]
[ [[ "\\" 2 ]] swapd accumulate ]
} ;
: get-hash ( key table -- value )
#! like hash but throws exception if f
dupd hash [ nip ] [
[ "Key not found " write . ] string-out throw
] if* ;
: >apply< ( apply -- func args )
dup apply-func swap apply-args ;
: make-apply ( arity apply/string -- quot )
dup string? [
swons functions get-hash
] [
>apply< car >r over r> make-apply
-rot swons high-functions get-hash cons
] if ;
: get-function ( apply -- quot )
>apply< length swap make-apply ;
M: apply compile-ast ! function application
[ apply-args [ swap ] accumulator [ drop ] append ] keep
get-function append ;
: push-list ( list item -- list )
unit append ;
: parse-comp ( args string -- quot )
#! Compile a string into a quotation w/o prologue
parse-full compile-ast ;
: prologue ( args -- quot )
#! Build the prolog for a function
[
length dup , \ <array> ,
[ 1 - ] keep [
2dup - [ swap set-array-nth ] cons , \ keep ,
] repeat drop
] [ ] make ;
: ast>quot ( args ast -- quot )
over prologue -rot compile-ast append ;
: define-math ( seq -- )
" " join
dup parse-full apply-args uncons car swap
>apply< >r create-in r>
[ "math-args" set-word-prop ] 2keep
>r tuck >r >r swap "code" set-word-prop r> r> r>
rot ast>quot define-compound ;
: MATH:
#! MATH: sq[x]=x*x ;
"in-definition" on
string-mode on
[
string-mode off define-math
] f ; parsing
: TEST-MATH:
#! Executes and prints the result of a math
#! expression at parsetime
string-mode on [
" " join string-mode off parse-full
f swap ast>quot call .
] f ; parsing
! PREDICATE: compound infix-word "code" word-prop ;
! M: infix-word definer
! drop POSTPONE: MATH: ;
! M: infix-word class.
! "code" word-prop write " ;" print ;
!
! Redefine compound to not include infix words so see works
! IN: words
! USING: kernel words parse-k ;
!
! PREDICATE: word compound
! dup word-primitive 1 = swap infix-word? not and ;
MATH: quadratic[a;b;c] =
plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;

23
contrib/math/load.factor
View File

@ -1,13 +1,10 @@
IN: scratchpad PROVIDE: math {
USING: kernel parser sequences words compiler ; "utils.factor"
"combinatorics.factor"
{ "analysis.factor"
"utils" "polynomials.factor"
"combinatorics" "quaternions.factor"
"analysis" "matrices.factor"
"polynomials" "statistics.factor"
"quaternions" "numerical-integration.factor"
"matrices" } ;
"statistics"
"numerical-integration"
} [ "/contrib/math/" swap ".factor" append3 run-resource ] each

3
contrib/math/numerical-integration.factor
View File

@ -1,7 +1,6 @@
IN: math-contrib IN: math-contrib
USING: kernel sequences errors namespaces math lists vectors errors prettyprint ; USING: kernel sequences errors namespaces math vectors errors prettyprint io inspector ;
USING: io inspector ;
: setup-range ( from to -- frange ) : setup-range ( from to -- frange )
step-size get swap <frange> ; step-size get swap <frange> ;

7
contrib/math/utils.factor
View File

@ -13,6 +13,13 @@ USING: errors kernel sequences math sequences-internals namespaces arrays ;
gcd 1 = [ "Non-trivial divisor found" throw ] unless ; gcd 1 = [ "Non-trivial divisor found" throw ] unless ;
foldable foldable
: each-bit ( n quot -- | quot: 0/1 -- )
over zero? pick -1 number= or [
2drop
] [
2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
] if ; inline
: (^mod) ( n z w -- z^w ) : (^mod) ( n z w -- z^w )
1 swap [ 1 swap [
1 number= [ dupd * pick mod ] when >r sq over mod r> 1 number= [ dupd * pick mod ] when >r sq over mod r>

66
contrib/parser-combinators/lazy-examples.factor
View File

@ -1,66 +0,0 @@
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lazy-examples
USE: lazy
USE: math
USE: lists
USE: parser-combinators
USE: kernel
USE: sequences
USE: namespaces
: lfrom ( n -- llist )
#! Return a lazy list of increasing numbers starting
#! from the initial value 'n'.
dup unit delay swap
[ 1 + lfrom ] cons delay lcons ;
: lfrom-by ( n quot -- llist )
#! Return a lazy list of values starting from n, with
#! each successive value being the result of applying quot to
#! n.
swap dup unit delay -rot
[ , dup , \ call , , \ lfrom-by , ] [ ] make delay lcons ;
: lnaturals 0 lfrom ;
: lpositves 1 lfrom ;
: levens 0 [ 2 + ] lfrom-by ;
: lodds 1 lfrom [ 2 mod 1 = ] lsubset ;
: lpowers-of-2 1 [ 2 * ] lfrom-by ;
: lones 1 [ ] lfrom-by ;
: lsquares lnaturals [ dup * ] lmap ;
: first-five-squares 5 lsquares ltake ;
: divisible-by? ( a b -- bool )
#! Return true if a is divisible by b
mod 0 = ;
: sieve ( llist - llist )
#! Given a lazy list of numbers, use the sieve of eratosthenes
#! algorithm to return a lazy list of primes.
luncons over [ divisible-by? not ]
cons lsubset [ sieve ] cons delay >r unit delay r> lcons ;
: lprimes 2 lfrom sieve ;
: first-ten-primes 10 lprimes ltake llist>list ;

265
contrib/parser-combinators/lazy.factor
View File

@ -1,265 +0,0 @@
! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lazy
USE: kernel
USE: sequences
USE: namespaces
USE: lists
USE: math
TUPLE: promise quot forced? value ;
: delay ( quot -- <promise> )
#! Given a quotation, create a promise which may later be forced.
#! When forced the quotation will execute returning the value. Future
#! forces of the promise will return that value and not re-execute
#! the quotation.
f f <promise> ;
: (force) ( <promise> -- value )
#! Force the given promise leaving the value of calling the
#! promises quotation on the stack. Re-forcing the promise
#! will return the same value and not recall the quotation.
dup promise-forced? [
dup promise-quot call over set-promise-value
t over set-promise-forced?
] unless
promise-value ;
: force ( <promise> -- value )
(force) dup promise? [
force
] when ;
TUPLE: lcons car cdr ;
SYMBOL: lazy-nil
DEFER: lnil
[ [ ] ] delay lazy-nil set
: lnil ( -- lcons )
#! Return the nil lazy list.
lazy-nil get ;
: lnil? ( lcons -- bool )
#! Is the given lazy cons the nil value
force not ;
: lcar ( lcons -- car )
#! Return the value of the head of the lazy list.
dup lnil? [
force lcons-car (force)
] unless ;
: lcdr ( lcons -- cdr )
#! Return the value of the rest of the lazy list.
#! This is itself a lazy list.
dup lnil? [
force lcons-cdr (force)
] unless ;
: lcons ( lcar lcdr -- promise )
#! Given a car and cdr, both lazy values, return a lazy cons.
swap [ , , \ <lcons> , ] [ ] make delay ;
: lunit ( lvalue -- llist )
#! Given a lazy value (a quotation that when called produces
#! the value) produce a lazy list containing that value.
[ lnil ] delay lcons ;
: lnth ( n llist -- value )
#! Return the nth item in a lazy list
swap [ lcdr ] times lcar ;
: luncons ( lcons -- car cdr )
#! Return the car and cdr of the lazy list
dup lcar swap lcdr ;
: lmap ( llist quot -- llist )
#! Return a lazy list containing the collected result of calling
#! quot on the original lazy list.
over lnil? [
drop
] [
swap 2dup
[ , \ lcdr , , \ lmap , ] [ ] make delay >r
[ , \ lcar , , \ call , ] [ ] make delay r>
lcons
] if ;
: ltake ( n llist -- llist )
#! Return a lazy list containing the first n items from
#! the original lazy list.
over 0 = [
2drop lnil
] [
dup lnil? [
nip
] [
swap dupd ( llist llist n -- )
[ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] [ ] make delay >r
[ , \ lcar , ] [ ] make delay r>
lcons
] if
] if ;
DEFER: lsubset
TUPLE: lsubset-state llist pred ;
: (lsubset-cdr) ( state -- llist )
#! Given a predicate and a lazy list, do the cdr
#! portion of lsubset.
dup lsubset-state-llist lcdr swap lsubset-state-pred lsubset ;
: (lsubset-car) ( state -- value )
#! Given a predicate and a lazy list, do the car
#! portion of lsubset.
dup lsubset-state-llist lcar over
lsubset-state-pred dupd call [ ( state lcar -- )
nip
] [ ( state lcar -- )
drop dup lsubset-state-llist lcdr over set-lsubset-state-llist
(lsubset-car)
] if ;
: (lsubset-set-first-car) ( state -- bool )
#! Set the state to the first valid car. If none found
#! return false.
dup lsubset-state-llist lcar over
lsubset-state-pred dupd call [ ( state lcar -- )
2drop t
] [ ( state lcar -- )
drop dup lsubset-state-llist lcdr dup lnil? [
2drop f
] [
over set-lsubset-state-llist
(lsubset-set-first-car)
] if
] if ;
: lsubset ( llist pred -- llist )
#! Return a lazy list containing only the items from the original
#! lazy list for which the predicate returns a value other than f.
over lnil? [
drop
] [
<lsubset-state> dup
(lsubset-set-first-car) [
dup
[ (lsubset-cdr) ] cons delay >r
[ (lsubset-car) ] cons delay r> lcons
] [
drop lnil
] if
] if ;
DEFER: lappend*
DEFER: (lappend*)
TUPLE: lappend*-state current rest ;
USE: io
: (lappend*-cdr) ( state -- llist )
#! Given the state object, do the cdr portion of the
#! lazy append.
dup lappend*-state-current dup lnil? [ ( state current -- )
nip
] [ ( state current -- )
lcdr ( state cdr -- )
dup lnil? [ ( state cdr -- )
drop dup lappend*-state-rest dup lnil? [ ( state rest )
nip
] [
nip
luncons ( state rest-car rest-cdr -- )
<lappend*-state> (lappend*)
] if
] [ ( state cdr -- )
swap lappend*-state-rest <lappend*-state> (lappend*)
] if
] if ;
: (lappend*-car) ( state -- value )
#! Given the state object, do the car portion of the
#! lazy append.
dup lappend*-state-current dup lnil? [ ( state current -- )
nip
] [ ( state current -- )
lcar nip
] if ;
: (lappend*) ( state -- llist )
#! Do the main work of the lazy list appending using a
#! state object.
dup
[ (lappend*-cdr) ] cons delay >r
[ (lappend*-car) ] cons delay r> lcons ;
: lappend* ( llists -- llist )
#! Given a lazy list of lazy lists, return a lazy list that
#! works through all of the sub-lists in sequence.
[ lnil? not ] lsubset
dup lnil? [
luncons <lappend*-state> (lappend*)
] unless ;
DEFER: list>llist
: lappend ( llist1 llist2 -- llist )
#! Concatenate two lazy lists such that they appear to be one big
#! lazy list.
[ ] cons cons list>llist lappend* ;
: leach ( llist quot -- )
#! Call the quotation on each item in the lazy list.
#! Warning: If the list is infinite then this will
#! never return.
over lnil? [
2drop
] [
>r luncons r> tuck >r >r call r> r> leach
] if ;
: (llist>list) ( result llist -- list )
#! Helper function for llist>list.
dup lnil? [
drop
] [
dup lcar ( result llist car )
swap lcdr >r swons r> (llist>list)
] if ;
: llist>list ( llist -- list )
#! Convert a lazy list to a normal list. This will cause
#! an infinite loop if the lazy list is an infinite list.
f swap (llist>list) reverse ;
: list>llist ( list -- llist )
#! Convert a list to a lazy list.
dup [
uncons [ list>llist ] cons delay >r unit delay r> lcons
] [
drop lnil
] if ;

14
contrib/postgresql/load.factor
View File

@ -1,11 +1,5 @@
IN: scratchpad USING: alien ;
USING: alien compiler kernel parser sequences words ;
"postgresql" "libpq" add-simple-library PROVIDE: postgresql
{ "libpq.factor" "postgresql.factor" }
{ { "postgresql-test" } ;
"libpq"
"postgresql"
"postgresql-test"
! "private" ! Put your password in this file
} [ "/contrib/postgresql/" swap ".factor" append3 run-resource ] each

4
contrib/postgresql/postgresql.factor
View File

@ -4,7 +4,7 @@
! tested on debian linux with postgresql 7.4.7 ! tested on debian linux with postgresql 7.4.7
IN: postgresql IN: postgresql
USING: kernel alien errors io prettyprint sequences lists namespaces arrays math ; USING: kernel alien errors io prettyprint sequences namespaces arrays math ;
SYMBOL: postgres-conn SYMBOL: postgres-conn
SYMBOL: query-res SYMBOL: query-res
@ -59,5 +59,3 @@ SYMBOL: query-res
: print-table ( seq -- ) : print-table ( seq -- )
[ [ "\t" append write ] each "\n" write ] each ; [ [ "\t" append write ] each "\n" write ] each ;

6
contrib/process.factor
View File

@ -1,11 +1,13 @@
IN: process IN: process
USING: compiler io io-internals kernel parser ; USING: compiler io io-internals kernel parser ;
FUNCTION: int system ( char* command ) ; compiled FUNCTION: int system ( char* command ) ;
FUNCTION: void* popen ( char* command, char* type ) ; compiled FUNCTION: void* popen ( char* command, char* type ) ;
: <process-stream> ( command mode -- stream ) : <process-stream> ( command mode -- stream )
popen dup <c-stream> ; popen dup <c-stream> ;
: !" parse-string system drop ; parsing : !" parse-string system drop ; parsing
PROVIDE: process ;

13
contrib/random-tester/load.factor
View File

@ -1,8 +1,5 @@
USING: kernel parser sequences words compiler ; PROVIDE: random-tester {
IN: scratchpad "utils.factor"
"random.factor"
{ "random-tester.factor"
"utils" } ;
"random"
"random-tester"
} [ "/contrib/random-tester/" swap ".factor" append3 run-resource ] each

646
contrib/random-tester/random-tester.factor
View File

@ -1,30 +1,40 @@
USING: kernel math sequences namespaces errors hashtables words arrays parser USING: kernel math math-internals memory sequences namespaces errors
compiler syntax lists io ; hashtables words arrays parser compiler syntax io
USING: inspector prettyprint ; inspector prettyprint optimizer inference ;
USING: optimizer compiler-frontend compiler-backend inference ;
IN: random-tester IN: random-tester
! Math words are listed in arrays according to the number of arguments, ! n-foo>bar -- list of words of type 'foo' that take n parameters
! if they can throw exceptions or not, and what they output. ! and output a 'bar'
! integer>x -> takes an integer, outputs anything
! integer>integer -> always outputs an integer
! Math vocabulary words ! Math vocabulary words
: math-1 ( -- seq ) : 1-x>y ( -- seq )
#! Words that take one argument
{ {
1+ 1- >bignum >digit >fixnum abs absq arg 1+ 1- >bignum >digit >fixnum abs absq arg
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
cosh cot coth denominator double>bits exp float>bits floor imaginary cosh cot coth denominator double>bits exp float>bits floor imaginary
log neg next-power-of-2 numerator quadrant real sec log neg numerator quadrant real sec ! next-power-of-2
sech sgn sin sinh sq sqrt tan tanh truncate sech sgn sin sinh sq sqrt tan tanh truncate
} ; } ;
: math-throw-1
: 1-x>y-throws
#! Words that take one argument and possibly throw an error
{ {
recip log2 recip log2
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ; } ;
: integer>x : 2-x>y ( -- seq )
#! Words that take two arguments
{ * + - /f max min polar> bitand bitor bitxor align } ;
: 2-x>y-throws ( -- seq )
#! Words that take two arguments and possibly throw an error
{ / /i mod rem } ;
: 1-integer>x
#! Words that take an integer and output a type (not necessarily integer)
{ {
1+ 1- >bignum >digit >fixnum abs absq arg 1+ 1- >bignum >digit >fixnum abs absq arg
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
@ -33,7 +43,7 @@ IN: random-tester
sech sgn sin sinh sq sqrt tan tanh truncate sech sgn sin sinh sq sqrt tan tanh truncate
} ; } ;
: ratio>x : 1-ratio>x
{ {
1+ 1- >bignum >digit >fixnum abs absq arg ceiling 1+ 1- >bignum >digit >fixnum abs absq arg ceiling
cis conjugate cos cosec cosech cis conjugate cos cosec cosech
@ -42,36 +52,36 @@ IN: random-tester
sech sgn sin sinh sq sqrt tan tanh truncate sech sgn sin sinh sq sqrt tan tanh truncate
} ; } ;
: float>x ( float -- x ) : 1-float>x ( float -- x )
{ {
1+ 1- >bignum >digit >fixnum abs absq arg 1+ 1- >bignum >digit >fixnum abs absq arg
ceiling cis conjugate cos cosec cosech ceiling cis conjugate cos cosec cosech
cosh cot coth double>bits exp float>bits floor imaginary cosh cot coth double>bits exp float>bits floor imaginary
log neg next-power-of-2 quadrant real sec log neg quadrant real sec ! next-power-of-2
sech sgn sin sinh sq sqrt tan tanh truncate sech sgn sin sinh sq sqrt tan tanh truncate
} ; } ;
: complex>x : 1-complex>x
{ {
1+ 1- abs absq arg 1+ 1- abs absq arg conjugate cos cosec cosech
conjugate cos cosec cosech cosh cot coth exp imaginary log neg quadrant real
cosh cot coth exp imaginary
log neg quadrant real
sec sech sin sinh sq sqrt tan tanh sec sech sin sinh sq sqrt tan tanh
} ; } ;
: integer>x-throw : 1-integer>x-throws
{ {
recip log2 recip log2
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ; } ;
: ratio>x-throw
: 1-ratio>x-throws
{ {
recip recip
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ; } ;
: integer>integer : 1-integer>integer
#! Subset of 1-integer>x
{ {
1+ 1- >bignum >digit >fixnum abs absq 1+ 1- >bignum >digit >fixnum abs absq
bitnot ceiling conjugate bitnot ceiling conjugate
@ -80,17 +90,16 @@ IN: random-tester
real sgn sq truncate real sgn sq truncate
} ; } ;
: ratio>ratio { 1+ 1- >digit abs absq conjugate neg real sq } ; : 1-ratio>ratio
{ 1+ 1- >digit abs absq conjugate neg real sq } ;
: float>float : 1-float>float
{ {
1+ 1- >digit abs absq arg ceiling 1+ 1- >digit abs absq arg ceiling
conjugate cos cosec cosech conjugate exp floor neg real sq truncate
cosh cot coth exp floor neg real sec
sech sin sinh sq tan tanh truncate
} ; } ;
: complex>complex : 1-complex>complex
{ {
1+ 1- abs absq arg 1+ 1- abs absq arg
conjugate cosec cosech conjugate cosec cosech
@ -99,461 +108,224 @@ IN: random-tester
sech sin sinh sq sqrt tanh sech sin sinh sq sqrt tanh
} ; } ;
: 2-integer>x ( n n -- x )
: math-2 ( -- seq )
{ * + - /f max min polar> bitand bitor bitxor align } ; { * + - /f max min polar> bitand bitor bitxor align } ;
: math-throw-2 ( -- seq ) { / /i mod rem } ; : 2-ratio>x ( r r -- x )
{ * + - /f max min polar> } ;
: 2-float>x ( f f -- x )
{ float+ float- float* float/f + - * /f max min polar> } ;
: 2-complex>x ( c c -- x ) { * + - /f } ;
: 2integer>x ( n n -- x ) ( -- word ) : 2-integer>integer ( n n -- n )
{ * + - /f max min polar> bitand bitor bitxor align } ;
: 2ratio>x ( r r -- x ) ( -- word ) { * + - /f max min polar> } ;
: 2float>x ( f f -- x ) ( -- word ) { * + - /f max min polar> } ;
: 2complex>x ( c c -- x ) ( -- word ) { * + - /f } ;
: 2integer>integer ( n n -- n ) ( -- word )
{ * + - max min bitand bitor bitxor align } ; { * + - max min bitand bitor bitxor align } ;
: 2ratio>ratio ( r r -- r ) ( -- word ) { * + - max min } ; : 2-ratio>ratio ( r r -- r )
: 2float>float ( f f -- f ) ( -- word ) { * + - /f max min } ; { * + - max min } ;
: 2complex>complex ( c c -- c ) ( -- word ) { * + - /f } ; : 2-float>float ( f f -- f )
{ float* float+ float- float/f max min /f + - } ;
: 2-complex>complex ( c c -- c )
{ * + - /f } ;
: (random-integer-quotation) ( -- quot )
random-integer ,
max-length random-int
[
[
[ integer>integer nth-rand , ]
[ random-integer , 2integer>integer nth-rand , ]
] do-one
] times ;
: random-integer-quotation ( -- quot )
[
(random-integer-quotation)
] [ ] make ;
: random-integer-quotation-1 ( -- quot )
[
(random-integer-quotation) 2integer>integer nth-rand ,
] [ ] make ;
: (random-ratio-quotation) ( -- quot )
random-ratio ,
max-length random-int
[
[
[ ratio>ratio nth-rand , ]
[ random-ratio , 2ratio>ratio nth-rand , ]
] do-one
] times ;
: random-ratio-quotation ( -- quot )
[
(random-ratio-quotation)
] [ ] make ;
: random-ratio-quotation-1 ( -- quot )
[
(random-ratio-quotation) 2ratio>ratio nth-rand ,
] [ ] make ;
: random-float-quotation ( -- quot )
[
random-float ,
max-length random-int
[
[
[ float>float nth-rand , ]
[ random-float , 2float>float nth-rand , ]
] do-one
] times
] [ ] make ;
: random-complex-quotation ( -- quot )
[
random-complex ,
max-length random-int
[
[
[ complex>complex nth-rand , ]
[ random-complex , 2complex>complex nth-rand , ]
] do-one
] times
] [ ] make ;
SYMBOL: last-quot SYMBOL: last-quot
SYMBOL: first-arg SYMBOL: first-arg
: runtime-check SYMBOL: second-arg
: 0-runtime-check ( quot -- )
#! Checks the runtime only, not the compiler
#! Evaluates the quotation twice and makes sure the results agree
[ last-quot set ] keep [ last-quot set ] keep
[ call ] keep [ call ] keep
call call
! 2dup swap unparse write " " write unparse print ! 2dup swap unparse write " " write unparse print flush
= [ last-quot get . "problem in runtime" throw ] unless ; = [ last-quot get . "problem in runtime" throw ] unless ;
: runtime-check-1 : 1-runtime-check ( quot -- )
#! Checks the runtime only, not the compiler
#! Evaluates the quotation twice and makes sure the results agree
#! For quotations that are given one argument
[ last-quot set first-arg set ] 2keep [ last-quot set first-arg set ] 2keep
[ call ] 2keep [ call ] 2keep
call call
2dup swap unparse write " " write unparse print 2dup swap unparse write " " write unparse print flush
= [ "problem in runtime" throw ] unless ; = [ "problem in runtime" throw ] unless ;
: interp-runtime-check ( quot -- ) : 1-interpreted-vs-compiled-check ( x quot -- )
! dup . #! Checks the runtime output vs the compiler output
[ last-quot set ] keep #! quot: ( x -- y )
[ call ] keep call ! compile-1 2dup swap unparse write " " write . flush
! 2dup swap unparse write " " write unparse print [ last-quot set first-arg set ] 2keep
= [ "problem in math" throw ] unless ;
: interp-compile-check-1 ( x quot -- )
.s flush
[ last-quot set ] keep
[ call ] 2keep compile-1 [ call ] 2keep compile-1
2dup swap unparse write " " write unparse print 2dup swap unparse write " " write unparse print flush
= [ "problem in math" throw ] unless ; = [ "problem in math1" throw ] unless ;
: interp-compile-check-2 ( x quot -- ) : 2-interpreted-vs-compiled-check ( x y quot -- )
#! Checks the runtime output vs the compiler output
#! quot: ( x y -- z )
.s flush .s flush
[ last-quot set ] keep [ last-quot set first-arg set second-arg set ] 3keep
[ call ] 3keep compile-1 [ call ] 3keep compile-1
2dup swap unparse write " " write unparse print 2dup swap unparse write " " write unparse print flush
= [ "problem in math" throw ] unless ; = [ "problem in math2" throw ] unless ;
: interp-compile-check* ( quot -- ) : 0-interpreted-vs-compiled-check-catch ( quot -- )
dup . #! Check the runtime output vs the compiler output for words that throw
>r 100 200 300 400 r> [ call 4array ] keep #!
>r 100 200 300 400 r> compile-1 4array
= [ "problem found! (compile-check*)" throw ] unless ;
: interp-compile-check-catch ( quot -- )
dup . dup .
[ last-quot set ] keep [ last-quot set ] keep
[ catch [ "caught: " write dup print-error ] when* ] keep [ catch [ "caught: " write dup print-error ] when* ] keep
[ compile-1 ] catch [ nip "caught: " write dup print-error ] when* [ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
= [ "problem in math" throw ] unless ; = [ "problem in math3" throw ] unless ;
: update-math-xt ( -- ) : 1-interpreted-vs-compiled-check-catch ( quot -- )
math-1 [ update-xt ] each #! Check the runtime output vs the compiler output for words that throw
math-throw-1 [ update-xt ] each 2dup swap unparse write " " write .
math-2 [ update-xt ] each ! "." write
math-throw-2 [ update-xt ] each ; [ last-quot set first-arg set ] 2keep
[ catch [ nip "caught: " write dup print-error ] when* ] 2keep
[ compile-1 ] catch [ 2nip "caught: " write dup print-error ] when*
= [ "problem in math4" throw ] unless ;
: update-xt-check ( quot -- ) : 2-interpreted-vs-compiled-check-catch ( quot -- )
update-math-xt #! Check the runtime output vs the compiler output for words that throw
dup . ! 3dup rot unparse write " " write swap unparse write " " write .
[ last-quot set ] keep "." write
[ call ] keep [ last-quot set first-arg set second-arg set ] 3keep
[ peek update-xt ] keep call [ catch [ 2nip "caught: " write dup print-error ] when* ] 3keep
2dup swap unparse write " " write unparse print [ compile-1 ] catch [ 2nip nip "caught: " write dup print-error ] when*
= [ "update-xt problem" throw ] unless ; = [ "problem in math5" throw ] unless ;
! RANDOM QUOTATIONS TO TEST
: random-1-integer>x-quot ( -- quot ) 1-integer>x nth-rand unit ;
: random-1-ratio>x-quot ( -- quot ) 1-ratio>x nth-rand unit ;
: random-1-float>x-quot ( -- quot ) 1-float>x nth-rand unit ;
: random-1-complex>x-quot ( -- quot ) 1-complex>x nth-rand unit ;
: test-1-integer>x ( -- )
random-integer random-1-integer>x-quot 1-interpreted-vs-compiled-check ;
: test-1-ratio>x ( -- )
random-ratio random-1-ratio>x-quot 1-interpreted-vs-compiled-check ;
: test-1-float>x ( -- )
random-float random-1-float>x-quot 1-interpreted-vs-compiled-check ;
: test-1-complex>x ( -- )
random-complex random-1-complex>x-quot 1-interpreted-vs-compiled-check ;
: random-1-float>float-quot ( -- ) 1-float>float nth-rand unit ;
: random-2-float>float-quot ( -- ) 2-float>float nth-rand unit ;
: nrandom-2-float>float-quot ( -- )
[
5
[
{
[ 2-float>float nth-rand , random-float , ]
[ 1-float>float nth-rand , ]
} do-one
] times
2-float>float nth-rand ,
] [ ] make ;
: test-1-float>float ( -- )
random-float random-1-float>float-quot 1-interpreted-vs-compiled-check ;
: test-2-float>float ( -- )
random-float random-float random-2-float>float-quot
2-interpreted-vs-compiled-check ;
: test-n-2-float>float ( -- )
random-float random-float nrandom-2-float>float-quot
2-interpreted-vs-compiled-check ;
: test-1-integer>x-runtime ( -- )
random-integer random-1-integer>x-quot 1-runtime-check ;
: random-1-integer>x-throws-quot ( -- ) 1-integer>x-throws nth-rand unit ;
: random-1-ratio>x-throws-quot ( -- ) 1-ratio>x-throws nth-rand unit ;
: test-1-integer>x-throws ( -- )
random-integer random-1-integer>x-throws-quot
1-interpreted-vs-compiled-check-catch ;
: test-1-ratio>x-throws ( -- )
random-ratio random-1-ratio>x-throws-quot
1-interpreted-vs-compiled-check-catch ;
: test-2-integer>x-throws ( -- )
! 1-arg tests
: random-integer>x-quot random-integer integer>x nth-rand unit cons ;
: random-ratio>x-quot ( -- ) random-ratio ratio>x nth-rand unit cons ;
: random-float>x-quot ( -- ) random-float float>x nth-rand unit cons ;
: random-complex>x-quot ( -- ) random-complex complex>x nth-rand unit cons ;
: test-integer>x ( -- ) random-integer>x-quot interp-runtime-check ;
: test-ratio>x ( -- ) random-ratio>x-quot interp-runtime-check ;
: test-float>x ( -- ) random-float>x-quot interp-runtime-check ;
: test-complex>x ( -- ) random-complex>x-quot interp-runtime-check ;
: test-integer>x-runtime ( -- ) random-integer>x-quot runtime-check ;
: test-integer>x-1-runtime ( -- ) random-integer>x-quot runtime-check ;
: test-integer>x-1 ( -- )
random-integer integer>x nth-rand unit interp-compile-check-1 ;
: test-ratio>x-1 ( -- )
random-ratio ratio>x nth-rand unit interp-compile-check-1 ;
: test-float>x-1 ( -- )
random-float float>x nth-rand unit interp-compile-check-1 ;
: test-complex>x-1 ( -- )
random-complex complex>x nth-rand unit interp-compile-check-1 ;
: test-integer>x-throws ( -- )
random-integer integer>x-throw nth-rand unit cons interp-compile-check-catch ;
: test-ratio>x-throws ( -- )
random-ratio ratio>x-throw nth-rand unit cons interp-compile-check-catch ;
: test-update-xt ( -- )
random-integer random-integer 2integer>x nth-rand unit cons cons update-xt-check ;
! 2-arg tests
: test-2integer>x ( -- )
random-integer random-integer 2integer>x nth-rand unit cons cons interp-runtime-check ;
: test-2ratio>x ( -- )
random-ratio random-ratio 2ratio>x nth-rand unit cons cons interp-runtime-check ;
: test-2float>x ( -- )
random-float random-float 2float>x nth-rand unit cons cons interp-runtime-check ;
: test-2complex>x ( -- )
random-complex random-complex 2complex>x nth-rand unit cons cons interp-runtime-check ;
: test-2random>x ( -- )
random-number random-number math-2 nth-rand unit cons cons interp-runtime-check ;
: test-2integer>x-2 ( -- )
random-integer random-integer 2integer>x nth-rand unit interp-compile-check-2 ;
: test-2ratio>x-2 ( -- )
random-ratio random-ratio 2ratio>x nth-rand unit interp-compile-check-2 ;
: test-2float>x-2 ( -- )
random-float random-float 2float>x nth-rand unit interp-compile-check-2 ;
: test-2complex>x-2 ( -- )
random-complex random-complex 2complex>x nth-rand unit interp-compile-check-2 ;
! : test-2integer>x-1 ( -- )
! random-integer random-integer-quotation-1 interp-compile-check-1 ;
: test-2integer>x-throws ( -- )
[ [
random-integer , random-integer , random-integer , random-integer ,
math-throw-2 nth-rand , 2-x>y-throws nth-rand ,
] [ ] make interp-compile-check-catch ; ] [ ] make 2-interpreted-vs-compiled-check-catch ;
: test-^-shift ( -- ) ! : test-^-shift ( -- )
! [
! 100 random-int 50 - ,
! 100 random-int 50 - ,
! { ^ shift } nth-rand ,
! ] [ ] make 2-interpreted-vs-compiled-check-catch ;
! : test-^-ratio ( -- )
! [
! random-ratio , random-ratio , \ ^ ,
! ] [ ] make interp-compile-check-catch ;
: test-0-float?-when
[ [
100 random-int 50 - , random-number , \ dup , \ float? , 1-float>x nth-rand unit , \ when ,
100 random-int 50 - , ] [ ] make 0-runtime-check ;
{ ^ shift } nth-rand ,
] [ ] make interp-compile-check-catch ;
: test-^-ratio ( -- ) : test-1-integer?-when
[ random-integer [
random-ratio , random-ratio , \ ^ , \ dup , \ integer? , 1-integer>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-catch ; ] [ ] make 1-interpreted-vs-compiled-check ;
: test-math { : test-1-ratio?-when
! test-integer>x
! test-ratio>x
! test-float>x
! test-complex>x
! test-integer>x-1
! test-ratio>x-1
! test-float>x-1
! test-complex>x-1
! test-integer>x-throws
! test-ratio>x-throws
! ! test-update-xt
! test-2integer>x
! test-2ratio>x
! test-2float>x
! test-2complex>x
test-2integer>x-2
test-2ratio>x-2
test-2float>x-2
test-2complex>x-2
! ! test-2integer>x-1
! test-2integer>x-throws
! test-^-shift
! test-^-ratio
} nth-rand unit call ;
! Boolean logic tests
: logic-0 ( -- seq )
{ bootstrapping? f t } ;
: logic-1 ( -- seq )
{
not tuple? float? integer? complex? ratio? continuation? wrapper?
number? rational? bignum? fixnum? float? primitive? symbol?
compound? real?
} ;
! odd? even? power-of-2?
: logic-2 ( -- seq ) { < > <= >= number= = eq? and or } ;
: logic-3 ( -- seq ) { between? } ;
: complex-logic-2 ( -- seq ) { number= = eq? and or } ;
: logic-0-test ( -- ) logic-0 nth-rand unit interp-runtime-check ;
: integer-logic-1-test ( -- )
[
random-integer , logic-1 nth-rand ,
] [ ] make interp-runtime-check ;
: ratio-logic-1-test ( -- )
[
random-ratio , logic-1 nth-rand ,
] [ ] make interp-runtime-check ;
: float-logic-1-test ( -- )
[
random-float , logic-1 nth-rand ,
] [ ] make interp-runtime-check ;
: complex-logic-1-test ( -- )
[
random-complex , logic-1 nth-rand ,
] [ ] make interp-runtime-check ;
: integer-logic-2-test ( -- )
[
random-integer , random-integer , logic-2 nth-rand ,
] [ ] make interp-runtime-check ;
: ratio-logic-2-test ( -- )
[
random-ratio , random-ratio , logic-2 nth-rand ,
] [ ] make interp-runtime-check ;
: float-logic-2-test ( -- )
[
random-float , random-float , logic-2 nth-rand ,
] [ ] make interp-runtime-check ;
: complex-logic-2-test ( -- )
[
random-complex , random-complex , complex-logic-2 nth-rand ,
] [ ] make interp-runtime-check ;
: string-to-math-test ( -- )
[
{
[ random-integer , \ number>string , ]
[ random-integer , \ number>string , \ string>number , ]
} do-one
] [ ] make interp-runtime-check ;
: test-float?-when
[
random-number , \ dup , \ float? , float>x nth-rand unit , \ when ,
] [ ] make interp-runtime-check ;
: test-integer?-when-1
random-float [
\ dup , \ float? , float>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ;
: test-ratio?-when-1
random-ratio [ random-ratio [
\ dup , \ ratio? , ratio>x nth-rand unit , \ when , \ dup , \ ratio? , 1-ratio>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ; ] [ ] make 1-interpreted-vs-compiled-check ;
: test-float?-when-1 : test-1-float?-when
random-float [ random-float [
\ dup , \ float? , float>x nth-rand unit , \ when , \ dup , \ float? , 1-float>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ; ] [ ] make 1-interpreted-vs-compiled-check ;
: test-complex?-when-1 : test-1-complex?-when
random-complex [ random-complex [
\ dup , \ complex? , complex>x nth-rand unit , \ when , \ dup , \ complex? , 1-complex>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ; ] [ ] make 1-interpreted-vs-compiled-check ;
: stack-identity-0
H{
{ 1 drop }
{ 1000000000000000000000000001 drop }
{ -11111111111111111111111111 drop }
{ -1 drop }
{ 1.203 drop }
{ -1.203 drop }
{ "asdf" drop }
} ; inline
: stack-identity-1
H{
{ dup drop }
{ >r r> }
} ; inline
: stack-identity-2
H{
{ swap swap }
{ over drop }
{ dupd nip }
{ 2dup 2drop }
} ; inline
: stack-identity-3
H{
{ rot -rot }
{ pick drop }
{ 3dup 3drop }
} ; inline
: stack-identity-4
H{
{ 2swap 2swap }
} ; inline
: get-stack-identity-table ( n -- hash ) : many-word-test ( -- )
#! defines words a1000 down to a0, which does a trivial addition
"random-tester-scratchpad" vocabularies get remove-hash
"random-tester-scratchpad" [ ensure-vocab ] keep use+
"a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
100 [
[ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
"a" swap unparse append [ parse ] catch [ 0 :res ] when define-compound
] each ;
: compile-loop ( -- )
10 [ many-word-test "a100" parse first compile ] times ;
: random-test
{ {
{ [ dup 0 = ] [ drop stack-identity-0 ] } test-1-integer>x
{ [ dup 1 = ] [ drop stack-identity-1 ] } test-1-ratio>x
{ [ dup 2 = ] [ drop stack-identity-2 ] } test-1-float>x
{ [ dup 3 = ] [ drop stack-identity-3 ] } test-1-complex>x
{ [ dup 4 = ] [ drop stack-identity-4 ] } test-1-integer>x-throws
{ [ t ] [ drop f ] } test-1-ratio>x-throws
} cond ; test-1-float>float
test-2-float>float
: get-stack-identity-table<= ( n -- hash ) test-n-2-float>float
1+ random-int get-stack-identity-table ; test-1-integer>x-runtime
! test-0-float?-when
test-1-integer?-when
: random-stack-identity ( n -- quot ) test-1-ratio?-when
#! n is number of items on stack test-1-float?-when
[ test-1-complex?-when
max-length random-int full-gc
[ dup get-stack-identity-table<= random-hash-entry swap , , ] times } nth-rand execute ;
drop
] [ ] make ;
: test-random-stack-identity ( -- )
4 random-stack-identity interp-compile-check* ;
! change the % to make longer quotations
: if-quot ( -- )
[
random-ratio , random-ratio , logic-2 nth-rand ,
2 [ 30% [ if-quot ] [ random-ratio-quotation-1 ] if unit % ] times
\ if ,
] [ ] make ;
: when-quot
[
random-ratio , random-ratio , logic-2 nth-rand ,
90% [ when-quot ] [ random-ratio-quotation-1 ] if unit %
coin-flip \ when \ unless ? ,
] [ ] make ;
: nested-ifs ( -- quot )
[
random-ratio ,
if-quot %
! when-quot %
] [ ] make ;
: test-if ( -- ) nested-ifs interp-runtime-check ;
: random-test ( -- )
{
test-if
test-random-stack-identity
test-math
}
nth-rand execute ;
: watch-simplifier ( -- )
[
dup word-def dataflow optimize
linearize [ split-blocks simplify . ] hash-each
] with-compiler ;

25
contrib/random-tester/random.factor
View File

@ -1,11 +1,10 @@
USING: kernel math sequences namespaces errors hashtables words arrays parser USING: kernel math sequences namespaces errors hashtables words
compiler syntax lists io ; arrays parser compiler syntax io inspector prettyprint optimizer
USING: inspector prettyprint ; inference ;
USING: optimizer compiler-frontend compiler-backend inference ;
IN: random-tester IN: random-tester
! Tweak me ! Tweak me
: max-length 7 ; inline : max-length 15 ; inline
: max-value 1000000000 ; inline : max-value 1000000000 ; inline
: 10% ( -- bool ) 10 random-int 8 > ; : 10% ( -- bool ) 10 random-int 8 > ;
@ -31,11 +30,11 @@ IN: random-tester
SYMBOL: special-integers SYMBOL: special-integers
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] [ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
{ } make \ special-integers set { } make \ special-integers set-global
: special-integers ( -- seq ) \ special-integers get ; : special-integers ( -- seq ) \ special-integers get ;
SYMBOL: special-floats SYMBOL: special-floats
[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ] [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set { } make \ special-floats set-global
: special-floats ( -- seq ) \ special-floats get ; : special-floats ( -- seq ) \ special-floats get ;
SYMBOL: special-complexes SYMBOL: special-complexes
[ [
@ -44,7 +43,7 @@ SYMBOL: special-complexes
0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
e neg e neg rect> , e e rect> , e neg e neg rect> , e e rect> ,
] { } make \ special-complexes set ] { } make \ special-complexes set-global
: special-complexes ( -- seq ) \ special-complexes get ; : special-complexes ( -- seq ) \ special-complexes get ;
: random-fixnum ( -- fixnum ) : random-fixnum ( -- fixnum )
@ -53,12 +52,12 @@ SYMBOL: special-complexes
: random-bignum ( -- bignum ) : random-bignum ( -- bignum )
400 random-bits first-bignum + coin-flip [ neg ] when ; 400 random-bits first-bignum + coin-flip [ neg ] when ;
: random-integer : random-integer ( -- n )
coin-flip [ coin-flip [
random-fixnum random-fixnum
] [ ] [
coin-flip [ random-bignum ] [ special-integers nth-rand ] if coin-flip [ random-bignum ] [ special-integers nth-rand ] if
] if ; ] if ;
: random-positive-integer ( -- int ) : random-positive-integer ( -- int )
random-integer dup 0 < [ random-integer dup 0 < [

Some files were not shown because too many files have changed in this diff Show More