gcc.
Factor supports various platforms. For an up-to-date list, see
-<http://factorcode.org/getfactor.fhtml>.
+<http://factorcode.org>.
Factor requires gcc 3.4 or later.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
-Compilation will yield an executable named 'factor' on Unix,
-'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
-
-* Libraries needed for compilation
-
-For X11 support, you need recent development libraries for libc,
-Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
-(like Ubuntu), you can use the following line to grab everything:
-
- sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
+For X11 support, you need recent development libraries for libc,
+Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the following line to grab everything:
+
+ sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+
If your DISPLAY environment variable is set, the UI will start
automatically:
./factor -run=listener
-If you're inside a terminal session, you can start the UI with one of
-the following two commands:
-
- ui
- [ ui ] in-thread
-
-The latter keeps the terminal listener running.
-
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X, a Cocoa UI is available in addition to the terminal
Then bootstrap with the following switches:
- ./factor -i=boot.<cpu>.image -ui-backend=x11
+ ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
Now if $DISPLAY is set, running ./factor will start the UI.
factor.com -i=boot.<cpu>.image
+Before bootstrapping, you will need to download the DLLs for the Pango
+text rendering library. The required DLLs are listed in
+build-support/dlls.txt and are available from the following location:
+
+ <http://factorcode.org/dlls>
+
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
* The Factor FAQ
-The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
+The Factor FAQ is available at the following location:
+
+ <http://concatenative.org/wiki/view/Factor/FAQ>
* Command line usage
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
+"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
+$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
+"A utility for defining " { $link "destructors" } " for deallocating memory:"
+{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;
--- /dev/null
+IN: alien.destructors
+USING: help.markup help.syntax alien destructors ;
+
+HELP: DESTRUCTOR:
+{ $syntax "DESTRUCTOR: word" }
+{ $description "Defines four things:"
+ { $list
+ { "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
+ { "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
+ { "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
+ }
+ "The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
+}
+{ $examples
+ "Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
+ { $code
+ "FUNCTION: void g_object_unref ( gpointer object ) ;"
+ "DESTRUCTOR: g_object_unref"
+ }
+ "Now, memory management becomes easier:"
+ { $code
+ "[ g_new_foo &g_object_unref ... ] with-destructors"
+ }
+} ;
+
+ARTICLE: "alien.destructors" "Alien destructors"
+"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
+{ $subsection POSTPONE: DESTRUCTOR: } ;
+
+ABOUT: "alien.destructors"
\ No newline at end of file
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline\r
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline\r
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline\r
-: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline\r
+: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline\r
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline\r
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline\r
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline\r
: >upper ( str -- upper ) [ ch>upper ] map ;\r
\r
HINTS: >lower string ;\r
-HINTS: >upper string ;
\ No newline at end of file
+HINTS: >upper string ;\r
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators hints arrays ;
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
+DEFER: (search)
+
+: keep-searching ( seq quot -- slice )
+ [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
+
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
decide {
{ +eq+ [ finish ] }
- { +lt+ [ dup midpoint@ head-slice (search) ] }
- { +gt+ [ dup midpoint@ tail-slice (search) ] }
+ { +lt+ [ [ (head) ] keep-searching ] }
+ { +gt+ [ [ (tail) ] keep-searching ] }
} case
] if ; inline recursive
IN: bitstreams.tests
[ 1 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
[ 254 8 t ]
-[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 4095 12 t ]
-[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 254 } ]
[
- <string-writer> <bitstream-writer> 254 8 rot
+ binary <byte-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array
] unit-test
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Building generic words..." print flush
- call-remake-generics-hook
+ remake-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
-{ $values { "array" array } }
+{ $values { "value" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
-{ $values { "array" array } }
+{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
-{ $values { "array" array } }
+{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3
drop "Months are indexed starting at 1" ;
<PRIVATE
+
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
+
PRIVATE>
: month-names ( -- array )
: month-name ( n -- string )
check-month 1- month-names nth ;
-: month-abbreviations ( -- array )
+CONSTANT: month-abbreviations
{
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
- } ;
+ }
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
: day-name ( n -- string ) day-names nth ;
-: day-abbreviations2 ( -- array )
- { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
+CONSTANT: day-abbreviations2
+ { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
: day-abbreviation2 ( n -- string )
- day-abbreviations2 nth ;
+ day-abbreviations2 nth ; inline
-: day-abbreviations3 ( -- array )
- { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
+CONSTANT: day-abbreviations3
+ { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
: day-abbreviation3 ( n -- string )
- day-abbreviations3 nth ;
+ day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
--- /dev/null
+Daniel Ehrenberg
+Slava Pestov
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
+: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
+
+: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
-
-: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ;
-
-[ t ] [ \ compile-execute(-test optimized>> ] unit-test
-[ 4 ] [ 1 3 compile-execute(-test ] unit-test
\ No newline at end of file
-! Copyright (C) 2009 Daniel Ehrenberg.
+! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros fry summary sequences generalizations accessors
-continuations effects effects.parser parser words ;
+USING: kernel macros fry summary sequences sequences.private
+generalizations accessors continuations effects effects.parser
+parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
-: execute-effect-unsafe ( word effect -- )
- drop execute ;
-
-: execute-effect-unsafe? ( word effect -- ? )
- swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
-
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
-: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
-
PRIVATE>
MACRO: call-effect ( effect -- quot )
: call( \ call-effect parse-call( ; parsing
-: execute-effect ( word effect -- )
- 2dup execute-effect-unsafe?
- [ execute-effect-unsafe ]
- [ [ [ execute ] curry ] dip call-effect ]
- if ; inline
+<PRIVATE
+
+: execute-effect-unsafe ( word effect -- )
+ drop execute ;
+
+: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
+
+: execute-effect-slow ( word effect -- )
+ [ [ execute ] curry ] dip call-effect ; inline
+
+: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
+
+: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: cache-miss ( word effect ic -- )
+ [ 2dup execute-effect-unsafe? ] dip
+ '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
+ [ execute-effect-slow ] if ; inline
+
+: execute-effect-ic ( word effect ic -- )
+ #! ic is a mutable cell { effect }
+ 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
+
+PRIVATE>
+
+MACRO: execute-effect ( effect -- )
+ { f } clone '[ _ _ execute-effect-ic ] ;
: execute( \ execute-effect parse-call( ; parsing
--- /dev/null
+extensions
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
[ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
[ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+ [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+
+ [ t ] [
+ {
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } }
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
+ } [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+ [ plist> ] bi@ =
+ ] unit-test
+
+ [ t ] [
+ { "DeviceUsagePage" 1 }
+ [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+ [ plist> ] bi@ =
+ ] unit-test
+
+ [ V{ "DeviceUsagePage" "Yes" } ] [
+ { "DeviceUsagePage" "Yes" }
+ >cf &CFRelease plist>
+ ] unit-test
+
+ [ V{ 2.0 1.0 } ] [
+ { 2.0 1.0 }
+ >cf &CFRelease plist>
+ ] unit-test
+
+ [ 3.5 ] [
+ 3.5 >cf &CFRelease plist>
+ ] unit-test
] with-destructors
\ No newline at end of file
USING: help.markup help.syntax strings colors ;
HELP: named-color
-{ $values { "string" string } { "color" color } }
+{ $values { "name" string } { "color" color } }
{ $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." }
{ $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." }
{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ;
ERROR: no-such-color name ;
-: named-color ( name -- rgb )
+: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
: COLOR: scan named-color parsed ; parsing
\ No newline at end of file
"Normally, new word definitions are recompiled automatically. This can be changed:"
{ $subsection disable-compiler }
{ $subsection enable-compiler }
-"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
-{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
-HELP: optimized-recompile-hook
-{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
-{ $description "Compile a set of words." }
+HELP: optimizing-compiler
+{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: compile-call
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
-continuations vocabs assocs dlists definitions math graphs
-generic combinators deques search-deques io stack-checker
-stack-checker.state stack-checker.inlining
-combinators.short-circuit compiler.errors compiler.units
-compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.optimizer
+continuations vocabs assocs dlists definitions math graphs generic
+combinators deques search-deques macros io stack-checker
+stack-checker.state stack-checker.inlining combinators.short-circuit
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame
-compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
H{ } clone generic-dependencies set
f swap compiler-error ;
+: ignore-error? ( word error -- ? )
+ [ [ inline? ] [ macro? ] bi or ]
+ [ compiler-error-type +warning+ eq? ] bi* and ;
+
: fail ( word error -- * )
- [ swap compiler-error ]
+ [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
[
drop
[ compiled-unxref ]
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield-hook get call ] slurp-deque ;
+ [ (compile) yield-hook get assert-depth ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
-: optimized-recompile-hook ( words -- alist )
+SINGLETON: optimizing-compiler
+
+M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
] with-scope ;
: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
+ optimizing-compiler compiler-impl set-global ;
: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
+ f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;
[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
+] unit-test
+
+[ t ] [
+ [ { integer integer } declare + drop ]
+ { + +-integer-integer } inlined?
] unit-test
\ No newline at end of file
[ drop ]
} cond ;
-! M: math-partial finalize-word
-! dup primitive? [ drop ] [ nip cached-expansion ] if ;
-
M: word finalize-word drop ;
M: #call finalize*
: value-infos-union ( infos -- info )
[ null-info ]
- [ dup first [ value-info-union ] reduce ] if-empty ;
+ [ unclip-slice [ value-info-union ] reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
+! generalize-counter-interval wasn't being called in all the right places.
+! bug found by littledan
+
+TUPLE: littledan-1 { a read-only } ;
+
+: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+
+: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
+
+[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
+
+TUPLE: littledan-2 { from read-only } { to read-only } ;
+
+: (littledan-2-test) ( x -- i elt )
+ [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
+
+: littledan-2-test ( x -- i elt )
+ [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
+
+[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
+
+: (littledan-3-test) ( x -- )
+ length 1+ f <array> (littledan-3-test) ; inline recursive
+
+: littledan-3-test ( x -- )
+ 0 f <array> (littledan-3-test) ; inline
+
+[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
+
+[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
+
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
} cond interval-union nip ;
: generalize-counter ( info' initial -- info )
- 2dup [ class>> null-class? ] either? [ drop ] [
- [ drop clone ] [ [ interval>> ] bi@ ] 2bi
- generalize-counter-interval >>interval
+ 2dup [ not ] either? [ drop ] [
+ 2dup [ class>> null-class? ] either? [ drop ] [
+ [ clone ] dip
+ [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+ [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
+ [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+ tri
+ ] if
] if ;
: unify-recursive-stacks ( stacks initial -- infos )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences ;
+USING: alien.syntax kernel sequences fry ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
: <CFArray> ( seq -- alien )
- [ f swap length f CFArrayCreateMutable ] keep
- [ length ] keep
- [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
+ f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
+ [ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ;
--- /dev/null
+unportable
+bindings
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text core-foundation
-core-foundation.dictionaries destructors
-arrays kernel generalizations math accessors
-core-foundation.utilities
-combinators hashtables colors ;
+USING: tools.test core-text core-text.fonts core-foundation
+core-foundation.dictionaries destructors arrays kernel generalizations
+math accessors core-foundation.utilities combinators hashtables colors
+colors.constants ;
IN: core-text.tests
: test-font ( name -- font )
: test-typographic-bounds ( string font -- ? )
[
- test-font &CFRelease white <CTLine> &CFRelease
- line-typographic-bounds {
+ test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
+ compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]
--- /dev/null
+unportable
+bindings
check_sse2 ;
"-no-sse2" (command-line) member? [
- [ optimized-recompile-hook ] recompile-hook
- [ { check_sse2 } compile ] with-variable
+ optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
"Checking if your CPU supports SSE2..." print flush
sse2? [
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
- ] with-variable ;
+ ] with-variable ; inline
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output ;
+ ] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
HELP: define-consult
-{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
-{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
+{ $values { "consultation" consultation } }
+{ $description "Defines a class to consult, using the quotation, on the generic words contained in the group." }
{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT:
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.standard delegate.protocols
-delegate.private assocs ;
+delegate.private assocs see ;
IN: delegate.tests
TUPLE: hello this that ;
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href=\"http://lol.com/search?q=sex\">haha</a></p>" ] [ "[[http://lol.com/search?q=sex|haha]]" convert-farkup ] unit-test
[ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
- [ relative-link-prefix get prepend "" like ]
- } cond url-encode ;
+ [ relative-link-prefix get prepend "" like url-encode ]
+ } cond ;
: write-link ( href text -- xml )
- [ check-url link-no-follow? get "true" and ] dip
- [XML <a href=<-> nofollow=<->><-></a> XML] ;
+ [ check-url link-no-follow? get "nofollow" and ] dip
+ [XML <a href=<-> rel=<->><-></a> XML] ;
: write-image-link ( href text -- xml )
disable-images? get [
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
-furnace.redirection strings multiline ;
+furnace.redirection strings multiline html.forms ;
IN: furnace.actions
HELP: <action>
}
} ;
+{ validate-params validate-values } related-words
+
HELP: validation-failed
{ $description "Stops processing the current request and takes action depending on the type of the current request:"
{ $list
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
validators http hashtables namespaces fry continuations locals\r
-io arrays math boxes splitting urls\r
+io arrays math boxes splitting urls call\r
xml.entities\r
http.server\r
http.server.responses\r
'[\r
_ dup display>> [\r
{\r
- [ init>> call ]\r
- [ authorize>> call ]\r
+ [ init>> call( -- ) ]\r
+ [ authorize>> call( -- ) ]\r
[ drop restore-validation-errors ]\r
- [ display>> call ]\r
+ [ display>> call( -- response ) ]\r
} cleave\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
: handle-post ( action -- response )\r
'[\r
_ dup submit>> [\r
- [ validate>> call ]\r
- [ authorize>> call ]\r
- [ submit>> call ]\r
+ [ validate>> call( -- ) ]\r
+ [ authorize>> call( -- ) ]\r
+ [ submit>> call( -- response ) ]\r
tri\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
\ successful-login DEBUG add-input-logging\r
\r
-: logout ( -- )\r
+: logout ( -- response )\r
permit-id get [ delete-permit ] when*\r
URL" $realm" end-aside ;\r
\r
-! Copyright (c) 2008 Slava Pestov
+! Copyright (c) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.order namespaces combinators.short-circuit
+USING: accessors kernel math.order namespaces combinators.short-circuit call
html.forms
html.templates
html.templates.chloe
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
- responder init>> call
+ responder init>> call( -- )
dup wrap-boilerplate? [
clone [| body |
[
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters
-http.server.responses furnace.utilities ;
+http.server.responses furnace.utilities call ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;
C: <referrer-check> referrer-check
M: referrer-check call-responder*
- referrer over quot>> call
+ referrer over quot>> call( referrer -- ? )
[ call-next-method ]
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
- '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+ '[ exit-continuation set @ ] callcc1 exit-continuation off ; inline
Slava Pestov
+Daniel Ehrenberg
[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
-[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators parser-combinators.regexp lists sequences kernel
-promises strings unicode.case ;
+USING: sequences kernel regexp.combinators strings unicode.case
+peg.ebnf regexp arrays ;
IN: globs
-<PRIVATE
+EBNF: <glob>
-: 'char' ( -- parser )
- [ ",*?" member? not ] satisfy ;
+Character = "\\" .:c => [[ c 1string <literal> ]]
+ | !(","|"}") . => [[ 1string <literal> ]]
-: 'string' ( -- parser )
- 'char' <+> [ >lower token ] <@ ;
+RangeCharacter = !("]") .
-: 'escaped-char' ( -- parser )
- "\\" token any-char-parser &> [ 1token ] <@ ;
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <char-range> ]]
+ | RangeCharacter => [[ 1string <literal> ]]
-: 'escaped-string' ( -- parser )
- 'string' 'escaped-char' <|> ;
+StartRange = .:a "-" RangeCharacter:b => [[ a b <char-range> ]]
+ | . => [[ 1string <literal> ]]
-DEFER: 'term'
+Ranges = StartRange:s Range*:r => [[ r s prefix ]]
-: 'glob' ( -- parser )
- 'term' <*> [ <and-parser> ] <@ ;
+CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
-: 'union' ( -- parser )
- 'glob' "," token nonempty-list-of "{" "}" surrounded-by
- [ <or-parser> ] <@ ;
+AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
+ | Concatenation => [[ 1array ]]
-LAZY: 'term' ( -- parser )
- 'union'
- 'character-class' <|>
- "?" token [ drop any-char-parser ] <@ <|>
- "*" token [ drop any-char-parser <*> ] <@ <|>
- 'escaped-string' <|> ;
+Element = "*" => [[ R/ .*/ ]]
+ | "?" => [[ R/ ./ ]]
+ | "[" CharClass:c "]" => [[ c ]]
+ | "{" AlternationBody:b "}" => [[ b <or> ]]
+ | Character
-PRIVATE>
+Concatenation = Element* => [[ <sequence> ]]
-: <glob> ( string -- glob ) 'glob' just parse-1 just ;
+End = !(.)
+
+Main = Concatenation End
+
+;EBNF
: glob-matches? ( input glob -- ? )
- [ >lower ] [ <glob> ] bi* parse nil? not ;
+ [ >case-fold ] bi@ <glob> matches? ;
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline ;
+help command-line multiline see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
USING: math definitions help.topics help tools.test
prettyprint parser io.streams.string kernel source-files
-assocs namespaces words io sequences eval accessors ;
+assocs namespaces words io sequences eval accessors see ;
IN: help.definitions.tests
[ ] [ \ + >link see ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint.custom prettyprint words kernel
-effects ;
+effects see ;
IN: help.definitions
! Definition protocol implementation
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
+{ $subsection "see" }
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }
USING: help.markup help.crossref help.stylesheet help.topics
help.syntax definitions io prettyprint summary arrays math
-sequences vocabs strings ;
+sequences vocabs strings see ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"
[ check-descriptions ]
} cleave ;
+: check-class-description ( word element -- )
+ [ class? not ]
+ [ { $class-description } swap elements empty? not ] bi* and
+ [ "A word that is not a class has a $class-description" throw ] when ;
+
: all-word-help ( words -- seq )
[ word-help ] filter ;
dup '[
_ dup word-help
[ check-values ]
- [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
+ [ check-class-description ]
+ [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
] check-something
] [ drop ] if ;
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators call ;
+combinators call see ;
IN: help.markup
PREDICATE: simple-element < array
SYMBOL: last-element
SYMBOL: span
SYMBOL: block
-SYMBOL: table
: last-span? ( -- ? ) last-element get span eq? ;
: last-block? ( -- ? ) last-element get block eq? ;
[ print-element ] with-default-style ;
: ($block) ( quot -- )
- last-element get { f table } member? [ nl ] unless
+ last-element get [ nl ] when
span last-element set
call
block last-element set ; inline
table-content-style get [
swap [ last-element off call ] tabular-output
] with-style
- ] ($block) table last-element set ; inline
+ ] ($block) ; inline
: $list ( element -- )
list-style get [
] with-style
] ($block) ; inline
-: $see ( element -- ) first [ see ] ($see) ;
+: $see ( element -- ) first [ see* ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
drop
"Throws an error if the I/O operation fails." $errors ;
+FROM: prettyprint.private => with-pprint ;
+
: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
html.components html.forms namespaces
xml.writer ;
+\ render must-infer
+
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors strings namespaces assocs hashtables io
+USING: kernel accessors strings namespaces assocs hashtables io call
mirrors math fry sequences words continuations
xml.entities xml.writer xml.syntax ;
IN: html.forms
>hashtable "validators" set-word-prop ;
: validate ( value quot -- result )
- [ <validation-error> ] recover ; inline
+ '[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
: validate-value ( name value quot -- )
validate
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
-arrays strings html io.streams.string assocs
+arrays strings html io.streams.string assocs call
quotations xml.data xml.writer xml.syntax ;
IN: html.templates
M: string call-template* write ;
-M: callable call-template* call ;
+M: callable call-template* call( -- ) ;
M: xml call-template* write-xml ;
[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test
-[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
-
-[ { } ] [ "" parse-cookie ] unit-test
-[ { } ] [ "" parse-set-cookie ] unit-test
+[ "text/html" utf8 ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
-! Make sure that totally invalid cookies don't confuse us
-[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
+[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
: lf>crlf "\n" split "\r\n" join ;
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n\"" intersects?
+ dup "\r\n" intersects?
[ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
swap >>content-type ;
: parse-content-type-attributes ( string -- attributes )
- " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
+ " " split harvest [
+ "=" split1
+ [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
+ ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1
--- /dev/null
+IN: http.parsers.tests
+USING: http http.parsers tools.test ;
+
+[ { } ] [ "" parse-cookie ] unit-test
+[ { } ] [ "" parse-set-cookie ] unit-test
+
+! Make sure that totally invalid cookies don't confuse us
+[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
+
+[ { T{ cookie { name "__s" } { value "12345567" } } } ]
+[ "__s=12345567" parse-cookie ]
+unit-test
+
+[ { T{ cookie { name "__s" } { value "12345567" } } } ]
+[ "__s=12345567;" parse-cookie ]
+unit-test
\ No newline at end of file
'value' ,
'space' ,
] seq*
- [ ";,=" member? not ] satisfy repeat1 [ drop f ] action
+ [ ";,=" member? not ] satisfy repeat0 [ drop f ] action
2choice ;
PEG: (parse-cookie) ( string -- alist )
"CGI output follows" >>message\r
swap '[\r
binary encode-output\r
-
_ output-stream get swap <cgi-process> binary <process-stream> [
\r+
output-stream get _ <cgi-process> binary <process-stream> [
\r post-request? [ request get post-data>> data>> write flush ] when\r
- '[ _ write ] each-block\r
+ '[ _ stream-write ] each-block\r
] with-stream\r
] >>body ;\r
\r
[ content-charset>> encode-output ]
[ write-response-body ]
bi
- ] unless ;
+ ] unless drop ;
M: raw-response write-response ( respose -- )
write-response-line
write-response-body
drop ;
-M: raw-response write-full-response ( response -- )
- write-response ;
+M: raw-response write-full-response ( request response -- )
+ nip write-response ;
: post-request? ( -- ? ) request get method>> "POST" = ;
swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- )
- [ request get swap write-full-response ]
+ '[ request get _ write-full-response ]
[
[ \ do-response log-error ]
[
{ $side-effects "responder" } ;
ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
-"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
+"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- response )" } "."
$nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection enable-fhtml }
-! Copyright (C) 2004, 2008 Slava Pestov.\r
+! Copyright (C) 2004, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: calendar kernel math math.order math.parser namespaces\r
parser sequences strings assocs hashtables debugger mime.types\r
io.files.info io.directories io.pathnames io.encodings.binary\r
fry xml.entities destructors urls html xml.syntax\r
html.templates.fhtml http http.server http.server.responses\r
-http.server.redirection xml.writer ;\r
+http.server.redirection xml.writer call ;\r
IN: http.server.static\r
\r
TUPLE: file-responder root hook special allow-listings ;\r
\r
: serve-static ( filename mime-type -- response )\r
over modified-since?\r
- [ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
+ [ file-responder get hook>> call( filename mime-type -- response ) ]\r
+ [ 2drop <304> ]\r
+ if ;\r
\r
: serving-path ( filename -- filename )\r
[ file-responder get root>> trim-tail-separators "/" ] dip\r
: serve-file ( filename -- response )\r
dup mime-type\r
dup file-responder get special>> at\r
- [ call ] [ serve-static ] ?if ;\r
+ [ call( filename -- response ) ] [ serve-static ] ?if ;\r
\r
\ serve-file NOTICE add-input-logging\r
\r
USING: images.bitmap images.viewer io.encodings.binary
-io.files io.files.unique kernel tools.test images.loader ;
+io.files io.files.unique kernel tools.test images.loader
+literals sequences ;
IN: images.bitmap.tests
-: test-bitmap24 ( -- path )
- "vocab:images/test-images/thiswayup24.bmp" ;
+CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
-: test-bitmap8 ( -- path )
- "vocab:images/test-images/rgb8bit.bmp" ;
+CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp"
-: test-bitmap4 ( -- path )
- "vocab:images/test-images/rgb4bit.bmp" ;
+CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
-: test-bitmap1 ( -- path )
- "vocab:images/test-images/1bit.bmp" ;
+CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
[ t ]
[
"test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi =
] unit-test
+
+{
+ $ test-bitmap8
+ $ test-bitmap24
+ "vocab:ui/render/test/reference.bmp"
+} [ [ ] swap [ load-image drop ] curry unit-test ] each
\ No newline at end of file
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences
-strings images endian summary ;
+strings images endian summary locals ;
IN: images.bitmap
-TUPLE: bitmap-image < image
-magic size reserved offset header-length width
+: assert-sequence= ( a b -- )
+ 2dup sequence= [ 2drop ] [ assert ] if ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
+TUPLE: bitmap-image < image ;
+
+! Used to construct the final bitmap-image
+
+TUPLE: loading-bitmap
+size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
-! Currently can only handle 24/32bit bitmaps.
-! Handles row-reversed bitmaps (their height is negative)
-
ERROR: bitmap-magic magic ;
M: bitmap-magic summary
<PRIVATE
-: array-copy ( bitmap array -- bitmap array' )
- over size-image>> abs memory>byte-array ;
-
: 8bit>buffer ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
-: raw-bitmap>buffer ( bitmap -- array )
+: reverse-lines ( byte-array width -- byte-array )
+ 3 * <sliced-groups> <reversed> concat ; inline
+
+: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
- { 24 [ color-index>> ] }
- { 16 [ bmp-not-supported ] }
- { 8 [ 8bit>buffer ] }
- { 4 [ bmp-not-supported ] }
- { 2 [ bmp-not-supported ] }
- { 1 [ bmp-not-supported ] }
+ { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
+ { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
+ [ bmp-not-supported ]
} case >byte-array ;
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-: parse-file-header ( bitmap -- bitmap )
- 2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
+: parse-file-header ( loading-bitmap -- loading-bitmap )
+ 2 read "BM" assert-sequence=
read4 >>size
read4 >>reserved
read4 >>offset ;
-: parse-bitmap-header ( bitmap -- bitmap )
+: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
read4 >>width
- read4 >>height
+ read4 32 >signed >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
read4 >>color-used
read4 >>color-important ;
-: rgb-quads-length ( bitmap -- n )
+: rgb-quads-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
-: color-index-length ( bitmap -- n )
+: color-index-length ( loading-bitmap -- n )
{
[ width>> ]
[ planes>> * ]
[ height>> abs * ]
} cleave ;
-: parse-bitmap ( bitmap -- bitmap )
+: image-size ( loading-bitmap -- n )
+ [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
+
+:: fixup-color-index ( loading-bitmap -- loading-bitmap )
+ loading-bitmap width>> :> width
+ loading-bitmap height>> abs :> height
+ loading-bitmap color-index>> length :> color-index-length
+ height 3 * :> height*3
+ color-index-length width height*3 * - height*3 /i :> misaligned
+ misaligned 0 > [
+ loading-bitmap [
+ loading-bitmap width>> misaligned + 3 * <sliced-groups>
+ [ 3 misaligned * head* ] map concat
+ ] change-color-index
+ ] [
+ loading-bitmap
+ ] if ;
+
+: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index ;
+ dup color-index-length read >>color-index
+ fixup-color-index ;
-: load-bitmap-data ( path bitmap -- bitmap )
+: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
[ binary ] dip '[
_ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
-: process-bitmap-data ( bitmap -- bitmap )
- dup raw-bitmap>buffer >>bitmap ;
-
ERROR: unknown-component-order bitmap ;
-: bitmap>component-order ( bitmap -- object )
+: bitmap>component-order ( loading-bitmap -- object )
bit-count>> {
{ 32 [ BGRA ] }
{ 24 [ BGR ] }
[ unknown-component-order ]
} case ;
-: fill-image-slots ( bitmap -- bitmap )
- dup {
- [ [ width>> ] [ height>> ] bi 2array >>dim ]
+: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
+ [ bitmap-image new ] dip
+ {
+ [ raw-bitmap>seq >>bitmap ]
+ [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
+ [ height>> 0 < [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
- [ bitmap>> >>bitmap ]
} cleave ;
-M: bitmap-image load-image* ( path bitmap -- bitmap )
- load-bitmap-data process-bitmap-data
- fill-image-slots ;
-
-M: bitmap-image normalize-scan-line-order
- dup dim>> '[
- _ first 4 * <sliced-groups> reverse concat
- ] change-bitmap ;
-
-MACRO: (nbits>bitmap) ( bits -- )
- [ -3 shift ] keep '[
- bitmap-image new
- 2over * _ * >>size-image
- swap >>height
- swap >>width
- swap array-copy [ >>bitmap ] [ >>color-index ] bi
- _ >>bit-count fill-image-slots
- ] ;
-
-: bgr>bitmap ( array height width -- bitmap )
- 24 (nbits>bitmap) ;
-
-: bgra>bitmap ( array height width -- bitmap )
- 32 (nbits>bitmap) ;
-
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
+M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
+ drop loading-bitmap new
+ load-bitmap-data
+ loading-bitmap>bitmap-image ;
PRIVATE>
-: save-bitmap ( bitmap path -- )
+: bitmap>color-index ( bitmap-array -- byte-array )
+ 4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+
+: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
- color-index>> length 14 + 40 + write4
+ bitmap>> bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
] [
{
- [ width>> write4 ]
- [ height>> write4 ]
- [ planes>> 1 or write2 ]
- [ bit-count>> 24 or write2 ]
- [ compression>> 0 or write4 ]
- [ size-image>> write4 ]
- [ x-pels>> 0 or write4 ]
- [ y-pels>> 0 or write4 ]
- [ color-used>> 0 or write4 ]
- [ color-important>> 0 or write4 ]
- [ rgb-quads>> write ]
- [ color-index>> write ]
+ ! width height
+ [ dim>> first2 [ write4 ] bi@ ]
+
+ ! planes
+ [ drop 1 write2 ]
+
+ ! bit-count
+ [ drop 24 write2 ]
+
+ ! compression
+ [ drop 0 write4 ]
+
+ ! size-image
+ [ bitmap>> bitmap>color-index length write4 ]
+
+ ! x-pels
+ [ drop 0 write4 ]
+
+ ! y-pels
+ [ drop 0 write4 ]
+
+ ! color-used
+ [ drop 0 write4 ]
+
+ ! color-important
+ [ drop 0 write4 ]
+
+ ! rgb-quads
+ [
+ [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+ reverse-lines write
+ ]
} cleave
] bi
] with-file-writer ;
{ R32G32B32A32 [ 16 ] }
} case ;
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
M: R16G16B16 normalize-component-order*
drop RGB16>8 add-dummy-alpha ;
-: BGR>RGB ( bitmap bytes-per-pixel -- pixels )
- <groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
+: BGR>RGB ( bitmap -- pixels )
+ 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+ 4 <sliced-groups>
+ [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
M: BGRA normalize-component-order*
- drop 4 BGR>RGB ;
+ drop BGRA>RGBA ;
M: RGB normalize-component-order*
drop add-dummy-alpha ;
M: BGR normalize-component-order*
- drop 3 BGR>RGB add-dummy-alpha ;
+ drop BGR>RGB add-dummy-alpha ;
: ARGB>RGBA ( bitmap -- bitmap' )
- 4 <groups> [ unclip suffix ] map B{ } join ;
+ 4 <groups> [ unclip suffix ] map B{ } join ; inline
M: ARGB normalize-component-order*
drop ARGB>RGBA ;
M: ABGR normalize-component-order*
- drop ARGB>RGBA 4 BGR>RGB ;
-
-GENERIC: normalize-scan-line-order ( image -- image )
+ drop ARGB>RGBA BGRA>RGBA ;
-M: image normalize-scan-line-order ;
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
- normalize-scan-line-order ;
+ normalize-scan-line-order
+ RGBA >>component-order ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors constructors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited ;
+sequences io.streams.limited fry combinators arrays math
+checksums checksums.crc32 ;
IN: images.png
-TUPLE: png-image < image chunks ;
+TUPLE: png-image < image chunks
+width height bit-depth color-type compression-method
+filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image )
V{ } clone >>chunks ;
-TUPLE: png-chunk length type data crc ;
+TUPLE: png-chunk length type data ;
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
bad-png-header
] unless drop ;
+ERROR: bad-checksum ;
+
: read-png-chunks ( image -- image )
<png-chunk>
- 4 read be> >>length
- 4 read ascii decode >>type
- dup length>> read >>data
- 4 read >>crc
+ 4 read be> [ >>length ] [ 4 + ] bi
+ read dup crc32 checksum-bytes
+ 4 read = [ bad-checksum ] unless
+ 4 cut-slice
+ [ ascii decode >>type ]
+ [ B{ } like >>data ] bi*
[ over chunks>> push ]
[ type>> ] bi "IEND" =
[ read-png-chunks ] unless ;
+: find-chunk ( image string -- chunk )
+ [ chunks>> ] dip '[ type>> _ = ] find nip ;
+
+: parse-ihdr-chunk ( image -- image )
+ dup "IHDR" find-chunk data>> {
+ [ [ 0 4 ] dip subseq be> >>width ]
+ [ [ 4 8 ] dip subseq be> >>height ]
+ [ [ 8 ] dip nth >>bit-depth ]
+ [ [ 9 ] dip nth >>color-type ]
+ [ [ 10 ] dip nth >>compression-method ]
+ [ [ 11 ] dip nth >>filter-method ]
+ [ [ 12 ] dip nth >>interlace-method ]
+ } cleave ;
+
+: find-compressed-bytes ( image -- bytes )
+ chunks>> [ type>> "IDAT" = ] filter
+ [ data>> ] map concat ;
+
+: fill-image-data ( image -- image )
+ dup [ width>> ] [ height>> ] bi 2array >>dim ;
+
: load-png ( path -- image )
- [ binary <file-reader> ] [ file-info size>> ] bi stream-throws <limited-stream> [
+ [ binary <file-reader> ] [ file-info size>> ] bi
+ stream-throws <limited-stream> [
<png-image>
read-png-header
read-png-chunks
+ parse-ihdr-chunk
+ fill-image-data
] with-input-stream ;
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
- [ ifd-component-order ]
+ [ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;
H{ } describe
H{ } describe
-[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
SYMBOL: +number-rows+
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: print-summary ( obj -- ) [ summary ] keep write-object ;
<PRIVATE
: (describe) ( obj assoc -- keys )
t pprint-string-cells? [
- [ summary. ] [
+ [ print-summary nl ] [
dup hashtable? [ sort-unparsed-keys ] when
[ fix-slot-names add-numbers simple-table. ] [ keys ] bi
] bi*
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol generalizations ;
+combinators.short-circuit fry words.symbol generalizations call ;
RENAME: _ fry => __
IN: inverse
M: pop-inverse inverse
[ "pop-length" word-prop cut-slice swap >quotation ]
- [ "pop-inverse" word-prop ] bi compose call ;
+ [ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
: (undo) ( revquot -- )
[ unclip-slice inverse % (undo) ] unless-empty ;
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test
+
+[ f ] [
+ { "omg you shoudnt have a directory called this" "or this" }
+ t
+ [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
+] unit-test
+
+[ f ] [
+ { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
+] unit-test
ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
- [
- '[ _ _ find-file [ file-not-found ] unless* ] attempt-all
+ '[
+ _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
] recover ;
USING: io.encodings.iana io.encodings.euc ;
IN: io.encodings.big5
-EUC: big5 "vocab:io/encodings/big5/CP950.txt"
+EUC: big5 "vocab:io/encodings/big5/CP950.TXT"
big5 "Big5" register-encoding
USING: help.syntax help.markup ;
IN: io.encodings.euc-kr
-ABOUT: euc-kr
-
HELP: euc-kr
-{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR, in practice." }
+{ $class-description "This encoding class implements Microsoft's CP949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatible with EUC-KR in practice." }
{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding"
+{ $subsection euc-kr } ;
+
+ABOUT: "io.encodings.euc-kr"
\ No newline at end of file
USING: help.syntax help.markup ;
IN: io.encodings.johab
-ABOUT: johab
-
HELP: johab
{ $class-description "Korean Johab encoding (KSC5601-1992). This encoding is not commonly used anymore." } ;
+
+ARTICLE: "io.encodings.johab" "Korean Johab encoding"
+{ $subsection johab } ;
+
+ABOUT: "io.encodings.johab"
\ No newline at end of file
TUPLE: input-port < buffered-port ;
+M: input-port stream-element-type drop +byte+ ;
+
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
+M: output-port stream-element-type stream>> stream-element-type ;
+
M: output-port stream-write1
dup check-disposed
1 over wait-to-write
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
-combinators.short-circuit ;
+combinators.short-circuit call ;
IN: io.servers.connection
TUPLE: threaded-server
[ [ remote-address set ] [ local-address set ] bi* ]
2bi ;
-M: threaded-server handle-client* handler>> call ;
+M: threaded-server handle-client* handler>> call( -- ) ;
: handle-client ( client remote local -- )
'[
io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array
+M: byte-vector stream-element-type drop +byte+ ;
+
: <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ;
TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
+M: byte-reader stream-element-type drop +byte+ ;
+
M: byte-reader stream-read-partial stream-read ;
M: byte-reader stream-read sequence-read ;
M: byte-reader stream-read1 sequence-read1 ;
: >duplex-stream< ( stream -- in out ) [ in>> ] [ out>> ] bi ; inline
+M: duplex-stream stream-element-type
+ [ in>> ] [ out>> ] bi
+ [ stream-element-type ] bi@
+ 2dup eq? [ drop ] [ "Cannot determine element type" throw ] if ;
+
M: duplex-stream set-timeout
>duplex-stream< [ set-timeout ] bi-curry@ bi ;
: <memory-stream> ( alien -- stream )
0 memory-stream boa ;
+M: memory-stream stream-element-type drop +byte+ ;
+
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
io.streams.plain io.encodings math.order growable io.streams.sequence ;
IN: io.streams.string
-<PRIVATE
-
-SINGLETON: null-encoding
-
-M: null-encoding decode-char drop stream-read1 ;
-
-PRIVATE>
-
-M: growable dispose drop ;
-
-M: growable stream-write1 push ;
-M: growable stream-write push-all ;
-M: growable stream-flush drop ;
-
-: <string-writer> ( -- stream )
- 512 <sbuf> ;
-
-: with-string-writer ( quot -- str )
- <string-writer> swap [ output-stream get ] compose with-output-stream*
- >string ; inline
-
-! New implementation
-
+! Readers
TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
+M: string-reader stream-element-type drop +character+ ;
M: string-reader stream-read-partial stream-read ;
M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ;
M: string-reader stream-read-until sequence-read-until ;
M: string-reader dispose drop ;
+<PRIVATE
+SINGLETON: null-encoding
+M: null-encoding decode-char drop stream-read1 ;
+PRIVATE>
+
: <string-reader> ( str -- stream )
0 string-reader boa null-encoding <decoder> ;
: with-string-reader ( str quot -- )
[ <string-reader> ] dip with-input-stream ; inline
-INSTANCE: growable plain-writer
+! Writers
+M: sbuf stream-element-type drop +character+ ;
+
+: <string-writer> ( -- stream )
+ 512 <sbuf> ;
+
+: with-string-writer ( quot -- str )
+ <string-writer> swap [ output-stream get ] compose with-output-stream*
+ >string ; inline
\ No newline at end of file
CONSULT: formatted-output-stream-protocol filter-writer stream>> ;
+M: filter-writer stream-element-type stream>> stream-element-type ;
+
M: filter-writer dispose stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-output-stream* ;
+ [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
bi
] with-row
] each
- ] tabular-output
+ ] tabular-output nl
] unless-empty ;
: trimmed-stack. ( seq -- )
{ $subsection cdr }
{ $subsection nil? } ;
-ARTICLE: { "lists" "strict" } "Strict lists"
+ARTICLE: { "lists" "strict" } "Constructing strict lists"
"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:"
{ $subsection cons }
{ $subsection swons }
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions effects generic kernel locals
-macros memoize prettyprint prettyprint.backend words ;
+macros memoize prettyprint prettyprint.backend see words ;
IN: locals.definitions
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
USING: help.syntax help.markup kernel macros prettyprint
-memoize combinators arrays generalizations ;
+memoize combinators arrays generalizations see ;
IN: locals
HELP: [|
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
-definitions compiler.units fry lexer words.symbol ;
+definitions compiler.units fry lexer words.symbol see ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ >alist sort-values <reversed> ] dip [\r
[ swapd with-cell pprint-cell ] with-row\r
] curry assoc-each\r
- ] tabular-output ;\r
+ ] tabular-output ; inline\r
\r
: log-entry. ( entry -- )\r
"====== " write\r
PRIVATE>\r
\r
: (define-logging) ( word level quot -- )\r
- [ dup ] 2dip 2curry annotate ;\r
+ [ dup ] 2dip 2curry annotate ; inline\r
\r
: call-logging-quot ( quot word level -- quot' )\r
[ "called" ] 2dip [ log-message ] 3curry prepose ;\r
IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval ;
+vectors io.streams.string prettyprint parser eval see ;
MACRO: see-test ( a b -- c ) + ;
: define-integer-op-word ( fix-word big-word triple -- )
[
- [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
+ [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
(( x y -- z )) define-declared
] [
2nip
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser generalizations
-prettyprint io.streams.string sequences eval namespaces ;
+prettyprint io.streams.string sequences eval namespaces see ;
IN: memoize.tests
MEMO: fib ( m -- n )
{ $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models"
-"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
+"New types of models can be defined, for example see " { $vocab-link "models.arrow" } "."
$nl
"Models can execute hooks when activated:"
{ $subsection model-activated }
IN: opengl.textures.tests
[ ] [
- { 3 5 }
- RGB
- B{
- 1 2 3 4 5 6 7 8 9
- 10 11 12 13 14 15 16 17 18
- 19 20 21 22 23 24 25 26 27
- 28 29 30 31 32 33 34 35 36
- 37 38 39 40 41 42 43 44 45
- } image boa "image" set
+ T{ image
+ { dim { 3 5 } }
+ { component-order RGB }
+ { bitmap
+ B{
+ 1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18
+ 19 20 21 22 23 24 25 26 27
+ 28 29 30 31 32 33 34 35 36
+ 37 38 39 40 41 42 43 44 45
+ }
+ }
+ } "image" set
] unit-test
[
TUPLE: texture loc dim texture-coords texture display-list disposed ;
-<PRIVATE
-
GENERIC: component-order>format ( component-order -- format type )
+M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
+M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+<PRIVATE
+
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
continuations peg peg.parsers unicode.categories multiline\r
splitting accessors effects sequences.deep peg.search\r
combinators.short-circuit lexer io.streams.string stack-checker\r
-io combinators parser ;\r
+io combinators parser call ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
\r
: TOKENIZER: \r
scan search [ "Tokenizer not found" throw ] unless*\r
- execute \ tokenizer set-global ; parsing\r
+ execute( -- tokenizer ) \ tokenizer set-global ; parsing\r
\r
TUPLE: ebnf-non-terminal symbol ;\r
TUPLE: ebnf-terminal symbol ;\r
#! in the EBNF syntax itself.\r
[\r
{\r
- [ dup blank? ]\r
- [ dup CHAR: " = ]\r
- [ dup CHAR: ' = ]\r
- [ dup CHAR: | = ]\r
- [ dup CHAR: { = ]\r
- [ dup CHAR: } = ]\r
- [ dup CHAR: = = ]\r
- [ dup CHAR: ) = ]\r
- [ dup CHAR: ( = ]\r
- [ dup CHAR: ] = ]\r
- [ dup CHAR: [ = ]\r
- [ dup CHAR: . = ]\r
- [ dup CHAR: ! = ]\r
- [ dup CHAR: & = ]\r
- [ dup CHAR: * = ]\r
- [ dup CHAR: + = ]\r
- [ dup CHAR: ? = ]\r
- [ dup CHAR: : = ]\r
- [ dup CHAR: ~ = ]\r
- [ dup CHAR: < = ]\r
- [ dup CHAR: > = ]\r
- } 0|| not nip \r
+ [ blank? ]\r
+ [ CHAR: " = ]\r
+ [ CHAR: ' = ]\r
+ [ CHAR: | = ]\r
+ [ CHAR: { = ]\r
+ [ CHAR: } = ]\r
+ [ CHAR: = = ]\r
+ [ CHAR: ) = ]\r
+ [ CHAR: ( = ]\r
+ [ CHAR: ] = ]\r
+ [ CHAR: [ = ]\r
+ [ CHAR: . = ]\r
+ [ CHAR: ! = ]\r
+ [ CHAR: & = ]\r
+ [ CHAR: * = ]\r
+ [ CHAR: + = ]\r
+ [ CHAR: ? = ]\r
+ [ CHAR: : = ]\r
+ [ CHAR: ~ = ]\r
+ [ CHAR: < = ]\r
+ [ CHAR: > = ]\r
+ } 1|| not\r
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;\r
\r
: 'terminal' ( -- parser )\r
#! Parse a valid foreign parser name\r
[\r
{\r
- [ dup blank? ]\r
- [ dup CHAR: > = ]\r
- } 0|| not nip \r
+ [ blank? ]\r
+ [ CHAR: > = ]\r
+ } 1|| not\r
] satisfy repeat1 [ >string ] action ;\r
\r
: 'foreign' ( -- parser )\r
options>> [ (transform) ] map choice ;\r
\r
M: ebnf-any-character (transform) ( ast -- parser )\r
- drop tokenizer any>> call ;\r
+ drop tokenizer any>> call( -- parser ) ;\r
\r
M: ebnf-range (transform) ( ast -- parser )\r
pattern>> range-pattern ;\r
\r
M: ebnf-action (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
- string-lines parse-lines check-action-effect action ;\r
+ [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;\r
\r
M: ebnf-semantic (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals \r
- string-lines parse-lines semantic ;\r
+ [ string-lines parse-lines ] call( string -- quot ) semantic ;\r
\r
M: ebnf-var (transform) ( ast -- parser )\r
parser>> (transform) ;\r
\r
M: ebnf-terminal (transform) ( ast -- parser )\r
- symbol>> tokenizer one>> call ;\r
+ symbol>> tokenizer one>> call( symbol -- parser ) ;\r
\r
M: ebnf-foreign (transform) ( ast -- parser )\r
dup word>> search\r
swap rule>> [ main ] unless* over rule [\r
nip\r
] [\r
- execute\r
+ execute( -- parser )\r
] if* ;\r
\r
: parser-not-found ( name -- * )\r
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
+\ parse must-infer
+
[ ] [ reset-pegs ] unit-test
[
io vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser words
quotations effects memoize accessors locals effects splitting
-combinators.short-circuit generalizations ;
+combinators.short-circuit generalizations call ;
IN: peg
TUPLE: parse-result remaining ast ;
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
- call compile-parser 1quotation (( -- result )) define-declared
+ call( -- parser ) compile-parser 1quotation (( -- result )) define-declared
] assoc-each ;
: compile ( parser -- word )
] with-compilation-unit ;
: compiled-parse ( state word -- result )
- swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline
+ swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
: (parse) ( input parser -- result )
dup word? [ compile ] unless compiled-parse ;
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
#! it at run time.
- quot>> call compile-parser 1quotation ;
+ quot>> call( -- parser ) compile-parser 1quotation ;
PRIVATE>
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
+\ search must-infer
+\ replace must-infer
USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings generic classes ;
+io kernel words definitions quotations strings generic classes
+prettyprint.private ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
{ $subsection unparse-use }
"Utility for tabular output:"
{ $subsection pprint-cell }
-"Printing a definition (see " { $link "definitions" } "):"
-{ $subsection see }
-"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
-{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
{ $subsection "prettyprint-variables" }
{ $subsection "prettyprint-extension" }
{ $subsection "prettyprint-limitations" }
-{ $see-also "number-strings" } ;
+{ $see-also "number-strings" "see" } ;
ABOUT: "prettyprint"
HELP: in.
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Prettyprints a " { $snippet "IN:" } " declaration." }
-$prettyprinting-note ;
-
-HELP: synopsis
-{ $values { "defspec" "a definition specifier" } { "str" string } }
-{ $contract "Prettyprints the prologue of a definition." } ;
-
-HELP: synopsis*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
-{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
-
-HELP: comment.
-{ $values { "string" "a string" } }
-{ $description "Prettyprints some text with the comment style." }
-$prettyprinting-note ;
-
-HELP: see
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Prettyprints a definition." } ;
-
-HELP: see-methods
-{ $values { "word" "a " { $link generic } " or a " { $link class } } }
-{ $contract "Prettyprints the methods defined on a generic word or class." } ;
-
-HELP: definer
-{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
-{ $contract "Outputs the parsing words which delimit the definition." }
-{ $examples
- { $example "USING: definitions prettyprint ;"
- "IN: scratchpad"
- ": foo ; \\ foo definer . ."
- ";\nPOSTPONE: :"
- }
- { $example "USING: definitions prettyprint ;"
- "IN: scratchpad"
- "SYMBOL: foo \\ foo definer . ."
- "f\nPOSTPONE: SYMBOL:"
- }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;
-
-HELP: definition
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
-{ $contract "Outputs the body of a definition." }
-{ $examples
- { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;
+$prettyprinting-note ;
\ No newline at end of file
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser ;
+accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic generic.standard assocs io kernel math
-namespaces make sequences strings io.styles io.streams.string
-vectors words words.symbol prettyprint.backend prettyprint.custom
-prettyprint.sections prettyprint.config sorting splitting
-grouping math.parser vocabs definitions effects classes.builtin
-classes.tuple io.pathnames classes continuations hashtables
-classes.mixin classes.union classes.intersection
-classes.predicate classes.singleton combinators quotations sets
-accessors colors parser summary vocabs.parser ;
+USING: arrays accessors assocs colors combinators grouping io
+io.streams.string io.styles kernel make math math.parser namespaces
+parser prettyprint.backend prettyprint.config prettyprint.custom
+prettyprint.sections quotations sequences sorting strings vocabs
+vocabs.parser words sets ;
IN: prettyprint
+<PRIVATE
+
: make-pprint ( obj quot -- block in use )
[
0 position set
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
: in. ( vocab -- )
- [ write-in nl ] when* ;
+ [ write-in ] when* ;
: use. ( seq -- )
[
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
- ] with-pprint nl
+ ] with-pprint
] unless-empty ;
: use/in. ( in use -- )
- dupd remove [ { "syntax" "scratchpad" } member? not ] filter
- use. in. ;
+ over "syntax" 2array diff
+ [ nip use. ]
+ [ empty? not and [ nl ] when ]
+ [ drop in. ]
+ 2tri ;
: vocab-names ( words -- vocabs )
dictionary get
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
- in get use get vocab-names use/in. ;
+ in get use get vocab-names prune in get ".private" append swap remove use/in. ;
[
nl
- "Restarts were invoked adding vocabularies to the search path." print
- "To avoid doing this in the future, add the following USING:" print
- "and IN: forms at the top of the source file:" print nl
- prelude.
- nl
+ { { font-style bold } { font-name "sans-serif" } } [
+ "Restarts were invoked adding vocabularies to the search path." print
+ "To avoid doing this in the future, add the following USING:" print
+ "and IN: forms at the top of the source file:" print nl
+ ] with-style
+ { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting
+ nl nl
] print-use-hook set-global
+PRIVATE>
+
: with-use ( obj quot -- )
- make-pprint use/in. do-pprint ; inline
+ make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi
+ do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline
] each
] with-row
] each
- ] tabular-output ;
-
-GENERIC: see ( defspec -- )
-
-: comment. ( string -- )
- [ H{ { font-style italic } } styled-text ] when* ;
-
-: seeing-word ( word -- )
- vocabulary>> pprinter-in set ;
-
-: definer. ( defspec -- )
- definer drop pprint-word ;
-
-: stack-effect. ( word -- )
- [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
- [ effect>string comment. ] when* ;
-
-: word-synopsis ( word -- )
- {
- [ seeing-word ]
- [ definer. ]
- [ pprint-word ]
- [ stack-effect. ]
- } cleave ;
-
-M: word synopsis* word-synopsis ;
-
-M: simple-generic synopsis* word-synopsis ;
-
-M: standard-generic synopsis*
- {
- [ definer. ]
- [ seeing-word ]
- [ pprint-word ]
- [ dispatch# pprint* ]
- [ stack-effect. ]
- } cleave ;
-
-M: hook-generic synopsis*
- {
- [ definer. ]
- [ seeing-word ]
- [ pprint-word ]
- [ "combination" word-prop var>> pprint* ]
- [ stack-effect. ]
- } cleave ;
-
-M: method-spec synopsis*
- first2 method synopsis* ;
-
-M: method-body synopsis*
- [ definer. ]
- [ "method-class" word-prop pprint-word ]
- [ "method-generic" word-prop pprint-word ] tri ;
-
-M: mixin-instance synopsis*
- [ definer. ]
- [ class>> pprint-word ]
- [ mixin>> pprint-word ] tri ;
-
-M: pathname synopsis* pprint* ;
-
-: synopsis ( defspec -- str )
- [
- 0 margin set
- 1 line-limit set
- [ synopsis* ] with-in
- ] with-string-writer ;
-
-M: word summary synopsis ;
-
-GENERIC: declarations. ( obj -- )
-
-M: object declarations. drop ;
-
-: declaration. ( word prop -- )
- [ nip ] [ name>> word-prop ] 2bi
- [ pprint-word ] [ drop ] if ;
-
-M: word declarations.
- {
- POSTPONE: parsing
- POSTPONE: delimiter
- POSTPONE: inline
- POSTPONE: recursive
- POSTPONE: foldable
- POSTPONE: flushable
- } [ declaration. ] with each ;
-
-: pprint-; ( -- ) \ ; pprint-word ;
-
-M: object see
- [
- 12 nesting-limit set
- 100 length-limit set
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block>
- ] with-use nl ;
-
-M: method-spec see
- first2 method see ;
-
-GENERIC: see-class* ( word -- )
-
-M: union-class see-class*
- <colon \ UNION: pprint-word
- dup pprint-word
- members pprint-elements pprint-; block> ;
-
-M: intersection-class see-class*
- <colon \ INTERSECTION: pprint-word
- dup pprint-word
- participants pprint-elements pprint-; block> ;
-
-M: mixin-class see-class*
- <block \ MIXIN: pprint-word
- dup pprint-word <block
- dup members [
- hard line-break
- \ INSTANCE: pprint-word pprint-word pprint-word
- ] with each block> block> ;
-
-M: predicate-class see-class*
- <colon \ PREDICATE: pprint-word
- dup pprint-word
- "<" text
- dup superclass pprint-word
- <block
- "predicate-definition" word-prop pprint-elements
- pprint-; block> block> ;
-
-M: singleton-class see-class* ( class -- )
- \ SINGLETON: pprint-word pprint-word ;
-
-GENERIC: pprint-slot-name ( object -- )
-
-M: string pprint-slot-name text ;
-
-M: array pprint-slot-name
- <flow \ { pprint-word
- f <inset unclip text pprint-elements block>
- \ } pprint-word block> ;
-
-: unparse-slot ( slot-spec -- array )
- [
- dup name>> ,
- dup class>> object eq? [
- dup class>> ,
- initial: ,
- dup initial>> ,
- ] unless
- dup read-only>> [
- read-only ,
- ] when
- drop
- ] { } make ;
-
-: pprint-slot ( slot-spec -- )
- unparse-slot
- dup length 1 = [ first ] when
- pprint-slot-name ;
-
-M: tuple-class see-class*
- <colon \ TUPLE: pprint-word
- dup pprint-word
- dup superclass tuple eq? [
- "<" text dup superclass pprint-word
- ] unless
- <block "slots" word-prop [ pprint-slot ] each block>
- pprint-; block> ;
-
-M: word see-class* drop ;
-
-M: builtin-class see-class*
- drop "! Built-in class" comment. ;
-
-: see-class ( class -- )
- dup class? [
- [
- dup seeing-word dup see-class*
- ] with-use nl
- ] when drop ;
-
-M: word see
- [ see-class ]
- [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
- [
- dup [ class? ] [ symbol? ] bi and
- [ drop ] [ call-next-method ] if
- ] tri ;
-
-: see-all ( seq -- )
- natural-sort [ nl ] [ see ] interleave ;
-
-: (see-implementors) ( class -- seq )
- dup implementors [ method ] with map natural-sort ;
-
-: (see-methods) ( generic -- seq )
- "methods" word-prop values natural-sort ;
-
-: methods ( word -- seq )
- [
- dup class? [ dup (see-implementors) % ] when
- dup generic? [ dup (see-methods) % ] when
- drop
- ] { } make prune ;
-
-: see-methods ( word -- )
- methods see-all ;
+ ] tabular-output nl ;
\ No newline at end of file
HELP: colon
{ $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
-{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
+{ $notes "Colon sections are used to enclose word definitions when " { $link "see" } "." } ;
HELP: <colon
{ $description "Begins a " { $link colon } " section." } ;
--- /dev/null
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays accessors fry sequences regexp.classes ;
+FROM: math.ranges => [a,b] ;
+IN: regexp.ast
+
+TUPLE: negation term ;
+C: <negation> negation
+
+TUPLE: from-to n m ;
+C: <from-to> from-to
+
+TUPLE: at-least n ;
+C: <at-least> at-least
+
+TUPLE: tagged-epsilon tag ;
+C: <tagged-epsilon> tagged-epsilon
+
+CONSTANT: epsilon T{ tagged-epsilon { tag t } }
+
+TUPLE: concatenation first second ;
+
+: <concatenation> ( seq -- concatenation )
+ [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
+
+TUPLE: alternation first second ;
+
+: <alternation> ( seq -- alternation )
+ unclip [ alternation boa ] reduce ;
+
+TUPLE: star term ;
+C: <star> star
+
+TUPLE: with-options tree options ;
+C: <with-options> with-options
+
+TUPLE: options on off ;
+C: <options> options
+
+SINGLETONS: unix-lines dotall multiline comments case-insensitive
+unicode-case reversed-regexp ;
+
+: <maybe> ( term -- term' )
+ f <concatenation> 2array <alternation> ;
+
+: <plus> ( term -- term' )
+ dup <star> 2array <concatenation> ;
+
+: repetition ( n term -- term' )
+ <array> <concatenation> ;
+
+GENERIC: <times> ( term times -- term' )
+M: at-least <times>
+ n>> swap [ repetition ] [ <star> ] bi 2array <concatenation> ;
+M: from-to <times>
+ [ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map <alternation> ;
+
+: char-class ( ranges ? -- term )
+ [ <or-class> ] dip [ <not-class> ] when ;
+
+TUPLE: lookahead term ;
+C: <lookahead> lookahead
+
+TUPLE: lookbehind term ;
+C: <lookbehind> lookbehind
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math vectors ;
-IN: regexp.backend
-
-TUPLE: regexp
- raw
- { options hashtable }
- stack
- parse-tree
- nfa-table
- dfa-table
- minimized-table
- matchers
- { nfa-traversal-flags hashtable }
- { dfa-traversal-flags hashtable }
- { state integer }
- { new-states vector }
- { visited-states hashtable } ;
-
-: reset-regexp ( regexp -- regexp )
- 0 >>state
- V{ } clone >>stack
- V{ } clone >>new-states
- H{ } clone >>visited-states ;
-
-SYMBOL: current-regexp
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.classes tools.test arrays kernel ;
+IN: regexp.classes.tests
+
+! Class algebra
+
+[ f ] [ { 1 2 } <and-class> ] unit-test
+[ T{ or-class f { 1 2 } } ] [ { 1 2 } <or-class> ] unit-test
+[ 3 ] [ { 1 2 } <and-class> 3 2array <or-class> ] unit-test
+[ CHAR: A ] [ CHAR: A LETTER-class <primitive-class> 2array <and-class> ] unit-test
+[ CHAR: A ] [ LETTER-class <primitive-class> CHAR: A 2array <and-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ CHAR: A LETTER-class <primitive-class> 2array <or-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ LETTER-class <primitive-class> CHAR: A 2array <or-class> ] unit-test
+[ t ] [ { t 1 } <or-class> ] unit-test
+[ t ] [ { 1 t } <or-class> ] unit-test
+[ f ] [ { f 1 } <and-class> ] unit-test
+[ f ] [ { 1 f } <and-class> ] unit-test
+[ 1 ] [ { f 1 } <or-class> ] unit-test
+[ 1 ] [ { 1 f } <or-class> ] unit-test
+[ 1 ] [ { t 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 t } <and-class> ] unit-test
+[ 1 ] [ 1 <not-class> <not-class> ] unit-test
+[ 1 ] [ { 1 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 1 } <or-class> ] unit-test
+[ t ] [ { t t } <or-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <and-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <or-class> ] unit-test
+[ T{ or-class { seq { 1 2 3 } } } ] [ { 1 2 } <or-class> { 2 3 } <or-class> 2array <or-class> ] unit-test
+[ T{ or-class { seq { 2 3 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
+[ f ] [ t <not-class> ] unit-test
+[ t ] [ f <not-class> ] unit-test
+[ f ] [ 1 <not-class> 1 t answer ] unit-test
+[ t ] [ { 1 2 } <or-class> <not-class> 1 2 3array <or-class> ] unit-test
+[ f ] [ { 1 2 } <and-class> <not-class> 1 2 3array <and-class> ] unit-test
+
+! Making classes into nested conditionals
+
+[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
+[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
+[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
+[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
+[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test
+[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
+
+SYMBOL: foo
+SYMBOL: bar
+
+[ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test
+
+[ t ] [ foo <primitive-class> dup t answer ] unit-test
+[ f ] [ foo <primitive-class> dup f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f answer ] unit-test
+[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f answer ] unit-test
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math math.order words regexp.utils
-unicode.categories combinators.short-circuit ;
+USING: accessors kernel math math.order words combinators locals
+ascii unicode.categories combinators.short-circuit sequences
+fry macros arrays assocs sets classes mirrors ;
IN: regexp.classes
SINGLETONS: any-char any-char-no-nl
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
-SINGLETONS: beginning-of-input beginning-of-line
-end-of-input end-of-line ;
+SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file word-break ;
-MIXIN: node
-TUPLE: character-class-range from to ; INSTANCE: character-class-range node
+TUPLE: range from to ;
+C: <range> range
GENERIC: class-member? ( obj class -- ? )
-M: t class-member? ( obj class -- ? ) 2drop f ;
+M: t class-member? ( obj class -- ? ) 2drop t ;
-M: integer class-member? ( obj class -- ? ) 2drop f ;
+M: integer class-member? ( obj class -- ? ) = ;
-M: character-class-range class-member? ( obj class -- ? )
+M: range class-member? ( obj class -- ? )
[ from>> ] [ to>> ] bi between? ;
M: any-char class-member? ( obj class -- ? )
M: digit-class class-member? ( obj class -- ? )
drop digit? ;
+: c-identifier-char? ( ch -- ? )
+ { [ alpha? ] [ CHAR: _ = ] } 1|| ;
+
M: c-identifier-class class-member? ( obj class -- ? )
- drop
- { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
+ drop c-identifier-char? ;
M: alpha-class class-member? ( obj class -- ? )
drop alpha? ;
+: punct? ( ch -- ? )
+ "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
M: punctuation-class class-member? ( obj class -- ? )
drop punct? ;
+: java-printable? ( ch -- ? )
+ { [ alpha? ] [ punct? ] } 1|| ;
+
M: java-printable-class class-member? ( obj class -- ? )
drop java-printable? ;
drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
M: control-character-class class-member? ( obj class -- ? )
- drop control-char? ;
+ drop control? ;
+
+: hex-digit? ( ch -- ? )
+ {
+ [ CHAR: A CHAR: F between? ]
+ [ CHAR: a CHAR: f between? ]
+ [ CHAR: 0 CHAR: 9 between? ]
+ } 1|| ;
M: hex-digit-class class-member? ( obj class -- ? )
drop hex-digit? ;
+: java-blank? ( ch -- ? )
+ {
+ CHAR: \s CHAR: \t CHAR: \n
+ HEX: b HEX: 7 CHAR: \r
+ } member? ;
+
M: java-blank-class class-member? ( obj class -- ? )
drop java-blank? ;
2drop f ;
M: terminator-class class-member? ( obj class -- ? )
- drop {
- [ CHAR: \r = ]
- [ CHAR: \n = ]
- [ CHAR: \u000085 = ]
- [ CHAR: \u002028 = ]
- [ CHAR: \u002029 = ]
- } 1|| ;
+ drop "\r\n\u000085\u002029\u002028" member? ;
-M: beginning-of-line class-member? ( obj class -- ? )
+M: ^ class-member? ( obj class -- ? )
2drop f ;
-M: end-of-line class-member? ( obj class -- ? )
+M: $ class-member? ( obj class -- ? )
2drop f ;
+
+M: f class-member? 2drop f ;
+
+TUPLE: primitive-class class ;
+C: <primitive-class> primitive-class
+
+TUPLE: not-class class ;
+
+PREDICATE: not-integer < not-class class>> integer? ;
+PREDICATE: not-primitive < not-class class>> primitive-class? ;
+
+M: not-class class-member?
+ class>> class-member? not ;
+
+TUPLE: or-class seq ;
+
+M: or-class class-member?
+ seq>> [ class-member? ] with any? ;
+
+TUPLE: and-class seq ;
+
+M: and-class class-member?
+ seq>> [ class-member? ] with all? ;
+
+DEFER: substitute
+
+: flatten ( seq class -- newseq )
+ '[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline
+
+:: seq>instance ( seq empty class -- instance )
+ seq length {
+ { 0 [ empty ] }
+ { 1 [ seq first ] }
+ [ drop class new seq { } like >>seq ]
+ } case ; inline
+
+TUPLE: class-partition integers not-integers primitives not-primitives and or other ;
+
+: partition-classes ( seq -- class-partition )
+ prune
+ [ integer? ] partition
+ [ not-integer? ] partition
+ [ primitive-class? ] partition ! extend primitive-class to epsilon tags
+ [ not-primitive? ] partition
+ [ and-class? ] partition
+ [ or-class? ] partition
+ class-partition boa ;
+
+: class-partition>seq ( class-partition -- seq )
+ make-mirror values concat ;
+
+: repartition ( partition -- partition' )
+ ! This could be made more efficient; only and and or are effected
+ class-partition>seq partition-classes ;
+
+: filter-not-integers ( partition -- partition' )
+ dup
+ [ primitives>> ] [ not-primitives>> ] [ or>> ] tri
+ 3append and-class boa
+ '[ [ class>> _ class-member? ] filter ] change-not-integers ;
+
+: answer-ors ( partition -- partition' )
+ dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ '[ [ _ [ t substitute ] each ] map ] change-or ;
+
+: contradiction? ( partition -- ? )
+ {
+ [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ other>> f swap member? ]
+ } 1|| ;
+
+: make-and-class ( partition -- and-class )
+ answer-ors repartition
+ [ t swap remove ] change-other
+ dup contradiction?
+ [ drop f ]
+ [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ;
+
+: <and-class> ( seq -- class )
+ dup and-class flatten partition-classes
+ dup integers>> length {
+ { 0 [ nip make-and-class ] }
+ { 1 [ integers>> first [ '[ _ swap class-member? ] all? ] keep and ] }
+ [ 3drop f ]
+ } case ;
+
+: filter-integers ( partition -- partition' )
+ dup
+ [ primitives>> ] [ not-primitives>> ] [ and>> ] tri
+ 3append or-class boa
+ '[ [ _ class-member? not ] filter ] change-integers ;
+
+: answer-ands ( partition -- partition' )
+ dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ '[ [ _ [ f substitute ] each ] map ] change-and ;
+
+: tautology? ( partition -- ? )
+ {
+ [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ other>> t swap member? ]
+ } 1|| ;
+
+: make-or-class ( partition -- and-class )
+ answer-ands repartition
+ [ f swap remove ] change-other
+ dup tautology?
+ [ drop t ]
+ [ filter-integers class-partition>seq prune f or-class seq>instance ] if ;
+
+: <or-class> ( seq -- class )
+ dup or-class flatten partition-classes
+ dup not-integers>> length {
+ { 0 [ nip make-or-class ] }
+ { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] }
+ [ 3drop t ]
+ } case ;
+
+GENERIC: <not-class> ( class -- inverse )
+
+M: object <not-class>
+ not-class boa ;
+
+M: not-class <not-class>
+ class>> ;
+
+M: and-class <not-class>
+ seq>> [ <not-class> ] map <or-class> ;
+
+M: or-class <not-class>
+ seq>> [ <not-class> ] map <and-class> ;
+
+M: t <not-class> drop f ;
+M: f <not-class> drop t ;
+
+M: primitive-class class-member?
+ class>> class-member? ;
+
+UNION: class primitive-class not-class or-class and-class range ;
+
+TUPLE: condition question yes no ;
+C: <condition> condition
+
+GENERIC# answer 2 ( class from to -- new-class )
+
+M:: object answer ( class from to -- new-class )
+ class from = to class ? ;
+
+: replace-compound ( class from to -- seq )
+ [ seq>> ] 2dip '[ _ _ answer ] map ;
+
+M: and-class answer
+ replace-compound <and-class> ;
+
+M: or-class answer
+ replace-compound <or-class> ;
+
+M: not-class answer
+ [ class>> ] 2dip answer <not-class> ;
+
+GENERIC# substitute 1 ( class from to -- new-class )
+M: object substitute answer ;
+M: not-class substitute [ <not-class> ] bi@ answer ;
+
+: assoc-answer ( table question answer -- new-table )
+ '[ _ _ substitute ] assoc-map
+ [ nip ] assoc-filter ;
+
+: assoc-answers ( table questions answer -- new-table )
+ '[ _ assoc-answer ] each ;
+
+DEFER: make-condition
+
+: (make-condition) ( table questions question -- condition )
+ [ 2nip ]
+ [ swap [ t assoc-answer ] dip make-condition ]
+ [ swap [ f assoc-answer ] dip make-condition ] 3tri
+ 2dup = [ 2nip ] [ <condition> ] if ;
+
+: make-condition ( table questions -- condition )
+ [ keys ] [ unclip (make-condition) ] if-empty ;
+
+GENERIC: class>questions ( class -- questions )
+: compound-questions ( class -- questions ) seq>> [ class>questions ] gather ;
+M: or-class class>questions compound-questions ;
+M: and-class class>questions compound-questions ;
+M: not-class class>questions class>> class>questions ;
+M: object class>questions 1array ;
+
+: table>questions ( table -- questions )
+ values [ class>questions ] gather >array t swap remove ;
+
+: table>condition ( table -- condition )
+ ! input table is state => class
+ >alist dup table>questions make-condition ;
+
+: condition-map ( condition quot: ( obj -- obj' ) -- new-condition )
+ over condition? [
+ [ [ question>> ] [ yes>> ] [ no>> ] tri ] dip
+ '[ _ condition-map ] bi@ <condition>
+ ] [ call ] if ; inline recursive
+
+: condition-states ( condition -- states )
+ dup condition? [
+ [ yes>> ] [ no>> ] bi
+ [ condition-states ] bi@ append prune
+ ] [ 1array ] if ;
+
+: condition-at ( condition assoc -- new-condition )
+ '[ _ at ] condition-map ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup regexp strings ;
+IN: regexp.combinators
+
+ABOUT: "regexp.combinators"
+
+ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale"
+"Regular expression combinators are useful when part of the regular expression contains user input. For example, given a sequence of strings on the stack, a regular expression which matches any one of them can be constructed:"
+{ $code
+ "[ <literal> ] map <or>"
+}
+"Without combinators, a naive approach would look as follows:"
+{ $code
+ "\"|\" join <regexp>"
+}
+"However, this code is incorrect, because one of the strings in the sequence might contain characters which have special meaning inside a regular expression. Combinators avoid this problem by building a regular expression syntax tree directly, without any parsing." ;
+
+ARTICLE: "regexp.combinators" "Regular expression combinators"
+"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
+{ $subsection "regexp.combinators.intro" }
+"Basic combinators:"
+{ $subsection <literal> }
+{ $subsection <nothing> }
+"Higher-order combinators for building new regular expressions from existing ones:"
+{ $subsection <or> }
+{ $subsection <and> }
+{ $subsection <not> }
+{ $subsection <sequence> }
+{ $subsection <zero-or-more> }
+"Derived combinators implemented in terms of the above:"
+{ $subsection <one-or-more> }
+"Setting options:"
+{ $subsection <option> } ;
+
+HELP: <literal>
+{ $values { "string" string } { "regexp" regexp } }
+{ $description "Creates a regular expression which matches the given literal string." } ;
+
+HELP: <nothing>
+{ $values { "value" regexp } }
+{ $description "The empty regular language." } ;
+
+HELP: <or>
+{ $values { "regexps" "a sequence of regular expressions" } { "disjunction" regexp } }
+{ $description "Creates a new regular expression which matches the union of what elements of the sequence match." } ;
+
+HELP: <and>
+{ $values { "regexps" "a sequence of regular expressions" } { "conjunction" regexp } }
+{ $description "Creates a new regular expression which matches the intersection of what elements of the sequence match." } ;
+
+HELP: <sequence>
+{ $values { "regexps" "a sequence of regular expressions" } { "regexp" regexp } }
+{ $description "Creates a new regular expression which matches strings that match each element of the sequence in order." } ;
+
+HELP: <not>
+{ $values { "regexp" regexp } { "not-regexp" regexp } }
+{ $description "Creates a new regular expression which matches everything that the given regexp does not match." } ;
+
+HELP: <one-or-more>
+{ $values { "regexp" regexp } { "regexp+" regexp } }
+{ $description "Creates a new regular expression which matches one or more copies of the given regexp." } ;
+
+HELP: <option>
+{ $values { "regexp" regexp } { "regexp?" regexp } }
+{ $description "Creates a new regular expression which matches zero or one copies of the given regexp." } ;
+
+HELP: <zero-or-more>
+{ $values { "regexp" regexp } { "regexp*" regexp } }
+{ $description "Creates a new regular expression which matches zero or more copies of the given regexp." } ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.combinators tools.test regexp kernel sequences ;
+IN: regexp.combinators.tests
+
+: strings ( -- regexp )
+ { "foo" "bar" "baz" } <any-of> ;
+
+[ t t t ] [ "foo" "bar" "baz" [ strings matches? ] tri@ ] unit-test
+[ f f f ] [ "food" "ibar" "ba" [ strings matches? ] tri@ ] unit-test
+
+: conj ( -- regexp )
+ { R' .*a' R' b.*' } <and> ;
+
+[ t ] [ "bljhasflsda" conj matches? ] unit-test
+[ f ] [ "bsdfdfs" conj matches? ] unit-test
+[ f ] [ "fsfa" conj matches? ] unit-test
+
+[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
+[ t ] [ "bsdfdfs" conj <not> matches? ] unit-test
+[ t ] [ "fsfa" conj <not> matches? ] unit-test
+
+[ f f ] [ "" "hi" [ <nothing> matches? ] bi@ ] unit-test
+[ t t ] [ "" "hi" [ <nothing> <not> matches? ] bi@ ] unit-test
+
+[ { t t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <zero-or-more> matches? ] map ] unit-test
+[ { f t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <one-or-more> matches? ] map ] unit-test
+[ { t t f f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <option> matches? ] map ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp sequences kernel regexp.negation regexp.ast
+accessors fry regexp.classes ;
+IN: regexp.combinators
+
+<PRIVATE
+
+: modify-regexp ( regexp raw-quot tree-quot -- new-regexp )
+ [ '[ raw>> @ ] ]
+ [ '[ parse-tree>> @ ] ] bi* bi
+ make-regexp ; inline
+
+PRIVATE>
+
+CONSTANT: <nothing> R/ (?~.*)/
+
+: <literal> ( string -- regexp )
+ [ "\\Q" "\\E" surround ] [ <concatenation> ] bi make-regexp ; foldable
+
+: <char-range> ( char1 char2 -- regexp )
+ [ [ "[" "-" surround ] [ "]" append ] bi* append ]
+ [ <range> ]
+ 2bi make-regexp ;
+
+: <or> ( regexps -- disjunction )
+ [ [ raw>> "(" ")" surround ] map "|" join ]
+ [ [ parse-tree>> ] map <alternation> ] bi
+ make-regexp ; foldable
+
+: <any-of> ( strings -- regexp )
+ [ <literal> ] map <or> ; foldable
+
+: <sequence> ( regexps -- regexp )
+ [ [ raw>> ] map concat ]
+ [ [ parse-tree>> ] map <concatenation> ] bi
+ make-regexp ; foldable
+
+: <not> ( regexp -- not-regexp )
+ [ "(?~" ")" surround ]
+ [ <negation> ] modify-regexp ; foldable
+
+: <and> ( regexps -- conjunction )
+ [ <not> ] map <or> <not> ; foldable
+
+: <zero-or-more> ( regexp -- regexp* )
+ [ "(" ")*" surround ]
+ [ <star> ] modify-regexp ; foldable
+
+: <one-or-more> ( regexp -- regexp+ )
+ [ "(" ")+" surround ]
+ [ <plus> ] modify-regexp ; foldable
+
+: <option> ( regexp -- regexp? )
+ [ "(" ")?" surround ]
+ [ <maybe> ] modify-regexp ; foldable
--- /dev/null
+Combinators for creating regular expressions
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.classes kernel sequences regexp.negation
+quotations assocs fry math locals combinators
+accessors words compiler.units kernel.private strings
+sequences.private arrays namespaces unicode.breaks
+regexp.transition-tables combinators.short-circuit ;
+IN: regexp.compiler
+
+GENERIC: question>quot ( question -- quot )
+
+SYMBOL: shortest?
+SYMBOL: backwards?
+
+<PRIVATE
+
+M: t question>quot drop [ 2drop t ] ;
+M: f question>quot drop [ 2drop f ] ;
+
+M: not-class question>quot
+ class>> question>quot [ not ] compose ;
+
+M: beginning-of-input question>quot
+ drop [ drop zero? ] ;
+
+M: end-of-input question>quot
+ drop [ length = ] ;
+
+M: end-of-file question>quot
+ drop [
+ {
+ [ length swap - 2 <= ]
+ [ swap tail { "\n" "\r\n" "\r" "" } member? ]
+ } 2&&
+ ] ;
+
+M: $ question>quot
+ drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
+
+M: ^ question>quot
+ drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+
+M: word-break question>quot
+ drop [ word-break-at? ] ;
+
+: (execution-quot) ( next-state -- quot )
+ ! The conditions here are for lookaround and anchors, etc
+ dup condition? [
+ [ question>> question>quot ] [ yes>> ] [ no>> ] tri
+ [ (execution-quot) ] bi@
+ '[ 2dup @ _ _ if ]
+ ] [ '[ _ execute ] ] if ;
+
+: execution-quot ( next-state -- quot )
+ dup sequence? [ first ] when
+ (execution-quot) ;
+
+TUPLE: box contents ;
+C: <box> box
+
+: condition>quot ( condition -- quot )
+ ! Conditions here are for different classes
+ dup condition? [
+ [ question>> ] [ yes>> ] [ no>> ] tri
+ [ condition>quot ] bi@
+ '[ dup _ class-member? _ _ if ]
+ ] [
+ contents>>
+ [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
+ ] if ;
+
+: non-literals>dispatch ( literals non-literals -- quot )
+ [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
+ swap keys f assoc-answers
+ table>condition [ <box> ] condition-map condition>quot ;
+
+: literals>cases ( literal-transitions -- case-body )
+ [ execution-quot ] assoc-map ;
+
+: split-literals ( transitions -- case default )
+ { } assoc-like [ first integer? ] partition
+ [ [ literals>cases ] keep ] dip non-literals>dispatch ;
+
+:: step ( last-match index str quot final? direction -- last-index/f )
+ final? index last-match ?
+ index str bounds-check? [
+ index direction + str
+ index str nth-unsafe
+ quot call
+ ] when ; inline
+
+: direction ( -- n )
+ backwards? get -1 1 ? ;
+
+: transitions>quot ( transitions final-state? -- quot )
+ dup shortest? get and [ 2drop [ drop nip ] ] [
+ [ split-literals swap case>quot ] dip direction
+ '[ { array-capacity string } declare _ _ _ step ]
+ ] if ;
+
+: word>quot ( word dfa -- quot )
+ [ transitions>> at ]
+ [ final-states>> key? ] 2bi
+ transitions>quot ;
+
+: states>code ( words dfa -- )
+ [
+ '[
+ dup _ word>quot
+ (( last-match index string -- ? ))
+ define-declared
+ ] each
+ ] with-compilation-unit ;
+
+: states>words ( dfa -- words dfa )
+ dup transitions>> keys [ gensym ] H{ } map>assoc
+ [ transitions-at ]
+ [ values ]
+ bi swap ;
+
+: dfa>main-word ( dfa -- word )
+ states>words [ states>code ] keep start-state>> ;
+
+PRIVATE>
+
+: simple-define-temp ( quot effect -- word )
+ [ define-temp ] with-compilation-unit ;
+
+: dfa>word ( dfa -- quot )
+ dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+ (( start-index string regexp -- i/f )) simple-define-temp ;
+
+: dfa>shortest-word ( dfa -- word )
+ t shortest? [ dfa>word ] with-variable ;
+
+: dfa>reverse-word ( dfa -- word )
+ t backwards? [ dfa>word ] with-variable ;
+
+: dfa>reverse-shortest-word ( dfa -- word )
+ t backwards? [ dfa>shortest-word ] with-variable ;
--- /dev/null
+USING: regexp.dfa tools.test ;
+IN: regexp.dfa.tests
+
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry kernel locals
math math.order regexp.nfa regexp.transition-tables sequences
-sets sorting vectors regexp.utils sequences.deep ;
-USING: io prettyprint threads ;
+sets sorting vectors regexp.ast regexp.classes ;
IN: regexp.dfa
-: find-delta ( states transition regexp -- new-states )
- nfa-table>> transitions>>
- rot [ swap at at ] with with gather sift ;
+: find-delta ( states transition nfa -- new-states )
+ transitions>> '[ _ swap _ at at ] gather sift ;
-: (find-epsilon-closure) ( states regexp -- new-states )
- eps swap find-delta ;
+:: epsilon-loop ( state table nfa question -- )
+ state table at :> old-value
+ old-value question 2array <or-class> :> new-question
+ new-question old-value = [
+ new-question state table set-at
+ state nfa transitions>> at
+ [ drop tagged-epsilon? ] assoc-filter
+ [| trans to |
+ to [
+ table nfa
+ trans tag>> new-question 2array <and-class>
+ epsilon-loop
+ ] each
+ ] assoc-each
+ ] unless ;
-: find-epsilon-closure ( states regexp -- new-states )
- '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
- natural-sort ;
+: epsilon-table ( states nfa -- table )
+ [ H{ } clone tuck ] dip
+ '[ _ _ t epsilon-loop ] each ;
-: find-closure ( states transition regexp -- new-states )
- [ find-delta ] 2keep nip find-epsilon-closure ;
+: find-epsilon-closure ( states nfa -- dfa-state )
+ epsilon-table table>condition ;
-: find-start-state ( regexp -- state )
- [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
+: find-closure ( states transition nfa -- new-states )
+ [ find-delta ] keep find-epsilon-closure ;
-: find-transitions ( seq1 regexp -- seq2 )
- nfa-table>> transitions>>
- [ at keys ] curry gather
- eps swap remove ;
+: find-start-state ( nfa -- state )
+ [ start-state>> 1array ] keep find-epsilon-closure ;
-: add-todo-state ( state regexp -- )
- 2dup visited-states>> key? [
- 2drop
- ] [
- [ visited-states>> conjoin ]
- [ new-states>> push ] 2bi
- ] if ;
-
-: new-transitions ( regexp -- )
- dup new-states>> [
- drop
- ] [
- dupd pop dup pick find-transitions rot
- [
- [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
- [ swapd transition make-transition ] dip
- dfa-table>> add-transition
- ] curry with each
- new-transitions
- ] if-empty ;
+: find-transitions ( dfa-state nfa -- next-dfa-state )
+ transitions>>
+ '[ _ at keys [ condition-states ] map concat ] gather
+ [ tagged-epsilon? not ] filter ;
-: states ( hashtable -- array )
- [ keys ]
- [ values [ values concat ] map concat append ] bi ;
+: add-todo-state ( state visited-states new-states -- )
+ 3dup drop key? [ 3drop ] [
+ [ conjoin ] [ push ] bi-curry* bi
+ ] if ;
-: set-final-states ( regexp -- )
- dup
- [ nfa-table>> final-states>> keys ]
- [ dfa-table>> transitions>> states ] bi
- [ intersects? ] with filter
+: add-todo-states ( state/condition visited-states new-states -- )
+ [ condition-states ] 2dip
+ '[ _ _ add-todo-state ] each ;
- swap dfa-table>> final-states>>
- [ conjoin ] curry each ;
+:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
+ new-states [ nfa dfa ] [
+ pop :> state
+ state dfa transitions>> maybe-initialize-key
+ state nfa find-transitions
+ [| trans |
+ state trans nfa find-closure :> new-state
+ new-state visited-states new-states add-todo-states
+ state new-state trans dfa set-transition
+ ] each
+ nfa dfa new-states visited-states new-transitions
+ ] if-empty ;
-: set-initial-state ( regexp -- )
- dup
- [ dfa-table>> ] [ find-start-state ] bi
- [ >>start-state drop ] keep
- 1vector >>new-states drop ;
+: set-final-states ( nfa dfa -- )
+ [
+ [ final-states>> keys ]
+ [ transitions>> keys ] bi*
+ [ intersects? ] with filter
+ unique
+ ] keep (>>final-states) ;
-: set-traversal-flags ( regexp -- )
- dup
- [ nfa-traversal-flags>> ]
- [ dfa-table>> transitions>> keys ] bi
- [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
- >>dfa-traversal-flags drop ;
+: initialize-dfa ( nfa -- dfa )
+ <transition-table>
+ swap find-start-state >>start-state ;
-: construct-dfa ( regexp -- )
- {
- [ set-initial-state ]
- [ new-transitions ]
- [ set-final-states ]
- [ set-traversal-flags ]
- } cleave ;
+: construct-dfa ( nfa -- dfa )
+ dup initialize-dfa
+ dup start-state>> condition-states >vector
+ H{ } clone
+ new-transitions
+ [ set-final-states ] keep ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors regexp.classes math.bits assocs sequences
+arrays sets regexp.dfa math fry regexp.minimize regexp.ast regexp.transition-tables ;
+IN: regexp.disambiguate
+
+TUPLE: parts in out ;
+
+: make-partition ( choices classes -- partition )
+ zip [ first ] partition [ values ] bi@ parts boa ;
+
+: powerset-partition ( classes -- partitions )
+ [ length [ 2^ ] keep ] keep '[
+ _ <bits> _ make-partition
+ ] map rest ;
+
+: partition>class ( parts -- class )
+ [ out>> [ <not-class> ] map ]
+ [ in>> <and-class> ] bi
+ prefix <and-class> ;
+
+: get-transitions ( partition state-transitions -- next-states )
+ [ in>> ] dip '[ _ at ] gather sift ;
+
+: new-transitions ( transitions -- assoc ) ! assoc is class, partition
+ values [ keys ] gather
+ [ tagged-epsilon? not ] filter
+ powerset-partition
+ [ [ partition>class ] keep ] { } map>assoc
+ [ drop ] assoc-filter ;
+
+: preserving-epsilon ( state-transitions quot -- new-state-transitions )
+ [ [ drop tagged-epsilon? ] assoc-filter ] bi
+ assoc-union H{ } assoc-like ; inline
+: disambiguate ( nfa -- nfa )
+ expand-ors [
+ dup new-transitions '[
+ [
+ _ swap '[ _ get-transitions ] assoc-map
+ [ nip empty? not ] assoc-filter
+ ] preserving-epsilon
+ ] assoc-map
+ ] change-transitions ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test regexp.minimize assocs regexp
+accessors regexp.transition-tables regexp.parser
+regexp.classes regexp.negation ;
+IN: regexp.minimize.tests
+
+[ t ] [ 1 2 H{ { { 1 2 } t } } same-partition? ] unit-test
+[ t ] [ 2 1 H{ { { 1 2 } t } } same-partition? ] unit-test
+[ f ] [ 2 3 H{ { { 1 2 } t } } same-partition? ] unit-test
+
+[ H{ { 1 1 } { 2 1 } { 3 3 } { 4 3 } } ]
+[ { { 1 1 } { 1 2 } { 2 2 } { 3 3 } { 3 4 } { 4 4 } } [ t ] H{ } map>assoc partition>classes ] unit-test
+
+[ { { 1 2 } { 3 4 } } ] [ H{ { "elephant" 1 } { "tiger" 3 } } H{ { "elephant" 2 } { "tiger" 4 } } assemble-values ] unit-test
+
+: regexp-states ( string -- n )
+ parse-regexp ast>dfa transitions>> assoc-size ;
+
+[ 3 ] [ "ab|ac" regexp-states ] unit-test
+[ 3 ] [ "a(b|c)" regexp-states ] unit-test
+[ 1 ] [ "((aa*)*)*" regexp-states ] unit-test
+[ 1 ] [ "a|((aa*)*)*" regexp-states ] unit-test
+[ 2 ] [ "ab|((aa*)*)*b" regexp-states ] unit-test
+[ 4 ] [ "ab|cd" regexp-states ] unit-test
+[ 1 ] [ "(?i:[a-z]*|[A-Z]*)" regexp-states ] unit-test
+
+[
+ T{ transition-table
+ { transitions H{
+ { 0 H{ { CHAR: a 1 } { CHAR: b 1 } } }
+ { 1 H{ { CHAR: a 2 } { CHAR: b 2 } } }
+ { 2 H{ { CHAR: c 3 } } }
+ { 3 H{ } }
+ } }
+ { start-state 0 }
+ { final-states H{ { 3 3 } } }
+ }
+] [
+ T{ transition-table
+ { transitions H{
+ { 0 H{ { CHAR: a 1 } { CHAR: b 4 } } }
+ { 1 H{ { CHAR: a 2 } { CHAR: b 5 } } }
+ { 2 H{ { CHAR: c 3 } } }
+ { 3 H{ } }
+ { 4 H{ { CHAR: a 2 } { CHAR: b 5 } } }
+ { 5 H{ { CHAR: c 6 } } }
+ { 6 H{ } }
+ } }
+ { start-state 0 }
+ { final-states H{ { 3 3 } { 6 6 } } }
+ } combine-states
+] unit-test
+
+[ [ ] [ ] while-changes ] must-infer
+
+[ H{ { T{ or-class f { 2 1 } } 3 } { 4 5 } } ]
+[ H{ { 1 3 } { 2 3 } { 4 5 } } combine-state-transitions ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences regexp.transition-tables fry assocs
+accessors locals math sorting arrays sets hashtables regexp.dfa
+combinators.short-circuit regexp.classes ;
+IN: regexp.minimize
+
+: table>state-numbers ( table -- assoc )
+ transitions>> keys <enum> [ swap ] H{ } assoc-map-as ;
+
+: number-states ( table -- newtable )
+ dup table>state-numbers transitions-at ;
+
+: has-conditions? ( assoc -- ? )
+ values [ condition? ] any? ;
+
+: initially-same? ( s1 s2 transition-table -- ? )
+ {
+ [ drop <= ]
+ [ transitions>> '[ _ at keys ] bi@ set= ]
+ [ final-states>> '[ _ key? ] bi@ = ]
+ } 3&& ;
+
+:: initialize-partitions ( transition-table -- partitions )
+ ! Partition table is sorted-array => ?
+ H{ } clone :> out
+ transition-table transitions>> keys :> states
+ states [| s1 |
+ states [| s2 |
+ s1 s2 transition-table initially-same?
+ [ s1 s2 2array out conjoin ] when
+ ] each
+ ] each out ;
+
+: same-partition? ( s1 s2 partitions -- ? )
+ { [ [ 2array natural-sort ] dip key? ] [ drop = ] } 3|| ;
+
+: assemble-values ( assoc1 assoc2 -- values )
+ dup keys '[ _ swap [ at ] curry map ] bi@ zip ;
+
+: stay-same? ( s1 s2 transition partitions -- ? )
+ [ '[ _ transitions>> at ] bi@ assemble-values ] dip
+ '[ _ same-partition? ] assoc-all? ;
+
+: partition-more ( partitions transition-table -- partitions )
+ over '[ drop first2 _ _ stay-same? ] assoc-filter ;
+
+: partition>classes ( partitions -- synonyms ) ! old-state => new-state
+ >alist sort-keys
+ [ drop first2 swap ] assoc-map
+ <reversed>
+ >hashtable ;
+
+:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
+ obj quot call :> new-obj
+ new-obj comp call :> new-key
+ new-key old-key =
+ [ new-obj ]
+ [ new-obj quot comp new-key (while-changes) ]
+ if ; inline recursive
+
+: while-changes ( obj quot pred -- obj' )
+ 3dup nip call (while-changes) ; inline
+
+: (state-classes) ( transition-table -- partition )
+ [ initialize-partitions ] keep
+ '[ _ partition-more ] [ assoc-size ] while-changes ;
+
+: assoc>set ( assoc -- keys-set )
+ [ drop dup ] assoc-map ;
+
+: state-classes ( transition-table -- synonyms )
+ clone [ [ nip has-conditions? ] assoc-partition ] change-transitions
+ [ assoc>set ] [ (state-classes) partition>classes ] bi* assoc-union ;
+
+: canonical-state? ( state transitions state-classes -- ? )
+ '[ dup _ at = ] swap '[ _ at has-conditions? ] bi or ;
+
+: delete-duplicates ( transitions state-classes -- new-transitions )
+ dupd '[ drop _ _ canonical-state? ] assoc-filter ;
+
+: combine-states ( table -- smaller-table )
+ dup state-classes
+ [ transitions-at ] keep
+ '[ _ delete-duplicates ] change-transitions ;
+
+: combine-state-transitions ( hash -- hash )
+ H{ } clone tuck '[
+ _ [ 2array <or-class> ] change-at
+ ] assoc-each [ swap ] assoc-map ;
+
+: combine-transitions ( table -- table )
+ [ [ combine-state-transitions ] assoc-map ] change-transitions ;
+
+: minimize ( table -- minimal-table )
+ clone
+ number-states
+ combine-states
+ combine-transitions
+ expand-ors ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test regexp.negation regexp.transition-tables regexp.classes ;
+IN: regexp.negation.tests
+
+[
+ ! R/ |[^a]|.+/
+ T{ transition-table
+ { transitions H{
+ { 0 H{ { CHAR: a 1 } { T{ not-class f CHAR: a } -1 } } }
+ { 1 H{ { t -1 } } }
+ { -1 H{ { t -1 } } }
+ } }
+ { start-state 0 }
+ { final-states H{ { 0 0 } { -1 -1 } } }
+ }
+] [
+ ! R/ a/
+ T{ transition-table
+ { transitions H{
+ { 0 H{ { CHAR: a 1 } } }
+ { 1 H{ } }
+ } }
+ { start-state 0 }
+ { final-states H{ { 1 1 } } }
+ } negate-table
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.nfa regexp.disambiguate kernel sequences
+assocs regexp.classes hashtables accessors fry vectors
+regexp.ast regexp.transition-tables regexp.minimize
+regexp.dfa namespaces ;
+IN: regexp.negation
+
+CONSTANT: fail-state -1
+
+: add-default-transition ( state's-transitions -- new-state's-transitions )
+ clone dup
+ [ [ fail-state ] dip keys [ <not-class> ] map <and-class> ] keep set-at ;
+
+: fail-state-recurses ( transitions -- new-transitions )
+ clone dup
+ [ fail-state t associate fail-state ] dip set-at ;
+
+: add-fail-state ( transitions -- new-transitions )
+ [ add-default-transition ] assoc-map
+ fail-state-recurses ;
+
+: inverse-final-states ( transition-table -- final-states )
+ [ transitions>> assoc>set ] [ final-states>> ] bi assoc-diff ;
+
+: negate-table ( transition-table -- transition-table )
+ clone
+ [ add-fail-state ] change-transitions
+ dup inverse-final-states >>final-states ;
+
+: renumber-states ( transition-table -- transition-table )
+ dup transitions>> keys [ next-state ] H{ } map>assoc
+ transitions-at ;
+
+: box-transitions ( transition-table -- transition-table )
+ [ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
+
+: unify-final-state ( transition-table -- transition-table )
+ dup [ final-states>> keys ] keep
+ '[ -2 epsilon _ set-transition ] each
+ H{ { -2 -2 } } >>final-states ;
+
+: adjoin-dfa ( transition-table -- start end )
+ unify-final-state renumber-states box-transitions
+ [ start-state>> ]
+ [ final-states>> keys first ]
+ [ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
+
+: ast>dfa ( parse-tree -- minimal-dfa )
+ construct-nfa disambiguate construct-dfa minimize ;
+
+M: negation nfa-node ( node -- start end )
+ term>> ast>dfa negate-table adjoin-dfa ;
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs grouping kernel regexp.backend
-locals math namespaces regexp.parser sequences fry quotations
-math.order math.ranges vectors unicode.categories regexp.utils
-regexp.transition-tables words sets regexp.classes unicode.case.private ;
+USING: accessors arrays assocs grouping kernel locals math namespaces
+sequences fry quotations math.order math.ranges vectors
+unicode.categories regexp.transition-tables words sets hashtables
+combinators.short-circuit unicode.case unicode.case.private regexp.ast
+regexp.classes ;
+IN: regexp.nfa
+
! This uses unicode.case.private for ch>upper and ch>lower
! but case-insensitive matching should be done by case-folding everything
! before processing starts
-IN: regexp.nfa
-ERROR: feature-is-broken feature ;
-
-SYMBOL: negation-mode
-: negated? ( -- ? ) negation-mode get 0 or odd? ;
-
-SINGLETON: eps
-
-MIXIN: traversal-flag
-SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
-SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
-SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
-SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
-SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
-SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
-SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
-SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
-SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
-
-: options ( -- obj ) current-regexp get options>> ;
-
-: option? ( obj -- ? ) options key? ;
-
-: option-on ( obj -- ) options conjoin ;
-
-: option-off ( obj -- ) options delete-at ;
-
-: next-state ( regexp -- state )
- [ state>> ] [ [ 1+ ] change-state drop ] bi ;
-
-: set-start-state ( regexp -- )
- dup stack>> [
- drop
- ] [
- [ nfa-table>> ] [ pop first ] bi* >>start-state drop
- ] if-empty ;
-
-GENERIC: nfa-node ( node -- )
-
-:: add-simple-entry ( obj class -- )
- [let* | regexp [ current-regexp get ]
- s0 [ regexp next-state ]
- s1 [ regexp next-state ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ] |
- negated? [
- s0 f obj class make-transition table add-transition
- s0 s1 <default-transition> table add-transition
- ] [
- s0 s1 obj class make-transition table add-transition
- ] if
- s0 s1 2array stack push
- t s1 table final-states>> set-at ] ;
-
-: add-traversal-flag ( flag -- )
- stack peek second
- current-regexp get nfa-traversal-flags>> push-at ;
-
-:: concatenate-nodes ( -- )
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ]
- s2 [ stack peek first ]
- s3 [ stack pop second ]
- s0 [ stack peek first ]
- s1 [ stack pop second ] |
- s1 s2 eps <literal-transition> table add-transition
- s1 table final-states>> delete-at
- s0 s3 2array stack push ] ;
-
-:: alternate-nodes ( -- )
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ]
- s2 [ stack peek first ]
- s3 [ stack pop second ]
- s0 [ stack peek first ]
- s1 [ stack pop second ]
- s4 [ regexp next-state ]
- s5 [ regexp next-state ] |
- s4 s0 eps <literal-transition> table add-transition
- s4 s2 eps <literal-transition> table add-transition
- s1 s5 eps <literal-transition> table add-transition
- s3 s5 eps <literal-transition> table add-transition
- s1 table final-states>> delete-at
- s3 table final-states>> delete-at
- t s5 table final-states>> set-at
- s4 s5 2array stack push ] ;
-
-M: kleene-star nfa-node ( node -- )
- term>> nfa-node
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- s0 [ stack peek first ]
- s1 [ stack pop second ]
- s2 [ regexp next-state ]
- s3 [ regexp next-state ]
- table [ regexp nfa-table>> ] |
- s1 table final-states>> delete-at
- t s3 table final-states>> set-at
- s1 s0 eps <literal-transition> table add-transition
- s2 s0 eps <literal-transition> table add-transition
- s2 s3 eps <literal-transition> table add-transition
- s1 s3 eps <literal-transition> table add-transition
- s2 s3 2array stack push ] ;
-
-M: concatenation nfa-node ( node -- )
- seq>>
- reversed-regexp option? [ <reversed> ] when
- [ [ nfa-node ] each ]
- [ length 1- [ concatenate-nodes ] times ] bi ;
-
-M: alternation nfa-node ( node -- )
- seq>>
- [ [ nfa-node ] each ]
- [ length 1- [ alternate-nodes ] times ] bi ;
-
-M: constant nfa-node ( node -- )
- case-insensitive option? [
- dup char>> [ ch>lower ] [ ch>upper ] bi
- 2dup = [
- 2drop
- char>> literal-transition add-simple-entry
- ] [
- [ literal-transition add-simple-entry ] bi@
- alternate-nodes drop
- ] if
- ] [
- char>> literal-transition add-simple-entry
- ] if ;
+SYMBOL: option-stack
+
+SYMBOL: state
+
+: next-state ( -- state )
+ state [ get ] [ inc ] bi ;
+
+SYMBOL: nfa-table
+
+: set-each ( keys value hashtable -- )
+ '[ _ swap _ set-at ] each ;
+
+: options>hash ( options -- hashtable )
+ H{ } clone [
+ [ [ on>> t ] dip set-each ]
+ [ [ off>> f ] dip set-each ] 2bi
+ ] keep ;
+
+: using-options ( options quot -- )
+ [ options>hash option-stack [ ?push ] change ] dip
+ call option-stack get pop* ; inline
+
+: option? ( obj -- ? )
+ option-stack get assoc-stack ;
+
+GENERIC: nfa-node ( node -- start-state end-state )
+
+: add-simple-entry ( obj -- start-state end-state )
+ [ next-state next-state 2dup ] dip
+ nfa-table get add-transition ;
+
+: epsilon-transition ( source target -- )
+ epsilon nfa-table get add-transition ;
-M: epsilon nfa-node ( node -- )
- drop eps literal-transition add-simple-entry ;
+M:: star nfa-node ( node -- start end )
+ node term>> nfa-node :> s1 :> s0
+ next-state :> s2
+ next-state :> s3
+ s1 s0 epsilon-transition
+ s2 s0 epsilon-transition
+ s2 s3 epsilon-transition
+ s1 s3 epsilon-transition
+ s2 s3 ;
-M: word nfa-node ( node -- ) class-transition add-simple-entry ;
+GENERIC: modify-epsilon ( tag -- newtag )
+! Potential off-by-one errors when lookaround nested in lookbehind
-M: any-char nfa-node ( node -- )
- [ dotall option? ] dip any-char-no-nl ?
- class-transition add-simple-entry ;
+M: object modify-epsilon ;
-! M: beginning-of-text nfa-node ( node -- ) ;
+M: $ modify-epsilon
+ multiline option? [ drop end-of-input ] unless ;
-M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
+M: ^ modify-epsilon
+ multiline option? [ drop beginning-of-input ] unless ;
-M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
+M: tagged-epsilon nfa-node
+ clone [ modify-epsilon ] change-tag add-simple-entry ;
-: choose-letter-class ( node -- node' )
- case-insensitive option? Letter-class rot ? ;
+M: concatenation nfa-node ( node -- start end )
+ [ first>> ] [ second>> ] bi
+ reversed-regexp option? [ swap ] when
+ [ nfa-node ] bi@
+ [ epsilon-transition ] dip ;
-M: letter-class nfa-node ( node -- )
- choose-letter-class class-transition add-simple-entry ;
+:: alternate-nodes ( s0 s1 s2 s3 -- start end )
+ next-state :> s4
+ next-state :> s5
+ s4 s0 epsilon-transition
+ s4 s2 epsilon-transition
+ s1 s5 epsilon-transition
+ s3 s5 epsilon-transition
+ s4 s5 ;
-M: LETTER-class nfa-node ( node -- )
- choose-letter-class class-transition add-simple-entry ;
+M: alternation nfa-node ( node -- start end )
+ [ first>> ] [ second>> ] bi
+ [ nfa-node ] bi@
+ alternate-nodes ;
-M: character-class-range nfa-node ( node -- )
+GENERIC: modify-class ( char-class -- char-class' )
+
+M: object modify-class ;
+
+M: integer modify-class
+ case-insensitive option? [
+ dup Letter? [
+ [ ch>lower ] [ ch>upper ] bi 2array <or-class>
+ ] when
+ ] when ;
+
+M: integer nfa-node ( node -- start end )
+ modify-class add-simple-entry ;
+
+M: primitive-class modify-class
+ class>> modify-class <primitive-class> ;
+
+M: or-class modify-class
+ seq>> [ modify-class ] map <or-class> ;
+
+M: not-class modify-class
+ class>> modify-class <not-class> ;
+
+M: any-char modify-class
+ drop dotall option? t any-char-no-nl ? ;
+
+: modify-letter-class ( class -- newclass )
+ case-insensitive option? [ drop Letter-class ] when ;
+M: letter-class modify-class modify-letter-class ;
+M: LETTER-class modify-class modify-letter-class ;
+
+: cased-range? ( range -- ? )
+ [ from>> ] [ to>> ] bi {
+ [ [ letter? ] bi@ and ]
+ [ [ LETTER? ] bi@ and ]
+ } 2|| ;
+
+M: range modify-class
case-insensitive option? [
- ! This should be implemented for Unicode by case-folding
- ! the input and all strings in the regexp.
- dup [ from>> ] [ to>> ] bi
- 2dup [ Letter? ] bi@ and [
- rot drop
- [ [ ch>lower ] bi@ character-class-range boa ]
- [ [ ch>upper ] bi@ character-class-range boa ] 2bi
- [ class-transition add-simple-entry ] bi@
- alternate-nodes
- ] [
- 2drop
- class-transition add-simple-entry
- ] if
- ] [
- class-transition add-simple-entry
- ] if ;
-
-M: capture-group nfa-node ( node -- )
- "capture-groups" feature-is-broken
- eps literal-transition add-simple-entry
- capture-group-on add-traversal-flag
- term>> nfa-node
- eps literal-transition add-simple-entry
- capture-group-off add-traversal-flag
- 2 [ concatenate-nodes ] times ;
-
-! xyzzy
-M: non-capture-group nfa-node ( node -- )
- term>> nfa-node ;
-
-M: reluctant-kleene-star nfa-node ( node -- )
- term>> <kleene-star> nfa-node ;
-
-M: negation nfa-node ( node -- )
- negation-mode inc
- term>> nfa-node
- negation-mode dec ;
-
-M: lookahead nfa-node ( node -- )
- "lookahead" feature-is-broken
- eps literal-transition add-simple-entry
- lookahead-on add-traversal-flag
- term>> nfa-node
- eps literal-transition add-simple-entry
- lookahead-off add-traversal-flag
- 2 [ concatenate-nodes ] times ;
-
-M: lookbehind nfa-node ( node -- )
- "lookbehind" feature-is-broken
- eps literal-transition add-simple-entry
- lookbehind-on add-traversal-flag
- term>> nfa-node
- eps literal-transition add-simple-entry
- lookbehind-off add-traversal-flag
- 2 [ concatenate-nodes ] times ;
-
-M: option nfa-node ( node -- )
- [ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if
- eps literal-transition add-simple-entry ;
-
-: construct-nfa ( regexp -- )
+ dup cased-range? [
+ [ from>> ] [ to>> ] bi
+ [ [ ch>lower ] bi@ <range> ]
+ [ [ ch>upper ] bi@ <range> ] 2bi
+ 2array <or-class>
+ ] when
+ ] when ;
+
+M: class nfa-node
+ modify-class add-simple-entry ;
+
+M: with-options nfa-node ( node -- start end )
+ dup options>> [ tree>> nfa-node ] using-options ;
+
+: construct-nfa ( ast -- nfa-table )
[
- reset-regexp
- negation-mode off
- [ current-regexp set ]
- [ parse-tree>> nfa-node ]
- [ set-start-state ] tri
+ 0 state set
+ <transition-table> nfa-table set
+ nfa-node
+ nfa-table get
+ swap dup associate >>final-states
+ swap >>start-state
] with-scope ;
-USING: kernel tools.test regexp.backend regexp ;
-IN: regexp.parser
+USING: kernel tools.test regexp.parser fry sequences ;
+IN: regexp.parser.tests
-: test-regexp ( string -- )
- default-regexp parse-regexp ;
+: regexp-parses ( string -- )
+ [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
-! [ "(" ] [ unmatched-parentheses? ] must-fail-with
+: regexp-fails ( string -- )
+ '[ _ parse-regexp ] must-fail ;
-[ ] [ "a|b" test-regexp ] unit-test
-[ ] [ "a.b" test-regexp ] unit-test
-[ ] [ "a|b|c" test-regexp ] unit-test
-[ ] [ "abc|b" test-regexp ] unit-test
-[ ] [ "a|bcd" test-regexp ] unit-test
-[ ] [ "a|(b)" test-regexp ] unit-test
-[ ] [ "(a)|b" test-regexp ] unit-test
-[ ] [ "(a|b)" test-regexp ] unit-test
-[ ] [ "((a)|(b))" test-regexp ] unit-test
+{
+ "a|b" "a.b" "a|b|c" "abc|b" "a|bcd" "a|(b)" "(?-i:a)" "||"
+ "(a)|b" "(a|b)" "((a)|(b))" "(?:a)" "(?i:a)" "|b" "b|"
+ "[abc]" "[a-c]" "[^a-c]" "[^]]" "[]a]" "[[]" "[]-a]" "[a-]" "[-]"
+ "[--a]" "foo*" "(foo)*" "(a|b)|c" "(foo){2,3}" "(foo){2,}"
+ "(foo){2}" "{2,3}" "{," "{,}" "}" "foo}" "[^]-a]" "[^-]a]"
+ "[a-]" "[^a-]" "[^a-]" "a{,2}" "(?#foobar)"
+ "\\p{Space}" "\\t" "\\[" "[\\]]" "\\P{Space}"
+ "\\ueeee" "\\0333" "\\xff" "\\\\" "\\w"
+} [ regexp-parses ] each
-[ ] [ "(?:a)" test-regexp ] unit-test
-[ ] [ "(?i:a)" test-regexp ] unit-test
-[ ] [ "(?-i:a)" test-regexp ] unit-test
-[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
-[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
-
-[ ] [ "(?=a)" test-regexp ] unit-test
-
-[ ] [ "[abc]" test-regexp ] unit-test
-[ ] [ "[a-c]" test-regexp ] unit-test
-[ ] [ "[^a-c]" test-regexp ] unit-test
-[ "[^]" test-regexp ] must-fail
-
-[ ] [ "|b" test-regexp ] unit-test
-[ ] [ "b|" test-regexp ] unit-test
-[ ] [ "||" test-regexp ] unit-test
+{
+ "[^]" "[]" "a{foo}" "a{,}" "a{}" "(?)" "\\p{foo}" "\\P{foo}"
+ "\\ueeeg" "\\0339" "\\xfg"
+} [ regexp-fails ] each
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators io io.streams.string
-kernel math math.parser namespaces sets
-quotations sequences splitting vectors math.order
-strings regexp.backend regexp.utils
-unicode.case unicode.categories words locals regexp.classes ;
+USING: peg.ebnf kernel math.parser sequences assocs arrays fry math
+combinators regexp.classes strings splitting peg locals accessors
+regexp.ast ;
IN: regexp.parser
-FROM: math.ranges => [a,b] ;
-
-TUPLE: concatenation seq ; INSTANCE: concatenation node
-TUPLE: alternation seq ; INSTANCE: alternation node
-TUPLE: kleene-star term ; INSTANCE: kleene-star node
-
-! !!!!!!!!
-TUPLE: possessive-question term ; INSTANCE: possessive-question node
-TUPLE: possessive-kleene-star term ; INSTANCE: possessive-kleene-star node
-
-! !!!!!!!!
-TUPLE: reluctant-question term ; INSTANCE: reluctant-question node
-TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
-
-TUPLE: negation term ; INSTANCE: negation node
-TUPLE: constant char ; INSTANCE: constant node
-TUPLE: range from to ; INSTANCE: range node
-
-MIXIN: parentheses-group
-TUPLE: lookahead term ; INSTANCE: lookahead node
-INSTANCE: lookahead parentheses-group
-TUPLE: lookbehind term ; INSTANCE: lookbehind node
-INSTANCE: lookbehind parentheses-group
-TUPLE: capture-group term ; INSTANCE: capture-group node
-INSTANCE: capture-group parentheses-group
-TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
-INSTANCE: non-capture-group parentheses-group
-TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
-INSTANCE: independent-group parentheses-group
-TUPLE: comment-group term ; INSTANCE: comment-group node
-INSTANCE: comment-group parentheses-group
-
-SINGLETON: epsilon INSTANCE: epsilon node
-
-TUPLE: option option on? ; INSTANCE: option node
-
-SINGLETONS: unix-lines dotall multiline comments case-insensitive
-unicode-case reversed-regexp ;
-
-SINGLETONS: beginning-of-character-class end-of-character-class
-left-parenthesis pipe caret dash ;
-
-: push1 ( obj -- ) input-stream get stream>> push ;
-: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
-: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
-: drop1 ( -- ) read1 drop ;
-
-: stack ( -- obj ) current-regexp get stack>> ;
-: change-whole-stack ( quot -- )
- current-regexp get
- [ stack>> swap call ] keep (>>stack) ; inline
-: push-stack ( obj -- ) stack push ;
-: pop-stack ( -- obj ) stack pop ;
-: cut-out ( vector n -- vector' vector ) cut rest ;
-ERROR: cut-stack-error ;
-: cut-stack ( obj vector -- vector' vector )
- [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
-
-: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
-: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
-: <possessive-question> ( obj -- kleene ) possessive-question boa ;
-: <reluctant-question> ( obj -- kleene ) reluctant-question boa ;
-
-: <negation> ( obj -- negation ) negation boa ;
-: <concatenation> ( seq -- concatenation )
- >vector [ epsilon ] [ concatenation boa ] if-empty ;
-: <alternation> ( seq -- alternation ) >vector alternation boa ;
-: <capture-group> ( obj -- capture-group ) capture-group boa ;
-: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
-: <constant> ( obj -- constant ) constant boa ;
-
-: first|concatenation ( seq -- first/concatenation )
- dup length 1 = [ first ] [ <concatenation> ] if ;
-
-: first|alternation ( seq -- first/alternation )
- dup length 1 = [ first ] [ <alternation> ] if ;
-
-: <character-class-range> ( from to -- obj )
- 2dup <
- [ character-class-range boa ] [ 2drop unmatchable-class ] if ;
-
-ERROR: unmatched-parentheses ;
-
-ERROR: unknown-regexp-option option ;
+: allowed-char? ( ch -- ? )
+ ".()|[*+?$^" member? not ;
-: ch>option ( ch -- singleton )
+ERROR: bad-number ;
+
+: ensure-number ( n -- n )
+ [ bad-number ] unless* ;
+
+:: at-error ( key assoc quot: ( key -- replacement ) -- value )
+ key assoc at* [ drop key quot call ] unless ; inline
+
+ERROR: bad-class name ;
+
+: name>class ( name -- class )
+ {
+ { "Lower" letter-class }
+ { "Upper" LETTER-class }
+ { "Alpha" Letter-class }
+ { "ASCII" ascii-class }
+ { "Digit" digit-class }
+ { "Alnum" alpha-class }
+ { "Punct" punctuation-class }
+ { "Graph" java-printable-class }
+ { "Print" java-printable-class }
+ { "Blank" non-newline-blank-class }
+ { "Cntrl" control-character-class }
+ { "XDigit" hex-digit-class }
+ { "Space" java-blank-class }
+ ! TODO: unicode-character-class
+ } [ bad-class ] at-error ;
+
+: lookup-escape ( char -- ast )
{
- { CHAR: i [ case-insensitive ] }
- { CHAR: d [ unix-lines ] }
- { CHAR: m [ multiline ] }
- { CHAR: n [ multiline ] }
- { CHAR: r [ reversed-regexp ] }
- { CHAR: s [ dotall ] }
- { CHAR: u [ unicode-case ] }
- { CHAR: x [ comments ] }
- [ unknown-regexp-option ]
+ { CHAR: t [ CHAR: \t ] }
+ { CHAR: n [ CHAR: \n ] }
+ { CHAR: r [ CHAR: \r ] }
+ { CHAR: f [ HEX: c ] }
+ { CHAR: a [ HEX: 7 ] }
+ { CHAR: e [ HEX: 1b ] }
+ { CHAR: \\ [ CHAR: \\ ] }
+
+ { CHAR: w [ c-identifier-class <primitive-class> ] }
+ { CHAR: W [ c-identifier-class <primitive-class> <not-class> ] }
+ { CHAR: s [ java-blank-class <primitive-class> ] }
+ { CHAR: S [ java-blank-class <primitive-class> <not-class> ] }
+ { CHAR: d [ digit-class <primitive-class> ] }
+ { CHAR: D [ digit-class <primitive-class> <not-class> ] }
+
+ { CHAR: z [ end-of-input <tagged-epsilon> ] }
+ { CHAR: Z [ end-of-file <tagged-epsilon> ] }
+ { CHAR: A [ beginning-of-input <tagged-epsilon> ] }
+ { CHAR: b [ word-break <tagged-epsilon> ] }
+ { CHAR: B [ word-break <not-class> <tagged-epsilon> ] }
+ [ ]
} case ;
+: options-assoc ( -- assoc )
+ H{
+ { CHAR: i case-insensitive }
+ { CHAR: d unix-lines }
+ { CHAR: m multiline }
+ { CHAR: n multiline }
+ { CHAR: r reversed-regexp }
+ { CHAR: s dotall }
+ { CHAR: u unicode-case }
+ { CHAR: x comments }
+ } ;
+
+: ch>option ( ch -- singleton )
+ options-assoc at ;
+
: option>ch ( option -- string )
- {
- { case-insensitive [ CHAR: i ] }
- { multiline [ CHAR: m ] }
- { reversed-regexp [ CHAR: r ] }
- { dotall [ CHAR: s ] }
- [ unknown-regexp-option ]
- } case ;
+ options-assoc value-at ;
-: toggle-option ( ch ? -- )
- [ ch>option ] dip option boa push-stack ;
-
-: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
-
-: parse-options ( string -- )
- "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
-
-ERROR: bad-special-group string ;
-
-DEFER: (parse-regexp)
-: nested-parse-regexp ( token ? -- )
- [ push-stack (parse-regexp) pop-stack ] dip
- [ <negation> ] when pop-stack new swap >>term push-stack ;
-
-! non-capturing groups
-: (parse-special-group) ( -- )
- read1 {
- { [ dup CHAR: # = ] ! comment
- [ drop comment-group f nested-parse-regexp pop-stack drop ] }
- { [ dup CHAR: : = ]
- [ drop non-capture-group f nested-parse-regexp ] }
- { [ dup CHAR: = = ]
- [ drop lookahead f nested-parse-regexp ] }
- { [ dup CHAR: ! = ]
- [ drop lookahead t nested-parse-regexp ] }
- { [ dup CHAR: > = ]
- [ drop non-capture-group f nested-parse-regexp ] }
- { [ dup CHAR: < = peek1 CHAR: = = and ]
- [ drop drop1 lookbehind f nested-parse-regexp ] }
- { [ dup CHAR: < = peek1 CHAR: ! = and ]
- [ drop drop1 lookbehind t nested-parse-regexp ] }
- [
- ":)" read-until
- [ swap prefix ] dip
- {
- { CHAR: : [ parse-options non-capture-group f nested-parse-regexp ] }
- { CHAR: ) [ parse-options ] }
- [ drop bad-special-group ]
- } case
- ]
- } cond ;
-
-: handle-left-parenthesis ( -- )
- peek1 CHAR: ? =
- [ drop1 (parse-special-group) ]
- [ capture-group f nested-parse-regexp ] if ;
-
-: handle-dot ( -- ) any-char push-stack ;
-: handle-pipe ( -- ) pipe push-stack ;
-: (handle-star) ( obj -- kleene-star )
- peek1 {
- { CHAR: + [ drop1 <possessive-kleene-star> ] }
- { CHAR: ? [ drop1 <reluctant-kleene-star> ] }
- [ drop <kleene-star> ]
- } case ;
-: handle-star ( -- ) stack pop (handle-star) push-stack ;
-: handle-question ( -- )
- stack pop peek1 {
- { CHAR: + [ drop1 <possessive-question> ] }
- { CHAR: ? [ drop1 <reluctant-question> ] }
- [ drop epsilon 2array <alternation> ]
- } case push-stack ;
-: handle-plus ( -- )
- stack pop dup (handle-star)
- 2array <concatenation> push-stack ;
-
-ERROR: unmatched-brace ;
-: parse-repetition ( -- start finish ? )
- "}" read-until [ unmatched-brace ] unless
- [ "," split1 [ string>number ] bi@ ]
- [ CHAR: , swap index >boolean ] bi ;
-
-: replicate/concatenate ( n obj -- obj' )
- over zero? [ 2drop epsilon ]
- [ <repetition> first|concatenation ] if ;
-
-: exactly-n ( n -- )
- stack pop replicate/concatenate push-stack ;
-
-: at-least-n ( n -- )
- stack pop
- [ replicate/concatenate ] keep
- <kleene-star> 2array <concatenation> push-stack ;
-
-: at-most-n ( n -- )
- 1+
- stack pop
- [ replicate/concatenate ] curry map <alternation> push-stack ;
-
-: from-m-to-n ( m n -- )
- [a,b]
- stack pop
- [ replicate/concatenate ] curry map
- <alternation> push-stack ;
-
-ERROR: invalid-range a b ;
-
-: handle-left-brace ( -- )
- parse-repetition
- [ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip
- [
- 2dup and [ from-m-to-n ]
- [ [ nip at-most-n ] [ at-least-n ] if* ] if
- ] [ drop 0 max exactly-n ] if ;
-
-: handle-front-anchor ( -- ) beginning-of-line push-stack ;
-: handle-back-anchor ( -- ) end-of-line push-stack ;
-
-ERROR: bad-character-class obj ;
-ERROR: expected-posix-class ;
-
-: parse-posix-class ( -- obj )
- read1 CHAR: { = [ expected-posix-class ] unless
- "}" read-until [ bad-character-class ] unless
- {
- { "Lower" [ letter-class ] }
- { "Upper" [ LETTER-class ] }
- { "Alpha" [ Letter-class ] }
- { "ASCII" [ ascii-class ] }
- { "Digit" [ digit-class ] }
- { "Alnum" [ alpha-class ] }
- { "Punct" [ punctuation-class ] }
- { "Graph" [ java-printable-class ] }
- { "Print" [ java-printable-class ] }
- { "Blank" [ non-newline-blank-class ] }
- { "Cntrl" [ control-character-class ] }
- { "XDigit" [ hex-digit-class ] }
- { "Space" [ java-blank-class ] }
- ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
- [ bad-character-class ]
- } case ;
+: parse-options ( on off -- options )
+ [ [ ch>option ] { } map-as ] bi@ <options> ;
-: parse-octal ( -- n ) 3 read oct> check-octal ;
-: parse-short-hex ( -- n ) 2 read hex> check-hex ;
-: parse-long-hex ( -- n ) 6 read hex> check-hex ;
-: parse-control-character ( -- n ) read1 ;
+: string>options ( string -- options )
+ "-" split1 parse-options ;
+
+: options>string ( options -- string )
+ [ on>> ] [ off>> ] bi
+ [ [ option>ch ] map ] bi@
+ [ "-" glue ] unless-empty
+ "" like ;
-ERROR: bad-escaped-literals seq ;
+! TODO: add syntax for various parenthized things,
+! add greedy and nongreedy forms of matching
+! (once it's all implemented)
-: parse-til-E ( -- obj )
- "\\E" read-until [ bad-escaped-literals ] unless ;
-
-:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj )
- parse-til-E
- drop1
- [ epsilon ] [
- quot call [ <constant> ] V{ } map-as
- first|concatenation
- ] if-empty ; inline
+EBNF: parse-regexp
-: parse-escaped-literals ( -- obj )
- [ ] (parse-escaped-literals) ;
+CharacterInBracket = !("}") Character
-: lower-case-literals ( -- obj )
- [ >lower ] (parse-escaped-literals) ;
+QuotedCharacter = !("\\E") .
-: upper-case-literals ( -- obj )
- [ >upper ] (parse-escaped-literals) ;
+Escape = "p{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> ]]
+ | "P{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> <negation> ]]
+ | "Q" QuotedCharacter*:s "\\E" => [[ s <concatenation> ]]
+ | "u" Character:a Character:b Character:c Character:d
+ => [[ { a b c d } hex> ensure-number ]]
+ | "x" Character:a Character:b
+ => [[ { a b } hex> ensure-number ]]
+ | "0" Character:a Character:b Character:c
+ => [[ { a b c } oct> ensure-number ]]
+ | . => [[ lookup-escape ]]
-: parse-escaped ( -- obj )
- read1
- {
- { CHAR: t [ CHAR: \t <constant> ] }
- { CHAR: n [ CHAR: \n <constant> ] }
- { CHAR: r [ CHAR: \r <constant> ] }
- { CHAR: f [ HEX: c <constant> ] }
- { CHAR: a [ HEX: 7 <constant> ] }
- { CHAR: e [ HEX: 1b <constant> ] }
-
- { CHAR: w [ c-identifier-class ] }
- { CHAR: W [ c-identifier-class <negation> ] }
- { CHAR: s [ java-blank-class ] }
- { CHAR: S [ java-blank-class <negation> ] }
- { CHAR: d [ digit-class ] }
- { CHAR: D [ digit-class <negation> ] }
-
- { CHAR: p [ parse-posix-class ] }
- { CHAR: P [ parse-posix-class <negation> ] }
- { CHAR: x [ parse-short-hex <constant> ] }
- { CHAR: u [ parse-long-hex <constant> ] }
- { CHAR: 0 [ parse-octal <constant> ] }
- { CHAR: c [ parse-control-character ] }
-
- { CHAR: Q [ parse-escaped-literals ] }
-
- ! { CHAR: b [ word-boundary-class ] }
- ! { CHAR: B [ word-boundary-class <negation> ] }
- ! { CHAR: A [ handle-beginning-of-input ] }
- ! { CHAR: z [ handle-end-of-input ] }
-
- ! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator
-
- ! m//g mode
- ! { CHAR: G [ end of previous match ] }
-
- ! Group capture
- ! { CHAR: 1 [ CHAR: 1 <constant> ] }
- ! { CHAR: 2 [ CHAR: 2 <constant> ] }
- ! { CHAR: 3 [ CHAR: 3 <constant> ] }
- ! { CHAR: 4 [ CHAR: 4 <constant> ] }
- ! { CHAR: 5 [ CHAR: 5 <constant> ] }
- ! { CHAR: 6 [ CHAR: 6 <constant> ] }
- ! { CHAR: 7 [ CHAR: 7 <constant> ] }
- ! { CHAR: 8 [ CHAR: 8 <constant> ] }
- ! { CHAR: 9 [ CHAR: 9 <constant> ] }
-
- ! Perl extensions
- ! can't do \l and \u because \u is already a 4-hex
- { CHAR: L [ lower-case-literals ] }
- { CHAR: U [ upper-case-literals ] }
-
- [ <constant> ]
- } case ;
+EscapeSequence = "\\" Escape:e => [[ e ]]
-: handle-escape ( -- ) parse-escaped push-stack ;
-
-: handle-dash ( vector -- vector' )
- H{ { dash CHAR: - } } substitute ;
-
-: character-class>alternation ( seq -- alternation )
- [ dup number? [ <constant> ] when ] map first|alternation ;
-
-: handle-caret ( vector -- vector' )
- dup [ length 2 >= ] [ first caret eq? ] bi and [
- rest-slice character-class>alternation <negation>
- ] [
- character-class>alternation
- ] if ;
-
-: make-character-class ( -- character-class )
- [ beginning-of-character-class swap cut-stack ] change-whole-stack
- handle-dash handle-caret ;
-
-: apply-dash ( -- )
- stack [ pop3 nip <character-class-range> ] keep push ;
-
-: apply-dash? ( -- ? )
- stack dup length 3 >=
- [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
-
-ERROR: empty-negated-character-class ;
-DEFER: handle-left-bracket
-: (parse-character-class) ( -- )
- read1 [ empty-negated-character-class ] unless* {
- { CHAR: [ [ handle-left-bracket t ] }
- { CHAR: ] [ make-character-class push-stack f ] }
- { CHAR: - [ dash push-stack t ] }
- { CHAR: \ [ parse-escaped push-stack t ] }
- [ push-stack apply-dash? [ apply-dash ] when t ]
- } case
- [ (parse-character-class) ] when ;
-
-: push-constant ( ch -- ) <constant> push-stack ;
-
-: parse-character-class-second ( -- )
- read1 {
- { CHAR: [ [ CHAR: [ push-constant ] }
- { CHAR: ] [ CHAR: ] push-constant ] }
- { CHAR: - [ CHAR: - push-constant ] }
- [ push1 ]
- } case ;
+Character = EscapeSequence
+ | "$" => [[ $ <tagged-epsilon> ]]
+ | "^" => [[ ^ <tagged-epsilon> ]]
+ | . ?[ allowed-char? ]?
-: parse-character-class-first ( -- )
- read1 {
- { CHAR: ^ [ caret push-stack parse-character-class-second ] }
- { CHAR: [ [ CHAR: [ push-constant ] }
- { CHAR: ] [ CHAR: ] push-constant ] }
- { CHAR: - [ CHAR: - push-constant ] }
- [ push1 ]
- } case ;
+AnyRangeCharacter = EscapeSequence | .
-: handle-left-bracket ( -- )
- beginning-of-character-class push-stack
- parse-character-class-first (parse-character-class) ;
+RangeCharacter = !("]") AnyRangeCharacter
-: finish-regexp-parse ( stack -- obj )
- { pipe } split
- [ first|concatenation ] map first|alternation ;
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
+ | RangeCharacter
-: handle-right-parenthesis ( -- )
- stack dup [ parentheses-group "members" word-prop member? ] find-last
- -rot cut rest
- [ [ push ] keep current-regexp get (>>stack) ]
- [ finish-regexp-parse push-stack ] bi* ;
+StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
+ | AnyRangeCharacter
-: parse-regexp-token ( token -- ? )
- {
- { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
- { CHAR: ) [ handle-right-parenthesis f ] }
- { CHAR: . [ handle-dot t ] }
- { CHAR: | [ handle-pipe t ] }
- { CHAR: ? [ handle-question t ] }
- { CHAR: * [ handle-star t ] }
- { CHAR: + [ handle-plus t ] }
- { CHAR: { [ handle-left-brace t ] }
- { CHAR: [ [ handle-left-bracket t ] }
- { CHAR: \ [ handle-escape t ] }
- [
- dup CHAR: $ = peek1 f = and
- [ drop handle-back-anchor f ]
- [ push-constant t ] if
- ]
- } case ;
+Ranges = StartRange:s Range*:r => [[ r s prefix ]]
+
+CharClass = "^"?:n Ranges:e => [[ e n char-class ]]
+
+Options = [idmsux]*
+
+Parenthized = "?:" Alternation:a => [[ a ]]
+ | "?" Options:on "-"? Options:off ":" Alternation:a
+ => [[ a on off parse-options <with-options> ]]
+ | "?#" [^)]* => [[ f ]]
+ | "?~" Alternation:a => [[ a <negation> ]]
+ | "?=" Alternation:a => [[ a <lookahead> <tagged-epsilon> ]]
+ | "?!" Alternation:a => [[ a <lookahead> <not-class> <tagged-epsilon> ]]
+ | "?<=" Alternation:a => [[ a <lookbehind> <tagged-epsilon> ]]
+ | "?<!" Alternation:a => [[ a <lookbehind> <not-class> <tagged-epsilon> ]]
+ | Alternation
+
+Element = "(" Parenthized:p ")" => [[ p ]]
+ | "[" CharClass:r "]" => [[ r ]]
+ | ".":d => [[ any-char <primitive-class> ]]
+ | Character
+
+Number = (!(","|"}").)* => [[ string>number ensure-number ]]
+
+Times = "," Number:n "}" => [[ 0 n <from-to> ]]
+ | Number:n ",}" => [[ n <at-least> ]]
+ | Number:n "}" => [[ n n <from-to> ]]
+ | "}" => [[ bad-number ]]
+ | Number:n "," Number:m "}" => [[ n m <from-to> ]]
+
+Repeated = Element:e "{" Times:t => [[ e t <times> ]]
+ | Element:e "??" => [[ e <maybe> ]]
+ | Element:e "*?" => [[ e <star> ]]
+ | Element:e "+?" => [[ e <plus> ]]
+ | Element:e "?" => [[ e <maybe> ]]
+ | Element:e "*" => [[ e <star> ]]
+ | Element:e "+" => [[ e <plus> ]]
+ | Element
+
+Concatenation = Repeated*:r => [[ r sift <concatenation> ]]
+
+Alternation = Concatenation:c ("|" Concatenation)*:a
+ => [[ a empty? [ c ] [ a values c prefix <alternation> ] if ]]
+
+End = !(.)
-: (parse-regexp) ( -- )
- read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
-
-: parse-regexp-beginning ( -- )
- peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
-
-: parse-regexp ( regexp -- )
- dup current-regexp [
- raw>> [
- <string-reader> [
- parse-regexp-beginning (parse-regexp)
- ] with-input-stream
- ] unless-empty
- current-regexp get [ finish-regexp-parse ] change-stack
- dup stack>> >>parse-tree drop
- ] with-variable ;
+Main = Alternation End
+;EBNF
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings help.markup help.syntax regexp.backend ;
+USING: kernel strings help.markup help.syntax math regexp.parser regexp.ast ;
IN: regexp
+ABOUT: "regexp"
+
+ARTICLE: "regexp" "Regular expressions"
+"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
+{ $subsection { "regexp" "intro" } }
+"The class of regular expressions:"
+{ $subsection regexp }
+"Basic usage:"
+{ $subsection { "regexp" "syntax" } }
+{ $subsection { "regexp" "options" } }
+{ $subsection { "regexp" "construction" } }
+{ $subsection { "regexp" "operations" } }
+"Advanced topics:"
+{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
+{ $subsection { "regexp" "theory" } }
+{ $subsection { "regexp" "deploy" } } ;
+
+ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
+
+;
+
+ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
+"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
+{ $subsection POSTPONE: R/ }
+"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
+{ $subsection <regexp> }
+{ $subsection <optioned-regexp> }
+"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
+
+ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
+"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely. A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "."
+{ $heading "Characters" }
+{ $heading "Character classes" }
+{ $heading "Predefined character classes" }
+{ $heading "Boundaries" }
+{ $heading "Greedy quantifiers" }
+{ $heading "Reluctant quantifiers" }
+{ $heading "Posessive quantifiers" }
+{ $heading "Logical operations" }
+{ $heading "Lookaround" }
+{ $heading "Unsupported features" }
+"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
+"Another feature is Perl's " { $snippet "\\G" } " syntax, which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
+"Additionally, none of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included, for simplicity." ; ! Also describe syntax, from the beginning
+
+ARTICLE: { "regexp" "options" } "Regular expression options"
+"When " { $link { "regexp" "construction" } } ", various options can be provided. Options have single-character names. A string of options has one of the following two forms:"
+{ $code "on" "on-off" }
+"The latter syntax allows some options to be disabled. The " { $snippet "on" } " and " { $snippet "off" } " strings name options to be enabled and disabled, respectively."
+$nl
+"The following options are supported:"
+{ $table
+ { "i" { $link case-insensitive } }
+ { "d" { $link unix-lines } }
+ { "m" { $link multiline } }
+ { "n" { $link multiline } }
+ { "r" { $link reversed-regexp } }
+ { "s" { $link dotall } }
+ { "u" { $link unicode-case } }
+ { "x" { $link comments } }
+} ;
+
+ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
+"Far from being just a practical tool invented by Unix hackers, regular expressions were studied formally before computer programs were written to process them." $nl
+"A regular language is a set of strings that is matched by a regular expression, which is defined to have characters and the empty string, along with the operations concatenation, disjunction and Kleene star. Another way to define the class of regular languages is as the class of languages which can be recognized with constant space overhead, ie with a DFA. These two definitions are provably equivalent." $nl
+"One basic result in the theory of regular language is that the complement of a regular language is regular. In other words, for any regular expression, there exists another regular expression which matches exactly the strings that the first one doesn't match." $nl
+"This implies, by DeMorgan's law, that, if you have two regular languages, their intersection is also regular. That is, for any two regular expressions, there exists a regular expression which matches strings that match both inputs." $nl
+"Traditionally, regular expressions on computer support an additional operation: backreferences. For example, the Perl regexp " { $snippet "/(.*)$1/" } " matches a string repated twice. If a backreference refers to a string with a predetermined maximum length, then the resulting language is still regular." $nl
+"But, if not, the language is not regular. There is strong evidence that there is no efficient way to parse with backreferences in the general case. Perl uses a naive backtracking algorithm which has pathological behavior in some cases, taking exponential time to match even if backreferences aren't used. Additionally, expressions with backreferences don't have the properties with negation and intersection described above." $nl
+"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
+
+ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
+"Testing if a string matches a regular expression:"
+{ $subsection matches? }
+"Finding a match inside a string:"
+{ $subsection re-contains? }
+{ $subsection first-match }
+"Finding all matches inside a string:"
+{ $subsection count-matches }
+{ $subsection all-matching-slices }
+{ $subsection all-matching-subseqs }
+"Splitting a string into tokens delimited by a regular expression:"
+{ $subsection re-split }
+"Replacing occurrences of a regular expression with a string:"
+{ $subsection re-replace } ;
+
+ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
+"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
+$nl
+"Regular expressions constructed at runtime from a deployed application will be compiled with the non-optimizing compiler, which is always available because it is built into the Factor VM. This will result in lower performance than when using the optimizing compiler."
+$nl
+"Literal regular expressions constructed at parse time do not suffer from this restriction, since the deployed application is loaded and compiled before anything is stripped out."
+$nl
+"None of this applies to deployed applications which include the optimizing compiler, or code running inside a development image."
+{ $see-also "compiler" { "regexp" "construction" } "deploy-flags" } ;
+
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
-{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
+{ $description "Creates a regular expression object, given a string in regular expression syntax. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
+
+HELP: <optioned-regexp>
+{ $values { "string" string } { "options" "a string of " { $link { "regexp" "options" } } } { "regexp" regexp } }
+{ $description "Given a string in regular expression syntax, and a string of options, creates a regular expression object. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
+
+HELP: R/
+{ $syntax "R/ foo.*|[a-zA-Z]bar/options" }
+{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use. The syntax for the " { $snippet "options" } " string is documented in " { $link { "regexp" "options" } } "." } ;
+
+HELP: regexp
+{ $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
+
+HELP: matches?
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
+{ $description "Tests if the string as a whole matches the given regular expression." } ;
+
+HELP: all-matching-slices
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
+{ $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ;
+
+HELP: count-matches
+{ $values { "string" string } { "regexp" regexp } { "n" integer } }
+{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matching-slices } "." } ;
+
+HELP: re-split
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
+{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matching-slices } "." } ;
+
+HELP: re-replace
+{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } }
+{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } ;
+
+HELP: first-match
+{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } }
+{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ;
+
+HELP: re-contains?
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
+{ $description "Determines whether the string has a substring which matches the regular expression given." } ;
-USING: regexp tools.test kernel sequences regexp.parser
-regexp.traversal eval strings multiline ;
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp tools.test kernel sequences regexp.parser regexp.private
+eval strings multiline accessors ;
IN: regexp-tests
\ <regexp> must-infer
+\ compile-regexp must-infer
\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "b" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
-[ f ] [ "" "|" <regexp> matches? ] unit-test
-[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
+[ t ] [ "" "|" <regexp> matches? ] unit-test
+[ t ] [ "" "|||||||" <regexp> matches? ] unit-test
[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
! Dotall mode -- when on, . matches newlines.
! Off by default.
[ f ] [ "\n" "." <regexp> matches? ] unit-test
-[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
+[ t ] [ "\n" "(?s:.)" <regexp> matches? ] unit-test
[ t ] [ "\n" R/ ./s matches? ] unit-test
-[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
+[ f ] [ "\n\n" "(?s:.)." <regexp> matches? ] unit-test
[ f ] [ "" ".+" <regexp> matches? ] unit-test
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
-/*
-! FIXME
[ f ] [ "" "(a)" <regexp> matches? ] unit-test
[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
-*/
[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
-/*
-! FIXME
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
-*/
[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
-[ f ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
+[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\u0078" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\u0078" <regexp> matches? ] unit-test
[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
-[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
-[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
+[ "aaa" ] [ "aaacb" "a*" <regexp> first-match >string ] unit-test
+[ "aa" ] [ "aaacb" "aa?" <regexp> first-match >string ] unit-test
[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
[ f ] [ "aax" R/ AAA/i matches? ] unit-test
[ t ] [ "c" R/ [A-Z]/i matches? ] unit-test
[ f ] [ "3" R/ [A-Z]/i matches? ] unit-test
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
+[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
-[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
-[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
-[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
-[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
+[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
+[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
+[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
[ t ] [ "A" R/ [a-z]/i matches? ] unit-test
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
-[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
-[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
-! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
+[ t ] [ "abc" R/ abc/r matches? ] unit-test
+[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test
+
+[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
+[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
[ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
-/*
-! FIXME
[ ] [
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
<regexp> drop
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
-*/
-
-! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
-
-! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
[ { "ABC" "DEF" "GHI" } ]
-[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matching-subseqs ] unit-test
[ 3 ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
-/*
-! FIXME
-[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
+[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
+[ t ] [ "fxxbar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
+[ t ] [ "foobar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
-[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
-[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> first-match >string ] unit-test
+[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> first-match >string ] unit-test
-[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
-*/
+[ 3 ] [ "foobar" "foo(?=bar)" <regexp> first-match length ] unit-test
+[ f ] [ "foobxr" "foo(?=bar)" <regexp> first-match ] unit-test
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
-! Convert to lowercase until E
-[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
-[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
-
-! Convert to uppercase until E
-[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
-[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
-
-! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
-
-! [ t ] [ "a" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
-! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test
-
-! [ t ] [ "a" R/ a$/ matches? ] unit-test
-! [ f ] [ "a\n" R/ a$/ matches? ] unit-test
-! [ f ] [ "a\r" R/ a$/ matches? ] unit-test
-! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
-
-! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test
-! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test
-! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test
-! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
-
-! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
-! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
-! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
-! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
-
-! [ t ] [ "a" R/ \Aa/m matches? ] unit-test
-! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
-! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
-! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
-
-! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
-
-! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
-! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
-
-! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
-! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
-
-! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
-! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
-! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
-! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
-
-! [ t ] [ "a" R/ ^a/m matches? ] unit-test
-! [ t ] [ "\na" R/ ^a/m matches? ] unit-test
-! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
-! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
-
-! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
-! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
-! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
-! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test
-
-! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
-! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
-
-! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
-! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
-
-! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
-! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
-! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
-
-! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
-! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
-! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
-! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
-! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
-
-! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
-! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
-! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
-! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
-! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
-! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
-
-! "ab" "a(?=b*)" <regexp> match
-! "abbbbbc" "a(?=b*c)" <regexp> match
-! "ab" "a(?=b*)" <regexp> match
-
-! "baz" "(az)(?<=b)" <regexp> first-match
-! "cbaz" "a(?<=b*)" <regexp> first-match
-! "baz" "a(?<=b)" <regexp> first-match
-
-! "baz" "a(?<!b)" <regexp> first-match
-! "caz" "a(?<!b)" <regexp> first-match
-
-! "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match
-! "abcdefg" "a(?#bcdefg)bcd" <regexp> first-match
-! "abcdefg" "a(?:bcdefg)" <regexp> first-match
-
-! "caba" "a(?<=b)" <regexp> first-match
-
-! capture group 1: "aaaa" 2: ""
-! "aaaa" "(a*)(a*)" <regexp> match*
-! "aaaa" "(a*)(a+)" <regexp> match*
+! Testing negation
+[ f ] [ "a" R/ (?~a)/ matches? ] unit-test
+[ t ] [ "aa" R/ (?~a)/ matches? ] unit-test
+[ t ] [ "bb" R/ (?~a)/ matches? ] unit-test
+[ t ] [ "" R/ (?~a)/ matches? ] unit-test
+
+[ f ] [ "a" R/ (?~a+|b)/ matches? ] unit-test
+[ f ] [ "aa" R/ (?~a+|b)/ matches? ] unit-test
+[ t ] [ "bb" R/ (?~a+|b)/ matches? ] unit-test
+[ f ] [ "b" R/ (?~a+|b)/ matches? ] unit-test
+[ t ] [ "" R/ (?~a+|b)/ matches? ] unit-test
+
+! Intersecting classes
+[ t ] [ "ab" R/ ac|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ab" R/ ac|[a-z]b/ matches? ] unit-test
+[ t ] [ "ac" R/ ac|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ac" R/ ac|[a-z]b/ matches? ] unit-test
+[ t ] [ "ac" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ t ] [ "Ï€b" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ f ] [ "Ï€c" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+[ f ] [ "Ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
+
+[ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
+
+[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "Ï€b" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "Ï€c" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+
+! DFA is compiled when needed, or when literal
+[ regexp-initial-word ] [ "foo" <regexp> dfa>> ] unit-test
+[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test
+
+[ t ] [ "a" R/ ^a/ matches? ] unit-test
+[ f ] [ "\na" R/ ^a/ matches? ] unit-test
+[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
+[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
+
+[ 1 ] [ "a" R/ ^a/ count-matches ] unit-test
+[ 0 ] [ "\na" R/ ^a/ count-matches ] unit-test
+[ 0 ] [ "\r\na" R/ ^a/ count-matches ] unit-test
+[ 0 ] [ "\ra" R/ ^a/ count-matches ] unit-test
+
+[ t ] [ "a" R/ a$/ matches? ] unit-test
+[ f ] [ "a\n" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r" R/ a$/ matches? ] unit-test
+[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
+
+[ 1 ] [ "a" R/ a$/ count-matches ] unit-test
+[ 0 ] [ "a\n" R/ a$/ count-matches ] unit-test
+[ 0 ] [ "a\r" R/ a$/ count-matches ] unit-test
+[ 0 ] [ "a\r\n" R/ a$/ count-matches ] unit-test
+
+[ t ] [ "a" R/ a$|b$/ matches? ] unit-test
+[ t ] [ "b" R/ a$|b$/ matches? ] unit-test
+[ f ] [ "ab" R/ a$|b$/ matches? ] unit-test
+[ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
+
+[ t ] [ "a" R/ \Aa/ matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
+
+[ t ] [ "a" R/ \Aa/m matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
+[ 0 ] [ "\ra" R/ \Aa/m count-matches ] unit-test
+
+[ f ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
+[ 1 ] [ "\r\n\n\n\nam" R/ ^am/m count-matches ] unit-test
+
+[ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
+[ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
+
+[ f ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
+[ f ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
+[ 1 ] [ "a\r\n" R/ \Aa\Z/m count-matches ] unit-test
+[ 1 ] [ "a\n" R/ \Aa\Z/m count-matches ] unit-test
+
+[ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
+[ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
+[ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
+[ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
+
+[ 1 ] [ "a" R/ \Aa\Z/m count-matches ] unit-test
+[ 0 ] [ "\na" R/ \Aaa\Z/m count-matches ] unit-test
+[ 0 ] [ "\r\na" R/ \Aa\Z/m count-matches ] unit-test
+[ 0 ] [ "\ra" R/ \Aa\Z/m count-matches ] unit-test
+
+[ t ] [ "a" R/ ^a/m matches? ] unit-test
+[ f ] [ "\na" R/ ^a/m matches? ] unit-test
+[ 1 ] [ "\na" R/ ^a/m count-matches ] unit-test
+[ 1 ] [ "\r\na" R/ ^a/m count-matches ] unit-test
+[ 1 ] [ "\ra" R/ ^a/m count-matches ] unit-test
+
+[ t ] [ "a" R/ a$/m matches? ] unit-test
+[ f ] [ "a\n" R/ a$/m matches? ] unit-test
+[ 1 ] [ "a\n" R/ a$/m count-matches ] unit-test
+[ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test
+[ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test
+
+[ f ] [ "foobxr" "foo\\z" <regexp> first-match ] unit-test
+[ 3 ] [ "foo" "foo\\z" <regexp> first-match length ] unit-test
+
+[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test
+[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
+[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
+
+[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matching-subseqs ] unit-test
+
+[ t ] [ "foo" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "afoob" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "afoob" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ f ] [ "foo" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
+
+[ 3 ] [ "foo bar" "foo\\b" <regexp> first-match length ] unit-test
+[ f ] [ "fooxbar" "foo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "foo" "foo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+[ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
+
+[ f ] [ "foo bar" "foo\\B" <regexp> re-contains? ] unit-test
+[ 3 ] [ "fooxbar" "foo\\B" <regexp> first-match length ] unit-test
+[ f ] [ "foo" "foo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+[ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
+
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+[ t ] [ "abbbbbc" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ f ] [ "abbbbb" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+
+[ "az" ] [ "baz" "(?<=b)(az)" <regexp> first-match >string ] unit-test
+[ f ] [ "chaz" "(?<=b)(az)" <regexp> re-contains? ] unit-test
+[ "a" ] [ "cbaz" "(?<=b*)a" <regexp> first-match >string ] unit-test
+[ f ] [ "baz" "a(?<=b)" <regexp> re-contains? ] unit-test
+
+[ f ] [ "baz" "(?<!b)a" <regexp> re-contains? ] unit-test
+[ t ] [ "caz" "(?<!b)a" <regexp> re-contains? ] unit-test
+
+[ "abcd" ] [ "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match >string ] unit-test
+[ t ] [ "abcdefg" "a(?#bcdefg)bcd" <regexp> re-contains? ] unit-test
+[ t ] [ "abcdefg" "a(?:bcdefg)" <regexp> matches? ] unit-test
+
+[ 3 ] [ "caba" "(?<=b)a" <regexp> first-match from>> ] unit-test
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math sequences strings sets
-assocs prettyprint.backend prettyprint.custom make lexer
-namespaces parser arrays fry regexp.backend regexp.utils
-regexp.parser regexp.nfa regexp.dfa regexp.traversal
-regexp.transition-tables splitting sorting ;
+USING: accessors combinators kernel kernel.private math sequences
+sequences.private strings sets assocs prettyprint.backend
+prettyprint.custom make lexer namespaces parser arrays fry locals
+regexp.parser splitting sorting regexp.ast regexp.negation
+regexp.compiler words call call.private math.ranges ;
IN: regexp
-: default-regexp ( string -- regexp )
- regexp new
- swap >>raw
- <transition-table> >>nfa-table
- <transition-table> >>dfa-table
- <transition-table> >>minimized-table
- H{ } clone >>nfa-traversal-flags
- H{ } clone >>dfa-traversal-flags
- H{ } clone >>options
- H{ } clone >>matchers
- reset-regexp ;
-
-: construct-regexp ( regexp -- regexp' )
- {
- [ parse-regexp ]
- [ construct-nfa ]
- [ construct-dfa ]
- [ ]
- } cleave ;
+TUPLE: regexp
+ { raw read-only }
+ { parse-tree read-only }
+ { options read-only }
+ dfa next-match ;
+
+TUPLE: reverse-regexp < regexp ;
+
+<PRIVATE
+
+M: lookahead question>quot ! Returns ( index string -- ? )
+ term>> ast>dfa dfa>shortest-word '[ f _ execute ] ;
+
+: <reversed-option> ( ast -- reversed )
+ "r" string>options <with-options> ;
+
+M: lookbehind question>quot ! Returns ( index string -- ? )
+ term>> <reversed-option>
+ ast>dfa dfa>reverse-shortest-word
+ '[ [ 1- ] dip f _ execute ] ;
-: (match) ( string regexp -- dfa-traverser )
- <dfa-traverser> do-match ; inline
+: check-string ( string -- string )
+ ! Make this configurable
+ dup string? [ "String required" throw ] unless ;
-: match ( string regexp -- slice/f )
- (match) return-match ;
+: match-index-from ( i string regexp -- index/f )
+ ! This word is unsafe. It assumes that i is a fixnum
+ ! and that string is a string.
+ dup dfa>> execute-unsafe( index string regexp -- i/f ) ;
-: match* ( string regexp -- slice/f captured-groups )
- (match) [ return-match ] [ captured-groups>> ] bi ;
+GENERIC: end/start ( string regexp -- end start )
+M: regexp end/start drop length 0 ;
+M: reverse-regexp end/start drop length 1- -1 swap ;
+
+PRIVATE>
: matches? ( string regexp -- ? )
- dupd match
- [ [ length ] bi@ = ] [ drop f ] if* ;
+ [ check-string ] dip
+ [ end/start ] 2keep
+ match-index-from
+ [ = ] [ drop f ] if* ;
-: match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
+<PRIVATE
-: match-at ( string m regexp -- n/f finished? )
- [
- 2dup swap length > [ 2drop f f ] [ tail-slice t ] if
- ] dip swap [ match-head f ] [ 2drop f t ] if ;
+:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
+ i string regexp quot call dup [| j |
+ j i j
+ reverse? [ swap [ 1+ ] bi@ ] when
+ string
+ ] [ drop f f f f ] if ; inline
-: match-range ( string m regexp -- a/f b/f )
- 3dup match-at over [
- drop nip rot drop dupd +
- ] [
- [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
- ] if ;
+: search-range ( i string reverse? -- seq )
+ [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline
-: first-match ( string regexp -- slice/f )
- dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
+:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
+ f f f f
+ i string reverse? search-range
+ [ [ 2drop 2drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline
+
+: do-next-match ( i string regexp -- i start end ? )
+ dup next-match>>
+ execute-unsafe( i string regexp -- i start end ? ) ; inline
+
+:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
+ i string regexp do-next-match [| i' start end |
+ start end string quot call
+ i' string regexp quot (each-match)
+ ] [ 3drop ] if ; inline recursive
+
+: prepare-match-iterator ( string regexp -- i string regexp )
+ [ check-string ] dip [ end/start nip ] 2keep ; inline
+
+PRIVATE>
+
+: each-match ( string regexp quot: ( start end string -- ) -- )
+ [ prepare-match-iterator ] dip (each-match) ; inline
+
+: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
+ accumulator [ each-match ] dip >array ; inline
+
+: all-matching-slices ( string regexp -- seq )
+ [ slice boa ] map-matches ;
+
+: all-matching-subseqs ( string regexp -- seq )
+ [ subseq ] map-matches ;
+
+: count-matches ( string regexp -- n )
+ [ 0 ] 2dip [ 3drop 1+ ] each-match ;
+
+<PRIVATE
+
+:: (re-split) ( string regexp quot -- new-slices )
+ 0 string regexp [| end start end' string |
+ end' ! leave it on the stack for the next iteration
+ end start string quot call
+ ] map-matches
+ ! Final chunk
+ swap string length string quot call suffix ; inline
+
+PRIVATE>
-: re-cut ( string regexp -- end/f start )
- dupd first-match
- [ split1-slice swap ] [ "" like f swap ] if* ;
+: first-match ( string regexp -- slice/f )
+ [ prepare-match-iterator do-next-match ] [ drop ] 2bi
+ '[ _ slice boa nip ] [ 3drop f ] if ;
-: (re-split) ( string regexp -- )
- over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ;
+: re-contains? ( string regexp -- ? )
+ prepare-match-iterator do-next-match [ 3drop ] dip >boolean ;
: re-split ( string regexp -- seq )
- [ (re-split) ] { } make ;
+ [ slice boa ] (re-split) ;
: re-replace ( string regexp replacement -- result )
- [ re-split ] dip join ;
+ [ [ subseq ] (re-split) ] dip join ;
-: next-match ( string regexp -- end/f match/f )
- dupd first-match dup
- [ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
+<PRIVATE
-: all-matches ( string regexp -- seq )
- [ dup ] swap '[ _ next-match ] produce nip harvest ;
+: get-ast ( regexp -- ast )
+ [ parse-tree>> ] [ options>> ] bi <with-options> ;
-: count-matches ( string regexp -- n )
- all-matches length ;
+GENERIC: compile-regexp ( regex -- regexp )
+
+: regexp-initial-word ( i string regexp -- i/f )
+ compile-regexp match-index-from ;
+
+: do-compile-regexp ( regexp -- regexp )
+ dup '[
+ dup \ regexp-initial-word =
+ [ drop _ get-ast ast>dfa dfa>word ] when
+ ] change-dfa ;
+
+M: regexp compile-regexp ( regexp -- regexp )
+ do-compile-regexp ;
+
+M: reverse-regexp compile-regexp ( regexp -- regexp )
+ t backwards? [ do-compile-regexp ] with-variable ;
+
+DEFER: compile-next-match
+
+: next-initial-word ( i string regexp -- i start end string )
+ compile-next-match do-next-match ;
+
+: compile-next-match ( regexp -- regexp )
+ dup '[
+ dup \ next-initial-word = [
+ drop _ [ compile-regexp dfa>> def>> ] [ reverse-regexp? ] bi
+ '[ { array-capacity string regexp } declare _ _ next-match ]
+ (( i string regexp -- i start end string )) simple-define-temp
+ ] when
+ ] change-next-match ;
+
+PRIVATE>
+
+: new-regexp ( string ast options class -- regexp )
+ [ \ regexp-initial-word \ next-initial-word ] dip boa ; inline
+
+: make-regexp ( string ast -- regexp )
+ f f <options> regexp new-regexp ;
+
+: <optioned-regexp> ( string options -- regexp )
+ [ dup parse-regexp ] [ string>options ] bi*
+ dup on>> reversed-regexp swap member?
+ [ reverse-regexp new-regexp ]
+ [ regexp new-regexp ] if ;
+
+: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
<PRIVATE
+! The following two should do some caching
+
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }
{ "R| " "|" }
} swap [ subseq? not nip ] curry assoc-find drop ;
-: string>options ( string -- options )
- [ ch>option dup ] H{ } map>assoc ;
-
-: options>string ( options -- string )
- keys [ option>ch ] map natural-sort >string ;
+: take-until ( end lexer -- string )
+ dup skip-blank [
+ [ index-from ] 2keep
+ [ swapd subseq ]
+ [ 2drop 1+ ] 3bi
+ ] change-lexer-column ;
-PRIVATE>
-
-: <optioned-regexp> ( string option-string -- regexp )
- [ default-regexp ] [ string>options ] bi* >>options
- construct-regexp ;
-
-: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
-
-<PRIVATE
+: parse-noblank-token ( lexer -- str/f )
+ dup still-parsing-line? [ (parse-token) ] [ drop f ] if ;
: parsing-regexp ( accum end -- accum )
- lexer get dup skip-blank
- [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
- lexer get dup still-parsing-line?
- [ (parse-token) ] [ drop f ] if
- <optioned-regexp> parsed ;
+ lexer get [ take-until ] [ parse-noblank-token ] bi
+ <optioned-regexp> compile-next-match parsed ;
PRIVATE>
[ options>> options>string % ] bi
] "" make
] keep present-text ;
+
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel sequences
-vectors regexp.utils ;
+vectors locals regexp.classes ;
IN: regexp.transition-tables
-TUPLE: transition from to obj ;
-TUPLE: literal-transition < transition ;
-TUPLE: class-transition < transition ;
-TUPLE: default-transition < transition ;
-
-TUPLE: literal obj ;
-TUPLE: class obj ;
-TUPLE: default ;
-: make-transition ( from to obj class -- obj )
- new
- swap >>obj
- swap >>to
- swap >>from ;
-
-: <literal-transition> ( from to obj -- transition )
- literal-transition make-transition ;
-
-: <class-transition> ( from to obj -- transition )
- class-transition make-transition ;
-
-: <default-transition> ( from to -- transition )
- t default-transition make-transition ;
-
TUPLE: transition-table transitions start-state final-states ;
: <transition-table> ( -- transition-table )
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
+ ! Why do we have to do this?
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
-: set-transition ( transition hash -- )
- #! set the state as a key
- 2dup [ to>> ] dip maybe-initialize-key
- [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
- 2dup at* [ 2nip insert-at ]
- [ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ;
-
-: add-transition ( transition transition-table -- )
- transitions>> set-transition ;
+:: (set-transition) ( from to obj hash -- )
+ to condition? [ to hash maybe-initialize-key ] unless
+ from hash at
+ [ [ to obj ] dip set-at ]
+ [ to obj associate from hash set-at ] if* ;
+
+: set-transition ( from to obj transition-table -- )
+ transitions>> (set-transition) ;
+
+:: (add-transition) ( from to obj hash -- )
+ to hash maybe-initialize-key
+ from hash at
+ [ [ to obj ] dip push-at ]
+ [ to 1vector obj associate from hash set-at ] if* ;
+
+: add-transition ( from to obj transition-table -- )
+ transitions>> (add-transition) ;
+
+: map-set ( assoc quot -- new-assoc )
+ '[ drop @ dup ] assoc-map ; inline
+
+: number-transitions ( transitions numbering -- new-transitions )
+ dup '[
+ [ _ at ]
+ [ [ _ condition-at ] assoc-map ] bi*
+ ] assoc-map ;
+
+: transitions-at ( transition-table assoc -- transition-table )
+ [ clone ] dip
+ [ '[ _ condition-at ] change-start-state ]
+ [ '[ [ _ at ] map-set ] change-final-states ]
+ [ '[ _ number-transitions ] change-transitions ] tri ;
+
+: expand-one-or ( or-class transition -- alist )
+ [ seq>> ] dip '[ _ 2array ] map ;
+
+: expand-or ( state-transitions -- new-transitions )
+ >alist [
+ first2 over or-class?
+ [ expand-one-or ] [ 2array 1array ] if
+ ] map concat >hashtable ;
+
+: expand-ors ( transition-table -- transition-table )
+ [ [ expand-or ] assoc-map ] change-transitions ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators kernel math
-quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
-IN: regexp.traversal
-
-TUPLE: dfa-traverser
- dfa-table
- traversal-flags
- traverse-forward
- lookahead-counters
- lookbehind-counters
- capture-counters
- captured-groups
- capture-group-index
- last-state current-state
- text
- match-failed?
- start-index current-index
- matches ;
-
-: <dfa-traverser> ( text regexp -- match )
- [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
- dfa-traverser new
- swap >>traversal-flags
- swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
- swap >>text
- t >>traverse-forward
- 0 >>start-index
- 0 >>current-index
- 0 >>capture-group-index
- V{ } clone >>matches
- V{ } clone >>capture-counters
- V{ } clone >>lookbehind-counters
- V{ } clone >>lookahead-counters
- H{ } clone >>captured-groups ;
-
-: final-state? ( dfa-traverser -- ? )
- [ current-state>> ]
- [ dfa-table>> final-states>> ] bi key? ;
-
-: beginning-of-text? ( dfa-traverser -- ? )
- current-index>> 0 <= ; inline
-
-: end-of-text? ( dfa-traverser -- ? )
- [ current-index>> ] [ text>> length ] bi >= ; inline
-
-: text-finished? ( dfa-traverser -- ? )
- {
- [ current-state>> empty? ]
- [ end-of-text? ]
- [ match-failed?>> ]
- } 1|| ;
-
-: save-final-state ( dfa-straverser -- )
- [ current-index>> ] [ matches>> ] bi push ;
-
-: match-done? ( dfa-traverser -- ? )
- dup final-state? [
- dup save-final-state
- ] when text-finished? ;
-
-: previous-text-character ( dfa-traverser -- ch )
- [ text>> ] [ current-index>> 1- ] bi nth ;
-
-: current-text-character ( dfa-traverser -- ch )
- [ text>> ] [ current-index>> ] bi nth ;
-
-: next-text-character ( dfa-traverser -- ch )
- [ text>> ] [ current-index>> 1+ ] bi nth ;
-
-GENERIC: flag-action ( dfa-traverser flag -- )
-
-
-M: beginning-of-input flag-action ( dfa-traverser flag -- )
- drop
- dup beginning-of-text? [ t >>match-failed? ] unless drop ;
-
-M: end-of-input flag-action ( dfa-traverser flag -- )
- drop
- dup end-of-text? [ t >>match-failed? ] unless drop ;
-
-
-M: beginning-of-line flag-action ( dfa-traverser flag -- )
- drop
- dup {
- [ beginning-of-text? ]
- [ previous-text-character terminator-class class-member? ]
- } 1|| [ t >>match-failed? ] unless drop ;
-
-M: end-of-line flag-action ( dfa-traverser flag -- )
- drop
- dup {
- [ end-of-text? ]
- [ next-text-character terminator-class class-member? ]
- } 1|| [ t >>match-failed? ] unless drop ;
-
-
-M: word-boundary flag-action ( dfa-traverser flag -- )
- drop
- dup {
- [ end-of-text? ]
- [ current-text-character terminator-class class-member? ]
- } 1|| [ t >>match-failed? ] unless drop ;
-
-
-M: lookahead-on flag-action ( dfa-traverser flag -- )
- drop
- lookahead-counters>> 0 swap push ;
-
-M: lookahead-off flag-action ( dfa-traverser flag -- )
- drop
- dup lookahead-counters>>
- [ drop ] [ pop '[ _ - ] change-current-index drop ] if-empty ;
-
-M: lookbehind-on flag-action ( dfa-traverser flag -- )
- drop
- f >>traverse-forward
- [ 2 - ] change-current-index
- lookbehind-counters>> 0 swap push ;
-
-M: lookbehind-off flag-action ( dfa-traverser flag -- )
- drop
- t >>traverse-forward
- dup lookbehind-counters>>
- [ drop ] [ pop '[ _ + 2 + ] change-current-index drop ] if-empty ;
-
-M: capture-group-on flag-action ( dfa-traverser flag -- )
- drop
- [ current-index>> 0 2array ]
- [ capture-counters>> ] bi push ;
-
-M: capture-group-off flag-action ( dfa-traverser flag -- )
- drop
- dup capture-counters>> empty? [
- drop
- ] [
- {
- [ capture-counters>> pop first2 dupd + ]
- [ text>> <slice> ]
- [ [ 1+ ] change-capture-group-index capture-group-index>> ]
- [ captured-groups>> set-at ]
- } cleave
- ] if ;
-
-: process-flags ( dfa-traverser -- )
- [ [ 1+ ] map ] change-lookahead-counters
- [ [ 1+ ] map ] change-lookbehind-counters
- [ [ first2 1+ 2array ] map ] change-capture-counters
- ! dup current-state>> .
- dup [ current-state>> ] [ traversal-flags>> ] bi
- at [ flag-action ] with each ;
-
-: increment-state ( dfa-traverser state -- dfa-traverser )
- [
- dup traverse-forward>>
- [ [ 1+ ] change-current-index ]
- [ [ 1- ] change-current-index ] if
- dup current-state>> >>last-state
- ] [ first ] bi* >>current-state ;
-
-: match-literal ( transition from-state table -- to-state/f )
- transitions>> at at ;
-
-: match-class ( transition from-state table -- to-state/f )
- transitions>> at* [
- [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
- ] [ drop ] if ;
-
-: match-default ( transition from-state table -- to-state/f )
- [ drop ] 2dip transitions>> at t swap at ;
-
-: match-transition ( obj from-state dfa -- to-state/f )
- { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
-
-: setup-match ( match -- obj state dfa-table )
- [ [ current-index>> ] [ text>> ] bi nth ]
- [ current-state>> ]
- [ dfa-table>> ] tri ;
-
-: do-match ( dfa-traverser -- dfa-traverser )
- dup process-flags
- dup match-done? [
- dup setup-match match-transition
- [ increment-state do-match ] when*
- ] unless ;
-
-: return-match ( dfa-traverser -- slice/f )
- dup matches>>
- [ drop f ]
- [
- [ [ text>> ] [ start-index>> ] bi ]
- [ peek ] bi* rot <slice>
- ] if-empty ;
+++ /dev/null
-USING: regexp.utils tools.test ;
-IN: regexp.utils.tests
-
-[ [ ] [ ] while-changes ] must-infer
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs io kernel math math.order
-namespaces regexp.backend sequences unicode.categories
-math.ranges fry combinators.short-circuit vectors ;
-IN: regexp.utils
-
-: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj )
- [ [ dup slip ] dip pick over call ] dip dupd =
- [ 3drop ] [ (while-changes) ] if ; inline recursive
-
-: while-changes ( obj quot pred -- obj' )
- pick over call (while-changes) ; inline
-
-: assoc-with ( param assoc quot -- assoc curry )
- swapd [ [ -rot ] dip call ] 2curry ; inline
-
-: insert-at ( value key hash -- )
- 2dup at* [
- 2nip push
- ] [
- drop
- [ dup vector? [ 1vector ] unless ] 2dip set-at
- ] if ;
-
-: ?insert-at ( value key hash/f -- hash )
- [ H{ } clone ] unless* [ insert-at ] keep ;
-
-ERROR: bad-octal number ;
-ERROR: bad-hex number ;
-: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
-: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ;
-
-: ascii? ( n -- ? ) 0 HEX: 7f between? ;
-: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ;
-: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ;
-
-: hex-digit? ( n -- ? )
- [
- [ decimal-digit? ]
- [ CHAR: a CHAR: f between? ]
- [ CHAR: A CHAR: F between? ]
- ] 1|| ;
-
-: control-char? ( n -- ? )
- [
- [ 0 HEX: 1f between? ]
- [ HEX: 7f = ]
- ] 1|| ;
-
-: punct? ( n -- ? )
- "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
- [ [ alpha? ] [ CHAR: _ = ] ] 1|| ;
-
-: java-blank? ( n -- ? )
- {
- CHAR: \s CHAR: \t CHAR: \n
- HEX: b HEX: 7 CHAR: \r
- } member? ;
-
-: java-printable? ( n -- ? )
- [ [ alpha? ] [ punct? ] ] 1|| ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: see
+USING: help.markup help.syntax strings prettyprint.private
+definitions generic words classes ;
+
+HELP: synopsis
+{ $values { "defspec" "a definition specifier" } { "str" string } }
+{ $contract "Prettyprints the prologue of a definition." } ;
+
+HELP: synopsis*
+{ $values { "defspec" "a definition specifier" } }
+{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
+{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
+
+HELP: see
+{ $values { "defspec" "a definition specifier" } }
+{ $contract "Prettyprints a definition." } ;
+
+HELP: see-methods
+{ $values { "word" "a " { $link generic } " or a " { $link class } } }
+{ $contract "Prettyprints the methods defined on a generic word or class." } ;
+
+HELP: definer
+{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
+{ $contract "Outputs the parsing words which delimit the definition." }
+{ $examples
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ ": foo ; \\ foo definer . ."
+ ";\nPOSTPONE: :"
+ }
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ "SYMBOL: foo \\ foo definer . ."
+ "f\nPOSTPONE: SYMBOL:"
+ }
+}
+{ $notes "This word is used in the implementation of " { $link see } "." } ;
+
+HELP: definition
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
+{ $contract "Outputs the body of a definition." }
+{ $examples
+ { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
+}
+{ $notes "This word is used in the implementation of " { $link see } "." } ;
+
+ARTICLE: "see" "Printing definitions"
+"The " { $vocab-link "see" } " vocabulary implements support for printing out " { $link "definitions" } " in the image."
+$nl
+"Printing a definition:"
+{ $subsection see }
+"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
+{ $subsection see-methods } ;
+
+ABOUT: "see"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.builtin
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple classes.union combinators
+definitions effects generic generic.standard io io.pathnames
+io.streams.string io.styles kernel make namespaces prettyprint
+prettyprint.backend prettyprint.config prettyprint.custom
+prettyprint.sections sequences sets sorting strings summary
+words words.symbol ;
+IN: see
+
+GENERIC: see* ( defspec -- )
+
+: see ( defspec -- ) see* nl ;
+
+: synopsis ( defspec -- str )
+ [
+ 0 margin set
+ 1 line-limit set
+ [ synopsis* ] with-in
+ ] with-string-writer ;
+
+: definer. ( defspec -- )
+ definer drop pprint-word ;
+
+: comment. ( text -- )
+ H{ { font-style italic } } styled-text ;
+
+: stack-effect. ( word -- )
+ [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
+ [ effect>string comment. ] when* ;
+
+<PRIVATE
+
+: seeing-word ( word -- )
+ vocabulary>> pprinter-in set ;
+
+: word-synopsis ( word -- )
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: word synopsis* word-synopsis ;
+
+M: simple-generic synopsis* word-synopsis ;
+
+M: standard-generic synopsis*
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ dispatch# pprint* ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: hook-generic synopsis*
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ "combination" word-prop var>> pprint* ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: method-spec synopsis*
+ first2 method synopsis* ;
+
+M: method-body synopsis*
+ [ definer. ]
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] tri ;
+
+M: mixin-instance synopsis*
+ [ definer. ]
+ [ class>> pprint-word ]
+ [ mixin>> pprint-word ] tri ;
+
+M: pathname synopsis* pprint* ;
+
+M: word summary synopsis ;
+
+GENERIC: declarations. ( obj -- )
+
+M: object declarations. drop ;
+
+: declaration. ( word prop -- )
+ [ nip ] [ name>> word-prop ] 2bi
+ [ pprint-word ] [ drop ] if ;
+
+M: word declarations.
+ {
+ POSTPONE: parsing
+ POSTPONE: delimiter
+ POSTPONE: inline
+ POSTPONE: recursive
+ POSTPONE: foldable
+ POSTPONE: flushable
+ } [ declaration. ] with each ;
+
+: pprint-; ( -- ) \ ; pprint-word ;
+
+M: object see*
+ [
+ 12 nesting-limit set
+ 100 length-limit set
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ dup definer nip [ pprint-word ] when* declarations.
+ block>
+ ] with-use ;
+
+M: method-spec see*
+ first2 method see* ;
+
+GENERIC: see-class* ( word -- )
+
+M: union-class see-class*
+ <colon \ UNION: pprint-word
+ dup pprint-word
+ members pprint-elements pprint-; block> ;
+
+M: intersection-class see-class*
+ <colon \ INTERSECTION: pprint-word
+ dup pprint-word
+ participants pprint-elements pprint-; block> ;
+
+M: mixin-class see-class*
+ <block \ MIXIN: pprint-word
+ dup pprint-word <block
+ dup members [
+ hard line-break
+ \ INSTANCE: pprint-word pprint-word pprint-word
+ ] with each block> block> ;
+
+M: predicate-class see-class*
+ <colon \ PREDICATE: pprint-word
+ dup pprint-word
+ "<" text
+ dup superclass pprint-word
+ <block
+ "predicate-definition" word-prop pprint-elements
+ pprint-; block> block> ;
+
+M: singleton-class see-class* ( class -- )
+ \ SINGLETON: pprint-word pprint-word ;
+
+GENERIC: pprint-slot-name ( object -- )
+
+M: string pprint-slot-name text ;
+
+M: array pprint-slot-name
+ <flow \ { pprint-word
+ f <inset unclip text pprint-elements block>
+ \ } pprint-word block> ;
+
+: unparse-slot ( slot-spec -- array )
+ [
+ dup name>> ,
+ dup class>> object eq? [
+ dup class>> ,
+ initial: ,
+ dup initial>> ,
+ ] unless
+ dup read-only>> [
+ read-only ,
+ ] when
+ drop
+ ] { } make ;
+
+: pprint-slot ( slot-spec -- )
+ unparse-slot
+ dup length 1 = [ first ] when
+ pprint-slot-name ;
+
+M: tuple-class see-class*
+ <colon \ TUPLE: pprint-word
+ dup pprint-word
+ dup superclass tuple eq? [
+ "<" text dup superclass pprint-word
+ ] unless
+ <block "slots" word-prop [ pprint-slot ] each block>
+ pprint-; block> ;
+
+M: word see-class* drop ;
+
+M: builtin-class see-class*
+ drop "! Built-in class" comment. ;
+
+: see-class ( class -- )
+ dup class? [
+ [
+ [ seeing-word ] [ see-class* ] bi
+ ] with-use
+ ] [ drop ] if ;
+
+M: word see*
+ [ see-class ]
+ [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
+ [
+ dup [ class? ] [ symbol? ] bi and
+ [ drop ] [ call-next-method ] if
+ ] tri ;
+
+: seeing-implementors ( class -- seq )
+ dup implementors [ method ] with map natural-sort ;
+
+: seeing-methods ( generic -- seq )
+ "methods" word-prop values natural-sort ;
+
+PRIVATE>
+
+: see-all ( seq -- )
+ natural-sort [ nl nl ] [ see* ] interleave ;
+
+: methods ( word -- seq )
+ [
+ dup class? [ dup seeing-implementors % ] when
+ dup generic? [ dup seeing-methods % ] when
+ drop
+ ] { } make prune ;
+
+: see-methods ( word -- )
+ methods see-all nl ;
\ No newline at end of file
--- /dev/null
+Printing loaded definitions as source code
! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license.
-USING: simple-flat-file tools.test memoize ;
+USING: simple-flat-file tools.test memoize assocs ;
IN: simple-flat-file.tests
[ "#" split1 drop ] map harvest ;
: split-column ( line -- columns )
- "\t" split 2 head ;
+ " \t" split harvest 2 short head 2 f pad-tail ;
: parse-hex ( s -- n )
- 2 short tail hex> ;
+ dup [
+ "0x" ?head [ "U+" ?head [ "Missing 0x or U+" throw ] unless ] unless
+ hex>
+ ] when ;
: parse-line ( line -- code-unicode )
split-column [ parse-hex ] map ;
--- /dev/null
+#
+# Name: cp949 to Unicode table (for testing, partial)
+#
+0x00 0x0000 #NULL
+0x01 0x0001 #START OF HEADING
+0x02 0x0002 #START OF TEXT
+0x03 0x0003 #END OF TEXT
+0x04 0x0004 #END OF TRANSMISSION
+0x8253 0xAD2A #HANGUL SYLLABLE KIYEOK WAE PIEUPSIOS
+0x8254 0xAD2B #HANGUL SYLLABLE KIYEOK WAE SIOS
+0x8255 0xAD2E #HANGUL SYLLABLE KIYEOK WAE CIEUC
+0x8256 0xAD2F #HANGUL SYLLABLE KIYEOK WAE CHIEUCH
+0x8257 0xAD30 #HANGUL SYLLABLE KIYEOK WAE KHIEUKH
+0x8258 0xAD31 #HANGUL SYLLABLE KIYEOK WAE THIEUTH
+0x8259 0xAD32 #HANGUL SYLLABLE KIYEOK WAE PHIEUPH
}
} ;
+ARTICLE: "smtp-gmail" "Setting up SMTP with gmail"
+"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link "factor-boot-rc" } "." $nl
+"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
+{ $code
+ "USING: smtp namespaces io.sockets ;"
+ ""
+ "\"my.gmail.address@gmail.com\" \"secret-password\" <plain-auth> smtp-auth set-global"
+ ""
+ "\"smtp.gmail.com\" 587 <inet> smtp-server set-global"
+ ""
+ "t smtp-tls? set-global"
+} ;
+
+
ARTICLE: "smtp" "SMTP client library"
"The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
$nl
{ $subsection email }
{ $subsection <email> }
"Sending an email:"
-{ $subsection send-email } ;
+{ $subsection send-email }
+"More topics:"
+{ $subsection "smtp-gmail" } ;
ABOUT: "smtp"
"cannot-infer" word-prop rethrow ;
: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
+ [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
: infer-word ( word -- effect )
[
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval locals.backend
-system ;
+system compiler.units ;
IN: stack-checker.tests
\ infer. must-infer
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
-: m dup call ; inline
+: m ( q -- ) dup call ; inline
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
-: m'' [ dup curry ] ; inline
+: m'' ( -- q ) [ dup curry ] ; inline
-: m''' m'' call call ; inline
+: m''' ( -- ) m'' call call ; inline
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
-: m-if t over if ; inline
+: m-if ( a b c -- ) t over if ; inline
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
[ custom-error ] infer
] unit-test
-: funny-throw throw ; inline
+: funny-throw ( a -- * ) throw ; inline
[ T{ effect f 0 0 t } ] [
[ 3 funny-throw ] infer
[ dup [ 3 throw ] dip ] infer
] unit-test
-! This was a false trigger of the undecidable quotation
-! recursion bug
-{ 2 1 } [ find-last-sep ] must-infer-as
-
! Regression
-: missing->r-check 1 load-locals ;
+: missing->r-check ( a -- ) 1 load-locals ;
[ [ missing->r-check ] infer ] must-fail
[ [ [ f dup ] [ ] while ] infer ] must-fail
-: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
[ [ erg's-inference-bug ] infer ] must-fail
[ [ inference-invalidation-d ] infer ] must-fail
-: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline
+: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
-: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
+: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
[ [ ] debugging-curry-folding ] must-infer
-[ [ exit ] [ 1 2 3 ] if ] must-infer
\ No newline at end of file
+[ [ exit ] [ 1 2 3 ] if ] must-infer
+
+! Stack effects are required now but FORGET: clears them...
+: forget-test ( -- ) ;
+
+[ forget-test ] must-infer
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ forget-test ] must-infer
\ No newline at end of file
IN: stack-checker.transforms
: give-up-transform ( word -- )
- dup recursive-word?
- [ call-recursive-word ]
- [ dup infer-word apply-word/effect ]
- if ;
+ {
+ { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
+ [ dup infer-word apply-word/effect ]
+ } cond ;
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
{ string blah-generic } watch
-[ ] [ "hi" blah-generic ] unit-test
+[ "hi" ] [ "hi" blah-generic ] unit-test
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
-{ $see-also "definitions" "words" see see-methods } ;
+{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs definitions io io.styles kernel prettyprint
-sorting ;
+sorting see ;
IN: tools.crossref
: synopsis-alist ( definitions -- alist )
- [ dup synopsis swap ] { } map>assoc ;
+ [ [ synopsis ] keep ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
: copy-vm ( executable bundle-name -- vm )
prepend-path vm over copy-file ;
-: copy-fonts ( name dir -- )
+CONSTANT: theme-path "basis/ui/gadgets/theme/"
+
+: copy-theme ( name dir -- )
deploy-ui? get [
- append-path "resource:fonts/" swap copy-tree-into
+ append-path
+ theme-path append-path
+ [ make-directories ]
+ [ theme-path "resource:" prepend swap copy-tree ] bi
] [ 2drop ] if ;
: image-name ( vocab bundle-name -- str )
USING: help.markup help.syntax words alien.c-types assocs
-kernel ;
+kernel call call.private tools.deploy.config ;
IN: tools.deploy
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
{ $subsection "deploy-config" }
{ $subsection "deploy-flags" } ;
-ARTICLE: "tools.deploy" "Application deployment"
-"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
-$nl
-"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
+ARTICLE: "tools.deploy.usage" "Deploy tool usage"
+"Once the necessary deployment flags have been set, the application can be deployed:"
+{ $subsection deploy }
+"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
{ $code "\"hello-ui\" deploy" }
{ $list
{ "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
{ "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
{ "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
}
-"In all cases, running the program displays a window with a message."
-$nl
+"On all platforms, running the program will display a window with a message." ;
+
+ARTICLE: "tools.deploy.impl" "Deploy tool implementation"
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
$nl
+"The deploy tool generates " { $emphasis "staging images" } " containing major subsystems, and uses the staging images to derive the final application image. The first time an application is deployed using a major subsystem, such as the UI, a new staging image is made, which can take a few minutes. Subsequent deployments of applications using this subsystem will be much faster." ;
+
+ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
+{ $heading "Behavior of " { $link boa } }
+"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
+{ $heading "Behavior of " { $link POSTPONE: execute( } }
+"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "."
+{ $heading "Error reporting" }
+"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
+{ $heading "Choosing the right deploy flags" }
+"Finding the correct deploy flags is a trial and error process; you must find a tradeoff between deployed image size and correctness. If your program uses dynamic language features, you may need to elect to strip out fewer subsystems in order to have full functionality." ;
+
+ARTICLE: "tools.deploy" "Application deployment"
+"The stand-alone application deployment tool, implemented in the " { $vocab-link "tools.deploy" } " vocablary, compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
+$nl
+"Most of the time, the words in the " { $vocab-link "tools.deploy" } " vocabulary should not be used directly; instead, use " { $link "ui.tools.deploy" } "."
+$nl
"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
{ $subsection "prepare-deploy" }
-"Once the necessary deployment flags have been set, the application can be deployed:"
-{ $subsection deploy }
-{ $see-also "ui.tools.deploy" } ;
+{ $subsection "tools.deploy.usage" }
+{ $subsection "tools.deploy.impl" }
+{ $subsection "tools.deploy.caveats" } ;
ABOUT: "tools.deploy"
\r
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
\r
-[ ] [\r
- "tools.deploy.test.6" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.7" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.8" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.9" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.10" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.11" shake-and-bake\r
- run-temp-image\r
-] unit-test
\ No newline at end of file
+{\r
+ "tools.deploy.test.6"\r
+ "tools.deploy.test.7"\r
+ "tools.deploy.test.8"\r
+ "tools.deploy.test.9"\r
+ "tools.deploy.test.10"\r
+ "tools.deploy.test.11"\r
+ "tools.deploy.test.12"\r
+} [\r
+ [ ] swap [\r
+ shake-and-bake\r
+ run-temp-image\r
+ ] curry unit-test\r
+] each
\ No newline at end of file
run-file
] when ;
+: strip-call ( -- )
+ "call" vocab [
+ "Stripping stack effect checking from call( and execute(" show
+ "vocab:tools/deploy/shaker/strip-call.factor"
+ run-file
+ ] when ;
+
: strip-cocoa ( -- )
"cocoa" vocab [
"Stripping unused Cocoa methods" show
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
- recompile-hook
- update-tuples-hook
- remake-generics-hook
+ compiler-impl
definition-observers
definitions:crossref
interactive-vocabs
init-stripper
strip-default-methods
strip-libc
+ strip-call
strip-cocoa
strip-debugger
compute-next-methods
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: tools.deploy.shaker.call
+
+IN: call
+USE: call.private
+
+: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: call math.parser io math ;
+IN: tools.deploy.test.12
+
+: execute-test ( a b w -- c ) execute( a b -- c ) ;
+
+: foo ( -- ) 1 2 \ + execute-test number>string print ;
+
+MAIN: foo
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-unicode? f }
+ { deploy-io 2 }
+ { deploy-ui? f }
+ { deploy-name "tools.deploy.test.12" }
+ { deploy-compiler? f }
+ { deploy-word-defs? f }
+ { deploy-threads? f }
+}
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp kernel io ;
+IN: tools.deploy.test.13
+
+: regexp-test ( a -- b ) <regexp> "xyz" swap matches? ;
+
+: main ( -- ) "x.z" regexp-test "X" "Y" ? print ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { "stop-after-last-window?" t }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.13" }
+ { deploy-word-props? f }
+ { deploy-unicode? f }
+ { deploy-word-defs? f }
+ { deploy-reflection 4 }
+ { deploy-ui? f }
+}
IN: tools.deploy.unix
: create-app-dir ( vocab bundle-name -- vm )
- dup "" copy-fonts
+ dup "" copy-theme
copy-vm
dup OCT: 755 set-file-permissions ;
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.pathnames io.directories kernel namespaces
+USING: io io.files io.pathnames io.directories io.encodings.ascii kernel namespaces
sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables
prettyprint combinators windows.shell32 windows.user32 ;
: copy-dll ( bundle-name -- )
"resource:factor.dll" swap copy-file-into ;
-: copy-freetype ( bundle-name -- )
- {
- "resource:freetype6.dll"
- "resource:zlib1.dll"
- } swap copy-files-into ;
+: copy-pango ( bundle-name -- )
+ "resource:build-support/dlls.txt" ascii file-lines
+ [ "resource:" prepend-path ] map
+ swap copy-files-into ;
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
deploy-ui? get [
- [ copy-freetype ]
- [ "" copy-fonts ]
+ [ copy-pango ]
+ [ "" copy-theme ]
[ ".exe" copy-vm ] tri
] [ ".com" copy-vm ] if ;
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
- nl
+ nl nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
- ] tabular-output ;
+ ] tabular-output
+ nl ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
pick at pprint-cell
] with-row
] each 2drop
- ] tabular-output ;
+ ] tabular-output nl ;
profiler-usage counters ;
: counters. ( assoc -- )
- standard-table-style [
- sort-values simple-table.
- ] tabular-output ;
+ sort-values simple-table. ;
: profile. ( -- )
"Call counts for all words:" print
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit ;
+splitting ascii combinators.short-circuit alarms words.symbol ;
IN: tools.scaffold
SYMBOL: developer-name
{ "ch" "a character" }
{ "word" word }
{ "array" array }
+ { "alarm" alarm }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
: ($values.) ( array -- )
[
- " { " write
+ "{ " write
dup array? [ first ] when
dup lookup-type [
[ unparse write bl ]
] if
] when* ;
+: symbol-description. ( word -- )
+ drop
+ "{ $var-description \"\" } ;" print ;
+
: $description. ( word -- )
drop
"{ $description \"\" } ;" print ;
+: docs-body. ( word/symbol -- )
+ dup symbol? [
+ symbol-description.
+ ] [
+ [ $values. ] [ $description. ] bi
+ ] if ;
+
: docs-header. ( word -- )
"HELP: " write name>> print ;
: (help.) ( word -- )
- [ docs-header. ] [ $values. ] [ $description. ] tri ;
+ [ docs-header. ] [ docs-body. ] bi ;
: interesting-words ( vocab -- array )
words
threads >alist sort-keys values [\r
[ thread. ] with-row\r
] each\r
- ] tabular-output ;\r
+ ] tabular-output nl ;\r
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
: describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ;
+: files. ( seq -- )
+ snippet-style get [
+ code-style get [
+ [ nl ] [ [ string>> ] keep write-object ] interleave
+ ] with-nesting
+ ] with-style ;
+
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
- snippet-style get [
- code-style get [
- stack.
- ] with-nesting
- ] with-style
+ files.
] ($block)
] unless-empty ;
: words. ( vocab -- )
last-element off
- [ require ] [ words $words ] bi ;
+ [ require ] [ words $words ] bi nl ;
: describe-metadata ( vocab -- )
[
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences namespaces ui.gadgets.frames
+ui.pens.image ui.gadgets.icons ui.gadgets.grids ;
+IN: ui.gadgets.corners
+
+CONSTANT: @center { 1 1 }
+CONSTANT: @left { 0 1 }
+CONSTANT: @right { 2 1 }
+CONSTANT: @top { 1 0 }
+CONSTANT: @bottom { 1 2 }
+
+CONSTANT: @top-left { 0 0 }
+CONSTANT: @top-right { 2 0 }
+CONSTANT: @bottom-left { 0 2 }
+CONSTANT: @bottom-right { 2 2 }
+
+SYMBOL: name
+
+: corner-image ( name -- image )
+ [ name get "-" ] dip 3append theme-image ;
+
+: corner-icon ( name -- icon )
+ corner-image <icon> ;
+
+: /-----\ ( corner -- corner )
+ "top-left" corner-icon @top-left grid-add
+ "top-middle" corner-icon @top grid-add
+ "top-right" corner-icon @top-right grid-add ;
+
+: |-----| ( gadget corner -- corner )
+ "left-edge" corner-icon @left grid-add
+ swap @center grid-add
+ "right-edge" corner-icon @right grid-add ;
+
+: \-----/ ( corner -- corner )
+ "bottom-left" corner-icon @bottom-left grid-add
+ "bottom-middle" corner-icon @bottom grid-add
+ "bottom-right" corner-icon @bottom-right grid-add ;
+
+: make-corners ( class name quot -- corners )
+ [ [ [ 3 3 ] dip new-frame { 1 1 } >>filled-cell ] dip name ] dip
+ with-variable ; inline
\ No newline at end of file
--- /dev/null
+IN: ui.gadgets.glass
+USING: help.markup help.syntax ui.gadgets math.rectangles ;
+
+HELP: show-glass
+{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "."
+ $nl
+ "The child's position is calculated with a heuristic:"
+ { $list
+ "The child must fit inside the window"
+ { "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } }
+ { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+ }
+ "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
+
+HELP: hide-glass
+{ $values { "child" gadget } }
+{ $description "Hides a gadget displayed in a glass layer." } ;
+
+HELP: hide-glass-hook
+{ $values { "gadget" gadget } }
+{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ;
+
+HELP: pass-to-popup
+{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } }
+{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ;
+
+HELP: show-popup
+{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup."
+ $nl
+ "This word differs from " { $link show-glass } " in two respects:"
+ { $list
+ { "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" }
+ { "Pressing " { $snippet "ESC" } " with the popup visible will hide it" }
+ }
+} ;
+
+ARTICLE: "ui.gadgets.glass" "Glass layers"
+"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other."
+$nl
+"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "."
+$nl
+"Displaying a gadget in a glass layer:"
+{ $subsection show-glass }
+"Hiding a gadget in a glass layer:"
+{ $subsection hide-glass }
+"Callback generic invoked on the gadget when its glass layer is hidden:"
+{ $subsection hide-glass-hook }
+"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:"
+{ $subsection show-popup }
+{ $subsection pass-to-popup } ;
+
+ABOUT: "ui.gadgets.glass"
\ No newline at end of file
swap >>owner ; inline
M: popup hide-glass-hook
- owner>> f >>popup request-focus ;
+ dup owner>> 2dup popup>> eq?
+ [ f >>popup request-focus drop ] [ 2drop ] if ;
PRIVATE>
{ T{ key-down f f "ESC" } [ hide-glass ] }
} set-gestures
-: pass-to-popup ( gesture interactor -- ? )
+: pass-to-popup ( gesture owner -- ? )
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )
- [ <popup> ] dip
- [ drop dup owner>> (>>popup) ]
- [ [ [ owner>> ] keep ] dip show-glass ]
- 2bi ;
\ No newline at end of file
+ [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
+ [ drop >>popup drop ] [ show-glass ] 3bi ;
\ No newline at end of file
--- /dev/null
+IN: ui.gadgets.labeled.tests
+USING: ui.gadgets ui.gadgets.labeled accessors tools.test ;
+
+[ t ] [ <gadget> "Hey" <labeled-gadget> content>> gadget? ] unit-test
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences colors fonts ui.gadgets
ui.gadgets.frames ui.gadgets.grids ui.gadgets.icons ui.gadgets.labels
-ui.gadgets.borders ui.pens.image ;
+ui.gadgets.borders ui.pens.image ui.gadgets.corners ui.render ;
IN: ui.gadgets.labeled
TUPLE: labeled-gadget < frame content ;
<PRIVATE
-CONSTANT: @center { 1 1 }
-CONSTANT: @left { 0 1 }
-CONSTANT: @right { 2 1 }
-CONSTANT: @top { 1 0 }
-CONSTANT: @bottom { 1 2 }
-
-CONSTANT: @top-left { 0 0 }
-CONSTANT: @top-right { 2 0 }
-CONSTANT: @bottom-left { 0 2 }
-CONSTANT: @bottom-right { 2 2 }
-
-: labeled-image ( name -- image )
- "labeled-block-" prepend theme-image ;
-
-: labeled-icon ( name -- icon )
- labeled-image <icon> ;
-
-CONSTANT: labeled-title-background
- T{ rgba f
- 0.7843137254901961
- 0.7686274509803922
- 0.7176470588235294
- 1.0
- }
-
: <labeled-title> ( gadget -- label )
>label
- [ labeled-title-background font-with-background ] change-font
+ [ panel-background-color font-with-background ] change-font
{ 0 2 } <border>
- "title-middle" labeled-image
+ "title-middle" corner-image
<image-pen> t >>fill? >>interior ;
: /-FOO-\ ( title labeled -- labeled )
- "title-left" labeled-icon @top-left grid-add
+ "title-left" corner-icon @top-left grid-add
swap <labeled-title> @top grid-add
- "title-right" labeled-icon @top-right grid-add ;
-
-: |-----| ( gadget labeled -- labeled )
- "left-edge" labeled-icon @left grid-add
- swap [ >>content ] [ @center grid-add ] bi
- "right-edge" labeled-icon @right grid-add ;
-
-: \-----/ ( labeled -- labeled )
- "bottom-left" labeled-icon @bottom-left grid-add
- "bottom-middle" labeled-icon @bottom grid-add
- "bottom-right" labeled-icon @bottom-right grid-add ;
+ "title-right" corner-icon @top-right grid-add ;
M: labeled-gadget focusable-child* content>> ;
PRIVATE>
: <labeled-gadget> ( gadget title -- newgadget )
- 3 3 labeled-gadget new-frame
- { 1 1 } >>filled-cell
+ labeled-gadget "labeled-block" [
+ pick >>content
/-FOO-\
|-----|
- \-----/ ;
+ \-----/
+ ] make-corners ;
{ $notes "Useful for right-click context menus." } ;
ARTICLE: "ui.gadgets.menus" "Popup menus"
-"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "."
{ $subsection <commands-menu> }
{ $subsection show-menu }
{ $subsection show-commands-menu } ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: colors.constants kernel locals math.rectangles
-namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
-ui.gadgets.worlds ui.gestures ui.operations ui.pens ui.pens.solid
-opengl math.vectors words accessors math math.order sorting ;
+USING: colors.constants kernel locals math.rectangles namespaces
+sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
+ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations
+ui.render ui.pens ui.pens.solid opengl math.vectors words accessors
+math math.order sorting ;
IN: ui.gadgets.menus
: show-menu ( owner menu -- )
dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
[ [ >integer ] map ] bi@ gl-line ;
+: <menu-items> ( items -- gadget )
+ [ <filled-pile> ] dip add-gadgets
+ panel-background-color <solid> >>interior ;
+
PRIVATE>
SINGLETON: ----
: menu-theme ( gadget -- gadget )
COLOR: light-gray <solid> >>interior ;
+: <menu> ( gadgets -- menu )
+ <menu-items>
+ frame "menu-background" [
+ /-----\
+ |-----|
+ \-----/
+ ] make-corners ;
+
: <commands-menu> ( target hook commands -- menu )
- [ <filled-pile> ] 3dip
- [ <menu-item> add-gadget ] with with each
- { 5 5 } <border> menu-theme ;
+ [ <menu-item> ] with with map <menu> ;
: show-commands-menu ( target commands -- )
[ dup [ ] ] dip <commands-menu> show-menu ;
{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
{ $notes "Not all streams support this operation." } ;
-HELP: ?nl
-{ $values { "stream" pane-stream } }
-{ $description "Inserts a line break in the pane unless the current line is empty." } ;
-
HELP: with-pane
{ $values { "pane" pane } { "quot" quotation } }
{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting tools.test.ui models math summary
-inspector accessors help.topics ;
+inspector accessors help.topics see ;
IN: ui.gadgets.panes.tests
: #children "pane" get children>> length ;
: test-gadget-text ( quot -- ? )
dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+ swap with-string-writer dup print = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
] test-gadget-text
] unit-test
+[ t ] [
+ [
+ last-element off
+ \ = >link title-style get [
+ $navigation-table
+ ] with-nesting
+ "Hello world" print-content
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a\n" } } simple-table. ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a" } } simple-table. "x" write ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
+] unit-test
+
ARTICLE: "test-article-1" "This is a test article"
"Hello world, how are you today." ;
output current input last-line prototype scrolls?
selection-color caret mark selecting? ;
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+M: pane-stream stream-element-type drop +character+ ;
+
+<PRIVATE
+
: clear-selection ( pane -- pane )
f >>caret f >>mark ; inline
: init-current ( pane -- pane )
dup prototype>> clone >>current ; inline
+: focus-input ( pane -- )
+ input>> [ request-focus ] when* ;
+
: next-line ( pane -- )
clear-selection
[ input>> unparent ]
[ init-current prepare-last-line ]
- [ input>> [ request-focus ] when* ] tri ;
+ [ focus-input ] tri ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ; inline
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
-: pane-clear ( pane -- )
- clear-selection
- [ output>> clear-incremental ]
- [ current>> clear-gadget ]
- bi ;
-
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
selection-color >>selection-color ; inline
: init-last-line ( pane -- pane )
- horizontal <track>
+ horizontal <track> 0 >>fill +baseline+ >>align
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
-: new-pane ( input class -- pane )
- [ vertical ] dip new-track
- swap >>input
- pane-theme
- init-prototype
- init-output
- init-current
- init-last-line ; inline
-
-: <pane> ( -- pane ) f pane new-pane ;
-
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
dup gadget-selection? [
[ selection-color>> gl-color ]
[
- [ [ origin get ] dip loc>> v- ] keep selected-children
+ [ loc>> vneg ] keep selected-children
[ draw-selection ] with each
] bi
] [ drop ] if ;
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
: smash-line ( current -- gadget )
dup children>> {
{ [ dup empty? ] [ 2drop "" <label> ] }
[ drop ]
} cond ;
-: smash-pane ( pane -- gadget ) output>> smash-line ;
-
: pane-nl ( pane -- )
[
[ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
add-incremental
] [ next-line ] bi ;
+: ?pane-nl ( pane -- )
+ [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
+ [ pane-nl ] bi ;
+
+: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
+
: pane-write ( seq pane -- )
[ pane-nl ] [ current>> stream-write ]
bi-curry interleave ;
[ nip pane-nl ] [ current>> stream-format ]
bi-curry bi-curry interleave ;
+: do-pane-stream ( pane-stream quot -- )
+ [ pane>> ] dip keep scroll-pane ; inline
+
+M: pane-stream stream-nl
+ [ pane-nl ] do-pane-stream ;
+
+M: pane-stream stream-write1
+ [ current>> stream-write1 ] do-pane-stream ;
+
+M: pane-stream stream-write
+ [ [ string-lines ] dip pane-write ] do-pane-stream ;
+
+M: pane-stream stream-format
+ [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
+
+M: pane-stream dispose drop ;
+
+M: pane-stream stream-flush drop ;
+
+M: pane-stream make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+PRIVATE>
+
+: new-pane ( input class -- pane )
+ [ vertical ] dip new-track
+ swap >>input
+ pane-theme
+ init-prototype
+ init-output
+ init-current
+ init-last-line ; inline
+
+: <pane> ( -- pane ) f pane new-pane ;
+
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- )
: gadget. ( gadget -- )
output-stream get print-gadget ;
-: ?nl ( stream -- )
- dup pane>> current>> children>> empty?
- [ dup stream-nl ] unless drop ;
+: pane-clear ( pane -- )
+ clear-selection
+ [ output>> clear-incremental ]
+ [ current>> clear-gadget ]
+ bi ;
: with-pane ( pane quot -- )
- over scroll>top
- over pane-clear [ <pane-stream> ] dip
- over [ with-output-stream* ] dip ?nl ; inline
+ [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
+ with-output-stream* ; inline
: make-pane ( quot -- gadget )
- <pane> [ swap with-pane ] keep smash-pane ; inline
+ [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
TUPLE: pane-control < pane quot ;
swap >>quot
swap >>model ;
-: do-pane-stream ( pane-stream quot -- )
- [ pane>> ] dip keep scroll-pane ; inline
-
-M: pane-stream stream-nl
- [ pane-nl ] do-pane-stream ;
-
-M: pane-stream stream-write1
- [ current>> stream-write1 ] do-pane-stream ;
-
-M: pane-stream stream-write
- [ [ string-lines ] dip pane-write ] do-pane-stream ;
-
-M: pane-stream stream-format
- [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
-
-M: pane-stream dispose drop ;
-
-M: pane-stream stream-flush drop ;
-
-M: pane-stream make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
! Character styles
+<PRIVATE
MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
inline
: unnest-pane-stream ( stream -- child parent )
- dup ?nl
- dup style>>
- over pane>> smash-pane style-pane
- swap parent>> ;
+ [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
TUPLE: pane-block-stream < nested-pane-stream ;
TUPLE: pane-cell-stream < nested-pane-stream ;
-M: pane-cell-stream dispose ?nl ;
+M: pane-cell-stream dispose drop ;
M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
- ] dip print-gadget ;
+ ] dip write-gadget ;
! Stream utilities
M: pack dispose drop ;
interleave
] if ;
-: caret>mark ( pane -- pane )
- dup caret>> >>mark
- dup relayout-1 ;
+: caret>mark ( pane -- )
+ dup caret>> >>mark relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n )
[ 3drop { } ]
if ;
-: move-caret ( pane loc -- pane )
+: move-caret ( pane loc -- )
over screen-loc v- over sloppy-pick-up >>caret
- dup relayout-1 ;
+ relayout-1 ;
: begin-selection ( pane -- )
f >>selecting?
- hand-loc get move-caret
+ dup hand-loc get move-caret
f >>mark
drop ;
: extend-selection ( pane -- )
hand-moved? [
- dup selecting?>> [
- hand-loc get move-caret
- ] [
- dup hand-clicked get child? [
- t >>selecting?
- dup hand-clicked set-global
- hand-click-loc get move-caret
- caret>mark
- ] when
- ] if
- dup dup caret>> gadget-at-path scroll>gadget
- ] when drop ;
+ [
+ dup selecting?>> [
+ hand-loc get move-caret
+ ] [
+ dup hand-clicked get child? [
+ t >>selecting?
+ [ hand-clicked set-global ]
+ [ hand-click-loc get move-caret ]
+ [ caret>mark ]
+ tri
+ ] [ drop ] if
+ ] if
+ ] [ dup caret>> gadget-at-path scroll>gadget ] bi
+ ] [ drop ] if ;
: end-selection ( pane -- )
f >>selecting?
- hand-moved? [
- [ com-copy-selection ] [ request-focus ] bi
- ] [
- relayout-1
- ] if ;
+ hand-moved?
+ [ [ com-copy-selection ] [ request-focus ] bi ]
+ [ [ relayout-1 ] [ focus-input ] bi ]
+ if ;
: select-to-caret ( pane -- )
t >>selecting?
- dup mark>> [ caret>mark ] unless
- hand-loc get move-caret
- dup request-focus
- com-copy-selection ;
+ [ dup mark>> [ dup caret>mark ] unless hand-loc get move-caret ]
+ [ com-copy-selection ]
+ [ request-focus ]
+ tri ;
: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
+PRIVATE>
+
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
IN: ui.gadgets.status-bar
HELP: show-status
-{ $values { "string" string } { "gadget" gadget } }
+{ $values { "string/f" string } { "gadget" gadget } }
{ $description "Displays a status message in the gadget's world." }
{ $notes "The status message will only be visible if the window was opened with " { $link open-status-window } ", and not " { $link open-window } "." } ;
M: object modifiers>string
[ name>> ] map "" join ;
+HOOK: keysym>string os ( keysym -- string )
+
+M: macosx keysym>string >upper ;
+
+M: object keysym>string ;
+
M: key-down gesture>string
[ mods>> ] [ sym>> ] bi
{
{ [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
{ [ dup " " = ] [ drop "SPACE" ] }
- [ >upper ]
+ [ keysym>string ]
} cond
[ modifiers>string ] dip append ;
[ last-vertices>> gl-vertex-pointer ]
[ last-colors>> gl-color-pointer ]
[ colors>> draw-gradient ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
+
+M: gradient pen-background 2drop transparent ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors help.markup help.syntax kernel opengl
-opengl.gl sequences specialized-arrays.float ui.pens ;
+opengl.gl sequences specialized-arrays.float math.vectors
+ui.gadgets ui.pens ;
IN: ui.pens.polygon
! Polygon pen
[ color>> gl-color ]
[ interior-vertices>> gl-vertex-pointer ]
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
- tri ;
\ No newline at end of file
+ tri ;
+
+: <polygon-gadget> ( color points -- gadget )
+ [ <polygon> ] [ { 0 0 } [ vmax ] reduce ] bi
+ [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors opengl ui.pens ui.pens.caching ;
+USING: kernel accessors opengl math colors ui.pens ui.pens.caching ;
IN: ui.pens.solid
TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
(gl-rect) ;
M: solid pen-background
- nip color>> ;
\ No newline at end of file
+ nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;
\ No newline at end of file
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
+CONSTANT: panel-background-color
+ T{ rgba f
+ 0.7843137254901961
+ 0.7686274509803922
+ 0.7176470588235294
+ 1.0
+ }
+
CONSTANT: focus-border-color COLOR: dark-gray
[ [ raise-window ] [ gadget-child show-help ] bi ]
[ (browser-window) ] if* ;
-: show-browser ( -- ) "handbook" com-browse ;
+: show-browser ( -- )
+ [ browser-gadget? ] find-window
+ [ raise-window ] [ browser-window ] if* ;
\ show-browser H{ { +nullary+ t } } define-command
[
[
[ "Class:" write ] with-cell
- [ class . ] with-cell
+ [ class pprint ] with-cell
] with-row
]
[
[
[ "Object:" write ] with-cell
- [ short. ] with-cell
+ [ pprint-short ] with-cell
] with-row
]
[
[
[ "Summary:" write ] with-cell
- [ summary. ] with-cell
+ [ print-summary ] with-cell
] with-row
] tri
] tabular-output
! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test
- [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
[ ] [ "hi" "interactor" get set-editor-string ] unit-test
- [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test
[ 2drop ] [ [ value>> ] dip show-summary ] if
] [ call-next-method ] if ;
+M: interactor stream-element-type drop +character+ ;
+
GENERIC: (print-input) ( object -- )
M: input (print-input)
[ listener-gadget? ] find-parent ;
: listener-streams ( listener -- input output )
- [ input>> ] [ output>> ] bi <pane-stream> ;
+ [ input>> ] [ output>> <pane-stream> ] bi ;
: init-listener ( listener -- listener )
<interactor>
USING: kernel quotations accessors fry assocs present math.order
math.vectors arrays locals models.search models.sort models sequences
vocabs tools.profiler words prettyprint combinators.smart
-definitions.icons ui ui.commands ui.gadgets ui.gadgets.panes
+definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
USING: editors help.markup help.syntax summary inspector io io.styles
listener parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.panes ui.gadgets.presentations ui.operations
-ui.tools.operations ui.tools.profiler ui.tools.common vocabs ;
+ui.tools.operations ui.tools.profiler ui.tools.common vocabs see ;
IN: ui.tools
ARTICLE: "starting-ui-tools" "Starting the UI tools"
{ $subsection "ui-frame-layout" }
{ $subsection "ui-book-layout" }
"Advanced topics:"
+{ $subsection "ui.gadgets.glass" }
{ $subsection "ui-null-layout" }
{ $subsection "ui-incremental-layout" }
{ $subsection "ui-layout-impl" }
grapheme-break-test parse-test-file [ >graphemes ] test
word-break-test parse-test-file [ >words ] test
+
+[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test
: >words ( str -- words )
[ first-word ] >pieces ;
+
+<PRIVATE
+
+: nth-next ( i str -- str[i-1] str[i] )
+ [ [ 1- ] keep ] dip '[ _ nth ] bi@ ;
+
+PRIVATE>
+
+: word-break-at? ( i str -- ? )
+ {
+ [ drop zero? ]
+ [ length = ]
+ [
+ [ nth-next [ word-break-prop ] dip ] 2keep
+ word-break-next nip
+ ]
+ } 2|| ;
USING: alien.syntax ;
IN: unix
-: FD_SETSIZE 1024 ;
+CONSTANT: FD_SETSIZE 1024
C-STRUCT: addrinfo
{ "int" "flags" }
USING: help.markup help.syntax io.streams.string quotations
-strings math regexp regexp.backend ;
+strings math regexp ;
IN: validators
HELP: v-checkbox
{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;\r
\r
HELP: &com-release\r
-{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
+{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ;\r
\r
HELP: |com-release\r
-{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
+{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;\r
\r
{ com-release &com-release |com-release } related-words\r
{ "gl" "opengl32.dll" "stdcall" }
{ "glu" "glu32.dll" "stdcall" }
{ "ole32" "ole32.dll" "stdcall" }
+ { "usp10" "usp10.dll" "stdcall" }
} [ first3 add-library ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax ;
+IN: windows.usp10
+
+LIBRARY: usp10
+
+C-STRUCT: SCRIPT_CONTROL
+ { "DWORD" "flags" } ;
+
+C-STRUCT: SCRIPT_STATE
+ { "WORD" "flags" } ;
+
+C-STRUCT: SCRIPT_ANALYSIS
+ { "WORD" "flags" }
+ { "SCRIPT_STATE" "s" } ;
+
+C-STRUCT: SCRIPT_ITEM
+ { "int" "iCharPos" }
+ { "SCRIPT_ANALYSIS" "a" } ;
+
+FUNCTION: HRESULT ScriptItemize (
+ WCHAR* pwcInChars,
+ int cInChars,
+ int cMaxItems,
+ SCRIPT_CONTROL* psControl,
+ SCRIPT_STATE* psState,
+ SCRIPT_ITEM* pItems,
+ int* pcItems
+) ;
+
+FUNCTION: HRESULT ScriptLayout (
+ int cRuns,
+ BYTE* pbLevel,
+ int* piVisualToLogical,
+ int* piLogicalToVisual
+) ;
+
+C-ENUM: SCRIPT_JUSTIFY_NONE
+SCRIPT_JUSTIFY_ARABIC_BLANK
+SCRIPT_JUSTIFY_CHARACTER
+SCRIPT_JUSTIFY_RESERVED1
+SCRIPT_JUSTIFY_BLANK
+SCRIPT_JUSTIFY_RESERVED2
+SCRIPT_JUSTIFY_RESERVED3
+SCRIPT_JUSTIFY_ARABIC_NORMAL
+SCRIPT_JUSTIFY_ARABIC_KASHIDA
+SCRIPT_JUSTIFY_ALEF
+SCRIPT_JUSTIFY_HA
+SCRIPT_JUSTIFY_RA
+SCRIPT_JUSTIFY_BA
+SCRIPT_JUSTIFY_BARA
+SCRIPT_JUSTIFY_SEEN
+SCRIPT_JUSTIFFY_RESERVED4 ;
+
+C-STRUCT: SCRIPT_VISATTR
+ { "WORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptShape (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WCHAR* pwcChars,
+ int cChars,
+ int cMaxGlyphs,
+ SCRIPT_ANALYSIS* psa,
+ WORD* pwOutGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* pcGlyphs
+) ;
+
+C-STRUCT: GOFFSET
+ { "LONG" "du" }
+ { "LONG" "dv" } ;
+
+FUNCTION: HRESULT ScriptPlace (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WORD* pwGlyphs,
+ int cGlyphs,
+ SCRIPT_VISATTR* psva,
+ SCRIPT_ANALYSIS* psa,
+ int* piAdvance,
+ GOFFSET* pGoffset,
+ ABC* pABC
+) ;
+
+FUNCTION: HRESULT ScriptTextOut (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ int x,
+ int y,
+ UINT fuOptions,
+ RECT* lprc,
+ SCRIPT_ANALYSIS* psa,
+ WCHAR* pwcReserved,
+ int iReserved,
+ WORD* pwGlyphs,
+ int cGlyphs,
+ int* piAdvance,
+ int* piJustify,
+ GOFFSET* pGoffset
+) ;
+
+FUNCTION: HRESULT ScriptJustify (
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ int cGlyphs,
+ int iDx,
+ int iMinKashida,
+ int* piJustify
+) ;
+
+C-STRUCT: SCRIPT_LOGATTR
+ { "BYTE" "flags" } ;
+
+FUNCTION: HRESULT ScriptBreak (
+ WCHAR* pwcChars,
+ int cChars,
+ SCRIPT_ANALYSIS* psa,
+ SCRIPT_LOGATTR* psla
+) ;
+
+FUNCTION: HRESULT ScriptCPtoX (
+ int iCP,
+ BOOL fTrailing,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ int* piX
+) ;
+
+FUNCTION: HRESULT ScriptXtoCP (
+ int iCP,
+ BOOL fTrailing,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ int* piCP,
+ int* piTrailing
+) ;
+
+FUNCTION: HRESULT ScriptGetLogicalWidths (
+ SCRIPT_ANALYSIS* psa,
+ int cChars,
+ int cGlyphs,
+ int* piGlyphWidth,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piDx
+) ;
+
+FUNCTION: HRESULT ScriptApplyLogicalWidth (
+ int* piDx,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ ABC* pABC,
+ int* piJustify
+) ;
+
+FUNCTION: HRESULT ScriptGetCMap (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WCHAR* pwcInChars,
+ int cChars,
+ DWORD dwFlags,
+ WORD* pwOutGlyphs
+) ;
+
+FUNCTION: HRESULT ScriptGetGlyphABCWidth (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WORD wGlyph,
+ ABC* pABC
+) ;
+
+C-STRUCT: SCRIPT_PROPERTIES
+ { "DWORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptGetProperties (
+ SCRIPT_PROPERTIES*** ppSp,
+ int* piNumScripts
+) ;
+
+C-STRUCT: SCRIPT_FONTPROPERTIES
+ { "int" "cBytes" }
+ { "WORD" "wgBlank" }
+ { "WORD" "wgDefault" }
+ { "WORD" "wgInvalid" }
+ { "WORD" "wgKashida" }
+ { "int" "iKashidaWidth" } ;
+
+FUNCTION: HRESULT ScriptGetFontProperties (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ SCRIPT_FONTPROPERTIES* sfp
+) ;
+
+FUNCTION: HRESULT ScriptCacheGetHeight (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ long* tmHeight
+) ;
+
+CONSTANT: SSA_PASSWORD HEX: 00000001
+CONSTANT: SSA_TAB HEX: 00000002
+CONSTANT: SSA_CLIP HEX: 00000004
+CONSTANT: SSA_FIT HEX: 00000008
+CONSTANT: SSA_DZWG HEX: 00000010
+CONSTANT: SSA_FALLBACK HEX: 00000020
+CONSTANT: SSA_BREAK HEX: 00000040
+CONSTANT: SSA_GLYPHS HEX: 00000080
+CONSTANT: SSA_RTL HEX: 00000100
+CONSTANT: SSA_GCP HEX: 00000200
+CONSTANT: SSA_HOTKEY HEX: 00000400
+CONSTANT: SSA_METAFILE HEX: 00000800
+CONSTANT: SSA_LINK HEX: 00001000
+CONSTANT: SSA_HIDEHOTKEY HEX: 00002000
+CONSTANT: SSA_HOTKEYONLY HEX: 00002400
+CONSTANT: SSA_FULLMEASURE HEX: 04000000
+CONSTANT: SSA_LPKANSIFALLBACK HEX: 08000000
+CONSTANT: SSA_PIDX HEX: 10000000
+CONSTANT: SSA_LAYOUTRTL HEX: 20000000
+CONSTANT: SSA_DONTGLYPH HEX: 40000000
+CONSTANT: SSA_NOKASHIDA HEX: 80000000
+
+C-STRUCT: SCRIPT_TABDEF
+ { "int" "cTabStops" }
+ { "int" "iScale" }
+ { "int*" "pTabStops" }
+ { "int" "iTabOrigin" } ;
+
+TYPEDEF: void* SCRIPT_STRING_ANALYSIS
+
+FUNCTION: HRESULT ScriptStringAnalyse (
+ HDC hdc,
+ void* pString,
+ int cString,
+ int cGlyphs,
+ int iCharset,
+ DWORD dwFlags,
+ int iReqWidth,
+ SCRIPT_CONTROL* psControl,
+ SCRIPT_STATE* psState,
+ int* piDx,
+ SCRIPT_TABDEF* pTabDef,
+ BYTE* pbInClass,
+ SCRIPT_STRING_ANALYSIS* pssa
+) ;
+
+FUNCTION: HRESULT ScriptStringFree (
+ SCRIPT_STRING_ANALYSIS* pssa
+) ;
+
+FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: SCRIPT_LOGATTR* ScriptString_pLogAttr ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: HRESULT ScriptStringGetOrder (
+ SCRIPT_STRING_ANALYSIS ssa,
+ UINT* puOrder
+) ;
+
+FUNCTION: HRESULT ScriptStringCPtoX (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int icp,
+ BOOL fTrailing,
+ int* pX
+) ;
+
+FUNCTION: HRESULT ScriptStringXtoCP (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int iX,
+ int* piCh,
+ int* piTrailing
+) ;
+
+FUNCTION: HRESULT ScriptStringGetLogicalWidths (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int* piDx
+) ;
+
+FUNCTION: HRESULT ScriptStringValidate (
+ SCRIPT_STRING_ANALYSIS ssa
+) ;
+
+FUNCTION: HRESULT ScriptStringOut (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int iX,
+ int iY,
+ UINT uOptions,
+ RECT* prc,
+ int iMinSel,
+ int iMaxSel,
+ BOOL fDisabled
+) ;
+
+CONSTANT: SIC_COMPLEX 1
+CONSTANT: SIC_ASCIIDIGIT 2
+CONSTANT: SIC_NEUTRAL 4
+
+FUNCTION: HRESULT ScriptIsComplex (
+ WCHAR* pwcInChars,
+ int cInChars,
+ DWORD dwFlags
+) ;
+
+C-STRUCT: SCRIPT_DIGITSUBSTITUTE
+ { "DWORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptRecordDigitSubstitution (
+ LCID Locale,
+ SCRIPT_DIGITSUBSTITUTE* psds
+) ;
+
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_CONTEXT 0
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_NONE 1
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_NATIONAL 2
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_TRADITIONAL 3
+
+FUNCTION: HRESULT ScriptApplyDigitSubstitution (
+ SCRIPT_DIGITSUBSTITUTE* psds,
+ SCRIPT_CONTROL* psc,
+ SCRIPT_STATE* pss
+) ;
\ No newline at end of file
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors xml.data ;
+words globs combinators io.encodings.utf8 sorting accessors xml.data
+xml.traversal xml.syntax ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
-<TAGS: parse-mode-tag ( modes tag -- )
+TAGS: parse-mode-tag ( modes tag -- )
-TAG: MODE
+TAG: MODE parse-mode-tag
dup "NAME" attr [
mode new {
{ "FILE" f (>>file) }
] dip
rot set-at ;
-TAGS>
-
: parse-modes-tag ( tag -- modes )
H{ } clone [
- swap child-tags [ parse-mode-tag ] with each
+ swap children-tags [ parse-mode-tag ] with each
] keep ;
MEMO: modes ( -- modes )
] if ;
: finalize-mode ( rulesets -- )
- rule-sets [
- dup [ nip finalize-rule-set ] assoc-each
+ dup rule-sets [
+ [ nip finalize-rule-set ] assoc-each
] with-variable ;
: load-mode ( name -- rule-sets )
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
+\ htmlize-file must-infer
+
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.traversal xml assocs kernel
combinators sequences math.parser namespaces parser
-xmode.utilities parser-combinators.regexp io.files accessors ;
+xmode.utilities regexp io.files accessors xml.syntax ;
IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
-<TAGS: parse-rule-tag ( rule-set tag -- )
+TAGS: parse-rule-tag ( rule-set tag -- )
-TAG: PROPS
+TAG: PROPS parse-rule-tag
parse-props-tag >>props drop ;
-TAG: IMPORT
+TAG: IMPORT parse-rule-tag
"DELEGATE" attr swap import-rule-set ;
-TAG: TERMINATE
+TAG: TERMINATE parse-rule-tag
"AT_CHAR" attr string>number >>terminate-char drop ;
-RULE: SEQ seq-rule
+RULE: SEQ seq-rule parse-rule-tag
shared-tag-attrs delegate-attr literal-start ;
-RULE: SEQ_REGEXP seq-rule
+RULE: SEQ_REGEXP seq-rule parse-rule-tag
shared-tag-attrs delegate-attr regexp-attr regexp-start ;
-RULE: SPAN span-rule
+RULE: SPAN span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ;
-RULE: SPAN_REGEXP span-rule
+RULE: SPAN_REGEXP span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr span-attrs regexp-attr parse-begin/end-tags init-span-tag ;
-RULE: EOL_SPAN eol-span-rule
+RULE: EOL_SPAN eol-span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr literal-start init-eol-span-tag ;
-RULE: EOL_SPAN_REGEXP eol-span-rule
+RULE: EOL_SPAN_REGEXP eol-span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr regexp-attr regexp-start init-eol-span-tag ;
-RULE: MARK_FOLLOWING mark-following-rule
+RULE: MARK_FOLLOWING mark-following-rule parse-rule-tag
shared-tag-attrs match-type-attr literal-start ;
-RULE: MARK_PREVIOUS mark-previous-rule
+RULE: MARK_PREVIOUS mark-previous-rule parse-rule-tag
shared-tag-attrs match-type-attr literal-start ;
-TAG: KEYWORDS ( rule-set tag -- key value )
+TAG: KEYWORDS parse-rule-tag
rule-set get ignore-case?>> <keyword-map>
- swap child-tags [ over parse-keyword-tag ] each
+ swap children-tags [ over parse-keyword-tag ] each
swap (>>keywords) ;
-TAGS>
-
: ?<regexp> ( string/f -- regexp/f )
- dup [ rule-set get ignore-case?>> <regexp> ] when ;
+ dup [ rule-set get ignore-case?>> <?insensitive-regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set> dup rule-set set
: parse-rules-tag ( tag -- rule-set )
[
- [ (parse-rules-tag) ] [ child-tags ] bi
+ [ (parse-rules-tag) ] [ children-tags ] bi
[ parse-rule-tag ] with each
rule-set get
] with-scope ;
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.traversal xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities
-parser-combinators.regexp io.files splitting arrays ;
+regexp io.files splitting arrays xml.syntax xml.syntax.private ;
IN: xmode.loader.syntax
! Rule tag parsing utilities
new swap init-from-tag swap add-rule ; inline
: RULE:
- scan scan-word
- parse-definition { } make
- swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
+ scan scan-word scan-word [
+ parse-definition { } make
+ swap [ (parse-rule-tag) ] 2curry
+ ] dip swap define-tag ; parsing
! Attribute utilities
: string>boolean ( string -- ? ) "TRUE" = ;
[ "NAME" attr ] [ "VALUE" attr ] bi ;
: parse-props-tag ( tag -- assoc )
- child-tags
+ children-tags
[ parse-prop-tag ] H{ } map>assoc ;
: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher )
- dup children>string rule-set get ignore-case?>> <regexp>
+ dup children>string
+ rule-set get ignore-case?>> <?insensitive-regexp>
swap position-attrs <matcher> ;
: shared-tag-attrs ( -- )
[ parse-literal-matcher >>end drop ] , ;
! SPAN's children
-<TAGS: parse-begin/end-tag ( rule tag -- )
+TAGS: parse-begin/end-tag ( rule tag -- )
-TAG: BEGIN
+TAG: BEGIN parse-begin/end-tag
! XXX
parse-literal-matcher >>start drop ;
-TAG: END
+TAG: END parse-begin/end-tag
! XXX
parse-literal-matcher >>end drop ;
-TAGS>
-
: parse-begin/end-tags ( -- )
[
! XXX: handle position attrs on span tag itself
- child-tags [ parse-begin/end-tag ] with each
+ children-tags [ parse-begin/end-tag ] with each
] , ;
: init-span-tag ( -- ) [ drop init-span ] , ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: xmode.marker
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
-parser-combinators.regexp splitting parser-combinators ascii
-ascii combinators.short-circuit accessors ;
+regexp splitting unicode.case ascii
+combinators.short-circuit accessors ;
+IN: xmode.marker
+
+! Next two words copied from parser-combinators
+! Just like head?, but they optionally ignore case
+
+: string= ( str1 str2 ignore-case -- ? )
+ [ [ >upper ] bi@ ] when sequence= ;
+
+: string-head? ( str1 str2 ignore-case -- ? )
+ 2over shorter?
+ [ 3drop f ] [
+ [
+ [ nip ]
+ [ length head-slice ] 2bi
+ ] dip string=
+ ] if ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
] keep string>> length and ;
M: regexp text-matches?
- [ >string ] dip match-head ;
+ [ >string ] dip re-contains? ;
: rule-start-matches? ( rule -- match-count/f )
dup start>> tuck swap can-match-here? [
process-escape? get [
escaped? [ not ] change
position [ + ] change
- ] [ 2drop ] if ;
+ ] [ drop ] if ;
M: seq-rule handle-rule-start
?end-rule
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize unicode.case
-parser-combinators.regexp ;
+regexp ;
IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;
+USING: assocs xmode.utilities tools.test ;
IN: xmode.utilities.tests
-USING: accessors xmode.utilities tools.test xml xml.data kernel
-strings vectors sequences io.files prettyprint assocs
-unicode.case ;
-
-TUPLE: company employees type ;
-
-: <company> V{ } clone f company boa ;
-
-: add-employee employees>> push ;
-
-<TAGS: parse-employee-tag
-
-TUPLE: employee name description ;
-
-TAG: employee
- employee new
- { { "name" f (>>name) } { f (>>description) } }
- init-from-tag swap add-employee ;
-
-TAGS>
-
-\ parse-employee-tag see
-
-: parse-company-tag
- [
- <company>
- { { "type" >upper (>>type) } }
- init-from-tag dup
- ] keep
- children>> [ tag? ] filter
- [ parse-employee-tag ] with each ;
-
-[
- T{ company f
- V{
- T{ employee f "Joe" "VP Sales" }
- T{ employee f "Jane" "CFO" }
- }
- "PUBLIC"
- }
-] [
- "vocab:xmode/utilities/test.xml"
- file>xml parse-company-tag
-] unit-test
USING: accessors sequences assocs kernel quotations namespaces
-xml.data xml.traversal combinators macros parser lexer words fry ;
+xml.data xml.traversal combinators macros parser lexer words fry
+regexp ;
IN: xmode.utilities
: implies ( x y -- z ) [ not ] dip or ; inline
-: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
-
: tag-init-form ( spec -- quot )
{
{ [ dup quotation? ] [ [ object get tag get ] prepose ] }
: init-from-tag ( tag tuple specs -- tuple )
over [ (init-from-tag) ] dip ; inline
-SYMBOL: tag-handlers
-SYMBOL: tag-handler-word
-
-: <TAGS:
- CREATE tag-handler-word set
- H{ } clone tag-handlers set ; parsing
-
-: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
-
-: TAG:
- scan parse-definition
- (TAG:) ; parsing
-
-: TAGS>
- tag-handler-word get
- tag-handlers get >alist [ [ dup main>> ] dip case ] curry
- define ; parsing
+: <?insensitive-regexp> ( string ? -- regexp )
+ "i" "" ? <optioned-regexp> ;
--- /dev/null
+libcairo-2.dll
+libgio-2.0-0.dll
+libglib-2.0-0.dll
+libgmodule-2.0-0.dll
+libgobject-2.0-0.dll
+libgthread-2.0-0.dll
+libpango-1.0-0.dll
+libpangocairo-1.0-0.dll
+libpangowin32-1.0-0.dll
+libpng12-0.dll
+libtiff3.dll
+zlib1.dll
maybe_download_dlls() {
if [[ $OS == winnt ]] ; then
- get_url http://factorcode.org/dlls/freetype6.dll
- get_url http://factorcode.org/dlls/zlib1.dll
- get_url http://factorcode.org/dlls/OpenAL32.dll
- get_url http://factorcode.org/dlls/alut.dll
- get_url http://factorcode.org/dlls/comerr32.dll
- get_url http://factorcode.org/dlls/gssapi32.dll
- get_url http://factorcode.org/dlls/iconv.dll
- get_url http://factorcode.org/dlls/k5sprt32.dll
- get_url http://factorcode.org/dlls/krb5_32.dll
- get_url http://factorcode.org/dlls/libcairo-2.dll
- get_url http://factorcode.org/dlls/libeay32.dll
- get_url http://factorcode.org/dlls/libiconv2.dll
- get_url http://factorcode.org/dlls/libintl3.dll
- get_url http://factorcode.org/dlls/libpq.dll
- get_url http://factorcode.org/dlls/libxml2.dll
- get_url http://factorcode.org/dlls/libxslt.dll
- get_url http://factorcode.org/dlls/msvcr71.dll
- get_url http://factorcode.org/dlls/ogg.dll
- get_url http://factorcode.org/dlls/pgaevent.dll
- get_url http://factorcode.org/dlls/sqlite3.dll
- get_url http://factorcode.org/dlls/ssleay32.dll
- get_url http://factorcode.org/dlls/theora.dll
- get_url http://factorcode.org/dlls/vorbis.dll
- chmod 777 *.dll
- check_ret chmod
+ for file in `cat build-support/dlls.txt`; do
+ get_url http://factorcode.org/dlls/$file
+ chmod 777 *.dll
+ check_ret chmod
+ done
fi
}
}
install_build_system_apt() {
- sudo apt-get --yes install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libpango-1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
M: assoc assoc-like drop ;
: ?at ( key assoc -- value/key ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ; inline
+ 2dup at* [ 2nip t ] [ 2drop f ] if ; inline
<PRIVATE
: substituter ( assoc -- quot )
[ ?at drop ] curry ; inline
-: with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) )
+: with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
curry [ swap ] prepose ; inline
PRIVATE>
{ "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
-} at "/bootstrap.factor" 3append parse-file
+} ?at [ "Bad architecture: " prepend throw ] unless
+"/bootstrap.factor" 3append parse-file
"vocab:bootstrap/layouts/layouts.factor" parse-file
dictionary
new-classes
changed-definitions changed-generics
- remake-generics forgotten-definitions
+ outdated-generics forgotten-definitions
root-cache source-files update-map implementors-map
} [ H{ } clone swap set ] each
! Vocabulary for slot accessors
"accessors" create-vocab drop
-! Trivial recompile hook. We don't want to touch the code heap
-! during stage1 bootstrap, it would just waste time.
-[ drop { } ] recompile-hook set
+dummy-compiler compiler-impl set
call
call
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate forget*
+ [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
+
M: predicate reset-word
- [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+ [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
: define-predicate ( class quot -- )
[ "predicate" word-prop first ] dip
MIXIN: empty-mixin
[ f ] [ "hi" empty-mixin? ] unit-test
+
+MIXIN: move-instance-declaration-mixin
+
+[ ] [ "IN: classes.mixin.tests.a USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
+
+[ ] [ "IN: classes.mixin.tests.b USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-2" parse-stream drop ] unit-test
+
+[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
+
+[ { string } ] [ move-instance-declaration-mixin members ] unit-test
\ No newline at end of file
-USING: math tools.test classes.algebra ;
+USING: math tools.test classes.algebra words kernel sequences assocs ;
IN: classes.predicate
PREDICATE: negative < integer 0 < ;
[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
[ 0 ] [ 0 abs ] unit-test
+
+PREDICATE: blah < word blah eq? ;
+
+[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test
+
+FORGET: blah
\ No newline at end of file
: predicate-quot ( class -- quot )
[
\ dup ,
- dup superclass "predicate" word-prop %
- "predicate-definition" word-prop , [ drop f ] , \ if ,
+ [ superclass "predicate" word-prop % ]
+ [ "predicate-definition" word-prop , ] bi
+ [ drop f ] , \ if ,
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
update-predicate-instance ;
M: predicate-class reset-class
- [ call-next-method ]
- [ { "predicate-definition" } reset-props ]
- bi ;
+ [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
+ update-predicate-instance ;
M: predicate-class rank-class drop 1 ;
-USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
+USING: kernel classes.singleton tools.test prettyprint io.streams.string see ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval ;
+columns math.order classes.private slots slots.private eval see ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
namespaces make sequences sequences.private strings vectors
words quotations memory combinators generic classes
classes.algebra classes.builtin classes.private slots.private
-slots compiler.units math.private accessors assocs effects ;
+slots math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
: apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ;
+SYMBOL: outdated-tuples
+
: permute-slots ( old-values layout -- new-values )
[ first all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
dup [ update-tuple ] map become
] if ;
-[ update-tuples ] update-tuples-hook set-global
-
: update-tuples-after ( class -- )
[ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string
-eval ;
+eval see ;
IN: classes.union.tests
! DEFER: bah
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
+[ t ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
+[ f ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
GENERIC: test-generic ( x -- y )
TUPLE: a-tuple ;
"Forward reference checking (see " { $link "definition-checking" } "):"
{ $subsection forward-reference? }
"A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":"
-{ $subsection recompile-hook }
+{ $subsection recompile }
"Low-level compiler interface exported by the Factor VM:"
{ $subsection modify-code-heap } ;
$nl
"Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
-HELP: recompile-hook
-{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
+HELP: recompile
+{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to compiled definitions" } }
+{ $contract "Internal word which compiles words. Called at the end of " { $link with-compilation-unit } "." } ;
HELP: no-compilation-unit
{ $values { "word" word } }
USING: definitions compiler.units tools.test arrays sequences words kernel
accessors namespaces fry ;
+[ [ [ ] define-temp ] with-compilation-unit ] must-infer
+[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
+
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
-math math.order classes classes.algebra ;
+math math.order classes classes.algebra classes.tuple
+classes.tuple.private generic ;
IN: compiler.units
SYMBOL: old-definitions
[ new-definitions get assoc-stack not ]
[ drop f ] if ;
-SYMBOL: recompile-hook
+SYMBOL: compiler-impl
+
+HOOK: recompile compiler-impl ( words -- alist )
+
+! Non-optimizing compiler
+M: f recompile [ f ] { } map>assoc ;
+
+! Trivial compiler. We don't want to touch the code heap
+! during stage1 bootstrap, it would just waste time.
+SINGLETON: dummy-compiler
+
+M: dummy-compiler recompile drop { } ;
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
dup changed-definitions get update
dup dup changed-vocabs update ;
-: compile ( words -- )
- recompile-hook get call modify-code-heap ;
-
-SYMBOL: outdated-tuples
-SYMBOL: update-tuples-hook
-SYMBOL: remake-generics-hook
+: compile ( words -- ) recompile modify-code-heap ;
: index>= ( obj1 obj2 seq -- ? )
[ index ] curry bi@ >= ;
changed-generics get compiled-generic-usages
append assoc-combine keys ;
-: call-recompile-hook ( -- )
- to-recompile recompile-hook get call ;
-
-: call-remake-generics-hook ( -- )
- remake-generics-hook get call ;
-
-: call-update-tuples-hook ( -- )
- update-tuples-hook get call ;
-
: unxref-forgotten-definitions ( -- )
forgotten-definitions get
keys [ word? ] filter
[ delete-compiled-xref ] each ;
: finish-compilation-unit ( -- )
- call-remake-generics-hook
- call-recompile-hook
- call-update-tuples-hook
+ remake-generics
+ to-recompile recompile
+ update-tuples
unxref-forgotten-definitions
modify-code-heap ;
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
- H{ } clone remake-generics set
+ H{ } clone outdated-generics set
H{ } clone outdated-tuples set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
- H{ } clone remake-generics set
+ H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-classes set
notify-definition-observers
] [ ] cleanup
] with-scope ; inline
-
-: default-recompile-hook ( words -- alist )
- [ f ] { } map>assoc ;
-
-recompile-hook [ [ default-recompile-hook ] ] initialize
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
-"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles."
+"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
{ $subsection "definition-protocol" }
{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
-{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ;
+{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions"
SYMBOL: changed-generics
-SYMBOL: remake-generics
+SYMBOL: outdated-generics
SYMBOL: new-classes
{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $subsection method-spec }
-{ $see-also see see-methods } ;
+{ $see-also "see" } ;
ARTICLE: "method-combination" "Custom method combination"
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes classes.algebra classes.tuple continuations
-layouts classes.union sorting compiler.units eval multiline ;
+layouts classes.union sorting compiler.units eval multiline
+io.streams.string ;
IN: generic.tests
GENERIC: foobar ( x -- y )
[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
[ 2 ] [ 2 c-n-m-cache ] unit-test
+
+! Moving a method from one vocab to another doesn't always work
+GENERIC: move-method-generic ( a -- b )
+
+[ ] [ "IN: generic.tests.a USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
+
+[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
+
+[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
+
+[ { string } ] [ move-method-generic order ] unit-test
\ No newline at end of file
USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
-sets compiler.units ;
+sets ;
IN: generic
! Method combination protocol
[ dup "combination" word-prop perform-combination ]
bi ;
-[
- remake-generics get keys
- [ generic? ] filter [ make-generic ] each
-] remake-generics-hook set-global
-
: method ( class generic -- method/f )
"methods" word-prop at ;
[ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
: remake-generic ( generic -- )
- dup remake-generics get set-in-unit ;
+ dup outdated-generics get set-in-unit ;
+
+: remake-generics ( -- )
+ outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
: with-methods ( class generic quot -- )
[ drop changed-generic ]
namespaces make quotations stack-checker vectors growable
hashtables sbufs prettyprint byte-vectors bit-vectors
specialized-vectors.double definitions generic sets graphs assocs
-grouping ;
+grouping see ;
GENERIC: lo-tag-test ( obj -- obj' )
] when
] when nip ; inline
+M: decoder stream-element-type
+ drop +character+ ;
+
M: decoder stream-read1
dup >decoder< decode-char fix-read1 ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ; inline
+M: encoder stream-element-type
+ drop +character+ ;
+
M: encoder stream-write1
>encoder< encode-char ;
classes strings continuations destructors math byte-arrays ;
IN: io
+HELP: +byte+
+{ $description "A stream element type. See " { $link stream-element-type } " for explanation." } ;
+
+HELP: +character+
+{ $description "A stream element type. See " { $link stream-element-type } " for explanation." } ;
+
+HELP: stream-element-type
+{ $values { "stream" "a stream" } { "type" { $link +byte+ } " or " { $link +character+ } } }
+{ $description
+ "Outputs one of the following two values:"
+ { $list
+ { { $link +byte+ } " - indicates that stream elements are integers in the range " { $snippet "[0,255]" } "; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." }
+ { { $link +character+ } " - indicates that stream elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." }
+ }
+ "Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "."
+
+} ;
+
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
-
HELP: stream-seek
{ $values
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
+"The following word is required for all input and output streams:"
+{ $subsection stream-element-type }
"These words are required for binary and string input streams:"
{ $subsection stream-read1 }
{ $subsection stream-read }
"Copying the contents of one stream to another:"
{ $subsection stream-copy } ;
-ARTICLE: "stream-elements" "Stream elements"
-"There are two types of streams:"
-{ $list
- { { $strong "Binary streams" } " - the elements are integers between 0 and 255, inclusive; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." }
- { { $strong "String streams" } " - the elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." }
-}
-"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "." ;
-
ARTICLE: "streams" "Streams"
-"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of elements."
-{ $subsection "stream-elements" }
+"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "."
+$nl
"A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "."
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
continuations destructors assocs ;
IN: io
+SYMBOLS: +byte+ +character+ ;
+
+GENERIC: stream-element-type ( stream -- type )
+
GENERIC: stream-read1 ( stream -- elt )
GENERIC: stream-read ( n stream -- seq )
GENERIC: stream-read-until ( seps stream -- seq sep/f )
: <c-writer> ( handle -- stream ) f c-writer boa ;
-M: c-writer stream-write1
- dup check-disposed
- handle>> fputc ;
+M: c-writer stream-element-type drop +byte+ ;
-M: c-writer stream-write
- dup check-disposed
- handle>> fwrite ;
+M: c-writer stream-write1 dup check-disposed handle>> fputc ;
-M: c-writer stream-flush
- dup check-disposed
- handle>> fflush ;
+M: c-writer stream-write dup check-disposed handle>> fwrite ;
-M: c-writer dispose*
- handle>> fclose ;
+M: c-writer stream-flush dup check-disposed handle>> fflush ;
+
+M: c-writer dispose* handle>> fclose ;
TUPLE: c-reader handle disposed ;
: <c-reader> ( handle -- stream ) f c-reader boa ;
-M: c-reader stream-read
- dup check-disposed
- handle>> fread ;
+M: c-reader stream-element-type drop +byte+ ;
-M: c-reader stream-read-partial
- stream-read ;
+M: c-reader stream-read dup check-disposed handle>> fread ;
-M: c-reader stream-read1
- dup check-disposed
- handle>> fgetc ;
+M: c-reader stream-read-partial stream-read ;
+
+M: c-reader stream-read1 dup check-disposed handle>> fgetc ;
: read-until-loop ( stream delim -- ch )
over stream-read1 dup [
M: null-stream dispose drop ;
+M: null-reader stream-element-type drop +byte+ ;
M: null-reader stream-readln drop f ;
M: null-reader stream-read1 drop f ;
M: null-reader stream-read-until 2drop f f ;
M: null-reader stream-read 2drop f ;
+M: null-writer stream-element-type drop +byte+ ;
M: null-writer stream-write1 2drop ;
M: null-writer stream-write 2drop ;
M: null-writer stream-flush drop ;
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences io kernel accessors math math.order ;
+USING: sequences io io.streams.plain kernel accessors math math.order
+growable destructors ;
IN: io.streams.sequence
+! Readers
SLOT: underlying
SLOT: i
: sequence-read-until ( separators stream -- seq sep/f )
[ find-sep ] keep
[ sequence-read ] [ next ] bi swap ; inline
+
+! Writers
+M: growable dispose drop ;
+
+M: growable stream-write1 push ;
+M: growable stream-write push-all ;
+M: growable stream-flush drop ;
+
+INSTANCE: growable plain-writer
\ No newline at end of file
"This operation is efficient and does not copy the quotation." }
{ $examples
{ $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" }
- { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" }
+ { $example "USING: kernel prettyprint see ;" "\\ = [ see ] curry ." "[ \\ = see ]" }
{ $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" }
} ;
"memory"
"namespaces"
"prettyprint"
+ "see"
"sequences"
"slicing"
"sorting"
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
[ V{ 3 4 } ] [ 2 4 1 10 dup <slice> subseq >vector ] unit-test
[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup <slice> <slice> subseq >vector ] unit-test
+[ 0 10 "hello" <slice> ] must-fail
+[ -10 3 "hello" <slice> ] must-fail
+[ 2 1 "hello" <slice> ] must-fail
+
[ "cba" ] [ "abcdef" 3 head-slice reverse ] unit-test
[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
-ERROR: slice-error from to seq reason ;
+TUPLE: slice-error from to seq reason ;
+
+: slice-error ( from to seq ? string -- from to seq )
+ [ \ slice-error boa throw ] curry when ; inline
: check-slice ( from to seq -- from to seq )
- pick 0 < [ "start < 0" slice-error ] when
- dup length pick < [ "end > sequence" slice-error ] when
- 2over > [ "start > end" slice-error ] when ; inline
+ 3dup
+ [ 2drop 0 < "start < 0" slice-error ]
+ [ [ drop ] 2dip length > "end > sequence" slice-error ]
+ [ drop > "start > end" slice-error ]
+ 3tri ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
[ (append) ] new-like ; inline
: 3append-as ( seq1 seq2 seq3 exemplar -- newseq )
- [ pick length pick length pick length + + ] dip [
- [ [ pick length pick length + ] dip copy ]
+ [ 3dup [ length ] tri@ + + ] dip [
+ [ [ 2over [ length ] bi@ + ] dip copy ]
[ (append) ] bi
] new-like ; inline
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
-{ $see-also "vocabularies" "vocabs.loader" "definitions" } ;
+{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ;
ABOUT: "words"
[ f ] [ \ testing generic? ] unit-test
-: forgotten ;
-: another-forgotten ;
+: forgotten ( -- ) ;
+: another-forgotten ( -- ) ;
FORGET: forgotten
FORGET: another-forgotten
-: another-forgotten ;
+: another-forgotten ( -- ) ;
! I forgot remove-crossref calls!
-: fee ;
-: foe fee ;
-: fie foe ;
+: fee ( -- ) ;
+: foe ( -- ) fee ;
+: fie ( -- ) foe ;
[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
[ t ] [ \ foe usage empty? ] unit-test
! more xref buggery
[ f ] [
GENERIC: xyzzle ( x -- x )
- : a ; \ a
+ : a ( -- ) ; \ a
M: integer xyzzle a ;
FORGET: a
M: object xyzzle ;
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
- [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
+ [ t "forgotten" set-word-prop ]
tri
] if ;
USING: kernel \r
namespaces\r
accessors\r
+assocs\r
make\r
math\r
math.functions\r
colors.constants\r
prettyprint\r
vars\r
+call\r
quotations\r
io\r
io.directories\r
ui.gadgets\r
ui.traverse\r
ui.gadgets.borders\r
- ui.gadgets.handler\r
- ui.gadgets.slate\r
ui.gadgets.frames\r
ui.gadgets.tracks\r
ui.gadgets.labels\r
ui.gadgets.buttons\r
ui.gadgets.packs\r
ui.gadgets.grids\r
+ ui.gadgets.corners\r
ui.gestures\r
ui.gadgets.scrollers\r
splitting\r
adsoda.tools\r
;\r
QUALIFIED-WITH: ui.pens.solid s\r
+QUALIFIED-WITH: ui.gadgets.wrappers w\r
\r
\r
IN: 4DNav\r
! menu\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
-USE: ui.gadgets.labeled.private\r
-\r
: menu-rotations-4D ( -- gadget )\r
3 3 <frame>\r
{ 1 1 } >>filled-cell\r
add-gadget\r
menu-quick-views add-gadget ; \r
\r
+TUPLE: handler < w:wrapper table ;\r
+\r
+: <handler> ( child -- handler ) handler w:new-wrapper ;\r
+\r
+M: handler handle-gesture ( gesture gadget -- ? )\r
+ tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;\r
+\r
: add-keyboard-delegate ( obj -- obj )\r
<handler>\r
{\r
ui.gadgets.scrollers\r
prettyprint\r
combinators\r
-rewrite-closures\r
accessors\r
values\r
tools.walker\r
[ directory? ] bi or ] filter\r
;\r
\r
-: update-filelist-model ( file-chooser -- file-chooser )\r
+: update-filelist-model ( file-chooser -- )\r
[ list-of-files ] [ model>> ] bi set-model ;\r
\r
: init-filelist-model ( file-chooser -- file-chooser )\r
: fc-go-home ( file-chooser -- )\r
[ home ] (fc-go) ;\r
\r
-: fc-change-directory ( file-chooser file -- file-chooser )\r
+: fc-change-directory ( file-chooser file -- )\r
dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
append-path over path>> set-model \r
update-filelist-model\r
-4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
+Simple tool to navigate through a 4D space with projections on 4 3D spaces
VAR: self
-: with-self ( quot obj -- ) [ >self call ] with-scope ;
+: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
-: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
+: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors regexp prettyprint io io.encodings.ascii
-io.files kernel sequences assocs namespaces ;
+USING: accessors prettyprint io io.encodings.ascii
+io.files kernel sequences assocs namespaces regexp ;
IN: benchmark.regex-dna
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images.bitmap images.viewer
+opengl.gl sequences math.vectors ui images images.viewer
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )
- dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
+ dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
: gl-screenshot ( gadget -- byte-array )
[
- GL_BACK glReadBuffer
- GL_PACK_ALIGNMENT 4 glPixelStorei
- 0 0
- ] dip
- [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+ [
+ GL_BACK glReadBuffer
+ GL_PACK_ALIGNMENT 4 glPixelStorei
+ 0 0
+ ] dip
+ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
+ ]
[ screenshot-array ] bi
[ glReadPixels ] keep ;
: screenshot ( window -- bitmap )
- [ gl-screenshot ]
- [ dim>> first2 ] bi
- bgr>bitmap ;
-
-: save-screenshot ( window path -- )
- [ screenshot ] dip save-bitmap ;
+ [ <image> ] dip
+ [ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
+ RGBA >>component-order
+ t >>upside-down?
+ normalize-image ;
: screenshot. ( window -- )
[ screenshot <image-gadget> ] [ title>> ] bi open-window ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.functions tools.test combinators.cleave ;
-
-IN: combinators.cleave.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
-
-[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
-
-[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
-
-[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
-
+++ /dev/null
-
-USING: kernel combinators words quotations arrays sequences locals macros
- shuffle generalizations fry ;
-
-IN: combinators.cleave
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
-
-: >quots ( seq -- seq ) [ >quot ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: [ncleave] ( SEQ N -- quot )
- SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
-
-MACRO: ncleave ( seq n -- quot ) [ncleave] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Cleave into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
-
-MACRO: narr ( seq n -- array ) [narr] ;
-
-MACRO: 0arr ( seq -- array ) 0 [narr] ;
-MACRO: 1arr ( seq -- array ) 1 [narr] ;
-MACRO: 2arr ( seq -- array ) 2 [narr] ;
-MACRO: 3arr ( seq -- array ) 3 [narr] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ cleave _ narray ] ;
-
-MACRO: <2arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ 2cleave _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {1} ( x -- {x} ) 1array ; inline
-: {2} ( x y -- {x,y} ) 2array ; inline
-: {3} ( x y z -- {x,y,z} ) 3array ; inline
-
-: {n} narray ;
-
-: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
-
-: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Spread into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr*> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ spread _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
-: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
+++ /dev/null
-
-USING: combinators.cleave fry kernel macros parser quotations ;
-
-IN: combinators.cleave.enhanced
-
-: \\
- scan-word literalize parsed
- scan-word literalize parsed ; parsing
-
-MACRO: bi ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ keep ] dip call ] ;
-
-MACRO: tri ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
-
-MACRO: bi* ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ dip ] dip call ] ;
-
-MACRO: tri* ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
-
+++ /dev/null
-
-USING: kernel combinators sequences macros fry newfx combinators.cleave ;
-
-IN: combinators.conditional
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1cond ( tbl -- )
- [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
- [ cond ] prefix-on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: descriptive kernel math tools.test continuations prettyprint io.streams.string ;\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ;\r
IN: descriptive.tests\r
\r
DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
USING: kernel sequences assocs sets locals combinators
accessors system math math.functions unicode.case prettyprint
- combinators.cleave dns ;
+ combinators.smart dns ;
IN: dns.cache.rr
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-cache-key ( obj -- key )
- { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
destructors
io io.binary io.sockets io.encodings.binary
accessors
- combinators.cleave
+ combinators.smart
newfx
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->ba ( query -- ba )
+ [
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ class>> class-table of uint16->ba ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: soa->ba ( rdata -- ba )
+ [
{
[ mname>> dn->ba ]
[ rname>> dn->ba ]
[ retry>> uint32->ba ]
[ expire>> uint32->ba ]
[ minimum>> uint32->ba ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->ba ( rr -- ba )
+ [
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ type>> ] [ rdata>> ] bi rdata->ba
[ length uint16->ba ] [ ] bi append
]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: header-bits-ba ( message -- ba )
+ [
{
[ qr>> 15 shift ]
[ opcode>> opcode-table of 11 shift ]
[ ra>> 7 shift ]
[ z>> 4 shift ]
[ rcode>> rcode-table of 0 shift ]
- }
- <arr> sum uint16->ba ;
+ } cleave
+ ] sum-outputs uint16->ba ;
: message->ba ( message -- ba )
+ [
{
[ id>> uint16->ba ]
[ header-bits-ba ]
[ answer-section>> [ rr->ba ] map concat ]
[ authority-section>> [ rr->ba ] map concat ]
[ additional-section>> [ rr->ba ] map concat ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ask ( message -- message ) dns-server ask-server ;
-: query->message ( query -- message ) <message> swap {1} >>question-section ;
+: query->message ( query -- message ) <message> swap 1array >>question-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
- combinators.cleave combinators.short-circuit
- newfx fry
+ combinators.short-circuit combinators.smart
+ newfx fry arrays
dns dns.util dns.misc ;
IN: dns.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- array )
- { [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
: rr->rdata-names ( rr -- names/f )
{
- { [ dup type>> NS = ] [ rdata>> {1} ] }
- { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
- { [ dup type>> CNAME = ] [ rdata>> {1} ] }
+ { [ dup type>> NS = ] [ rdata>> 1array ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
+ { [ dup type>> CNAME = ] [ rdata>> 1array ] }
{ [ t ] [ drop f ] }
}
cond ;
: fjsc-compile* ( string -- string )
'statement' parse ast>> fjsc-compile ;
-: fc* ( string -- string )
+: fc* ( string -- )
[
- 'statement' parse ast>> values>> do-expressions
+ 'statement' parse ast>> values>> do-expressions
] { } make [ write ] each ;
USING: accessors arrays assocs combinators help help.crossref
help.markup help.topics io io.streams.string kernel make namespaces
parser prettyprint sequences summary tools.vocabs tools.vocabs.browser
-vocabs vocabs.loader words ;
+vocabs vocabs.loader words see ;
IN: fuel.help
: fuel-parent-topics ( word -- seq )
help-path [ dup article-title swap 2array ] map ; inline
+SYMBOL: $doc-path
+
: (fuel-word-element) ( word -- element )
\ article swap dup article-title swap
[
] { } make 3array ;
: fuel-vocab-help-row ( vocab -- element )
- [ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
+ [ vocab-name ] [ summary ] bi 2array ;
: fuel-vocab-help-root-heading ( root -- element )
[ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
SYMBOL: vocab-list
+SYMBOL: describe-words
: fuel-vocab-help-table ( vocabs -- element )
[ fuel-vocab-help-row ] map vocab-list prefix ;
all-child-vocabs fuel-vocab-list ; inline
: fuel-vocab-describe-words ( name -- element )
- [ describe-words ] with-string-writer \ describe-words swap 2array ; inline
+ [ words. ] with-string-writer \ describe-words swap 2array ; inline
: (fuel-vocab-element) ( name -- element )
dup require \ article swap dup >vocab-link
USING: accessors arrays assocs definitions help.topics io.pathnames
kernel math math.order memoize namespaces sequences sets sorting
-tools.crossref tools.vocabs vocabs vocabs.parser words ;
+tools.completion tools.crossref tools.vocabs vocabs vocabs.parser
+words ;
IN: fuel.xref
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
-: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
+CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download"
: download-db ( -- path )
db-path dup exists? [
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.smart csv io.encodings.8-bit
+math.parser memoize sequences kernel unicode.categories money ;
+IN: geobytes
+
+! GeoBytes is not free software.
+! Please read their license should you choose to use it.
+! This is just a binding to the GeoBytes CSV files.
+! Download and install GeoBytes yourself should you wish to use it.
+! http://www.geobytes.com/GeoWorldMap.zip
+
+CONSTANT: geobytes-cities-path "resource:GeoWorldMap/Cities.txt"
+CONSTANT: geobytes-countries-path "resource:GeoWorldMap/Countries.txt"
+CONSTANT: geobytes-regions-path "resource:GeoWorldMap/Regions.txt"
+CONSTANT: geobytes-version-path "resource:GeoWorldMap/version.txt"
+
+TUPLE: country country-id country fips104 iso2 iso3 ison internet capital map-reference
+nationality-singular nationality-plural currency currency-code population title
+comment ;
+
+TUPLE: region region-id country-id region code adm1-code ;
+
+TUPLE: city city-id country-id region-id city longitude latitude timezone code ;
+
+TUPLE: version component version rows ;
+
+MEMO: load-countries ( -- seq )
+ geobytes-countries-path latin1 file>csv rest-slice [
+ [
+ {
+ [ string>number ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ string>number ]
+ [ ]
+ [ ]
+ } spread country boa
+ ] input<sequence
+ ] map ;
+
+MEMO: load-regions ( -- seq )
+ geobytes-regions-path latin1 file>csv rest-slice [
+ [
+ {
+ [ string>number ]
+ [ string>number ]
+ [ ]
+ [ ]
+ [ [ blank? ] trim ]
+ } spread region boa
+ ] input<sequence
+ ] map ;
+
+MEMO: load-cities ( -- seq )
+ geobytes-cities-path latin1 file>csv rest-slice [
+ [
+ {
+ [ string>number ]
+ [ string>number ]
+ [ string>number ]
+ [ ]
+ [ parse-decimal ]
+ [ parse-decimal ]
+ [ ]
+ [ string>number ]
+ } spread city boa
+ ] input<sequence
+ ] map ;
+
+MEMO: load-version ( -- seq )
+ geobytes-version-path latin1 file>csv rest-slice [
+ [
+ {
+ [ ]
+ [ ]
+ [ string>number ]
+ } spread version boa
+ ] input<sequence
+ ] map ;
--- /dev/null
+City, country, region database using database from http://www.geobytes.com/GeoWorldMap.zip
--- /dev/null
+enterprise
[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
-! [ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
+[ "foo " " bar" ]
+[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
] [ drop ] if ; inline recursive
: take-until ( quot: ( -- ? ) -- )
- [ get-i ] dip skip-until get-i
+ get-i [ skip-until ] dip get-i
state get string>> subseq ;
: string-matches? ( string circular -- ? )
- get-char over push-circular sequence= ;
+ get-char over push-growing-circular sequence= ;
: take-string ( match -- string )
- dup length <circular-string>
+ dup length <growing-circular>
[ 2dup string-matches? ] take-until nip
dup length rot length 1- - head next ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.loader io.pathnames kernel
-namespaces opengl opengl.gl sequences strings ui ui.gadgets
+USING: accessors images images.loader io.pathnames kernel namespaces
+opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: images.viewer
: draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
- [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
- [ bitmap>> ] bi glDrawPixels ;
+ [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+ glDrawPixels ;
M: image-gadget draw-gadget* ( gadget -- )
image>> draw-image ;
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
3bi ; ! FIXME
-DEFER: me?
-
! ======================================
! IRC client messages
! ======================================
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators.short-circuit
-continuations debugger http.client io.directories io.files
-io.launcher io.pathnames kernel make mason.common mason.config
+continuations debugger http.client io.directories io.files io.launcher
+io.pathnames io.encodings.ascii kernel make mason.common mason.config
mason.platform mason.report mason.email namespaces sequences ;
IN: mason.child
: make-cmd ( -- args )
gnu-make platform 2array ;
+: dll-url ( -- url )
+ "http://factorcode.org/dlls/"
+ target-cpu get "x86.64" = [ "64/" append ] when ;
+
: download-dlls ( -- )
target-os get "winnt" = [
- "http://factorcode.org/dlls/"
- target-cpu get "x86.64" = [ "64/" append ] when
- [ "freetype6.dll" append ]
- [ "zlib1.dll" append ] bi
- [ download ] bi@
+ dll-url "build-support/dlls.txt" ascii file-lines
+ [ append download ] with each
] when ;
: make-vm ( -- )
+++ /dev/null
-
-USING: kernel sequences multi-methods accessors math.vectors ;
-
-IN: math.physics.pos
-
-TUPLE: pos pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: distance ( a b -- c )
-
-METHOD: distance { sequence sequence } v- norm ;
-
-METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: math.physics.pos ;
-
-IN: math.physics.vel
-
-TUPLE: vel < pos vel ;
-
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: method-chains.tests
+USING: method-chains tools.test arrays strings sequences kernel namespaces ;
+
+GENERIC: testing ( a b -- c )
+
+M: sequence testing nip reverse ;
+AFTER: string testing append ;
+BEFORE: array testing over prefix "a" set ;
+
+[ V{ 3 2 1 } ] [ 3 V{ 1 2 3 } testing ] unit-test
+[ "heyyeh" ] [ 4 "yeh" testing ] unit-test
+[ { 4 2 0 } ] [ 5 { 0 2 4 } testing ] unit-test
+[ { 5 0 2 4 } ] [ "a" get ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic generic.parser words fry ;
+IN: method-chains
+
+: AFTER: (M:) dupd '[ [ _ (call-next-method) ] _ bi ] define ; parsing
+: BEFORE: (M:) over '[ _ [ _ (call-next-method) ] bi ] define ; parsing
+++ /dev/null
-
-USING: accessors effects.parser kernel lexer multi-methods
- parser sequences words ;
-
-IN: multi-method-syntax
-
-! A nicer specializer syntax to hold us over till multi-methods go in
-! officially.
-!
-! Use both 'multi-methods' and 'multi-method-syntax' in that order.
-
-: scan-specializer ( -- specializer )
-
- scan drop ! eat opening parenthesis
-
- ")" parse-effect in>> [ search ] map ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-specializer swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
definitions prettyprint prettyprint.backend prettyprint.custom
quotations generalizations debugger io compiler.units
kernel.private effects accessors hashtables sorting shuffle
-math.order sets ;
+math.order sets see ;
IN: multi-methods
! PART I: Converting hook specializers
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors ;
+hashtables continuations classes assocs accessors see ;
GENERIC: first-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
-locals kernel.private tools.vocabs.browser assocs quotations
- tools.vocabs tools.annotations tools.crossref
-help.topics math.functions compiler.tree.optimizer
-compiler.cfg.optimizer fry
-ui.gadgets.panes tetris tetris.game combinators generalizations
-multiline sequences.private ;
+USING: slides help.markup math arrays hashtables namespaces sequences
+kernel sequences parser memoize io.encodings.binary locals
+kernel.private tools.vocabs.browser assocs quotations tools.vocabs
+tools.annotations tools.crossref help.topics math.functions
+compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
+tetris tetris.game combinators generalizations multiline
+sequences.private ;
IN: otug-talk
-USING: cairo cairo.ffi cairo.gadgets accessors
-io.backend ui.gadgets ;
-
-TUPLE: png-gadget < cairo-gadget surface ;
-
-: <png-gadget> ( file -- gadget )
- png-gadget new-gadget
- swap normalize-path
- cairo_image_surface_create_from_png >>surface ; inline
-
-M: png-gadget pref-dim* ( gadget -- )
- surface>>
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height ]
- bi 2array ;
-
-M: png-gadget render-cairo* ( gadget -- )
- cr swap surface>> 0 0 cairo_set_source_surface
- cr cairo_paint ;
-
-M: png-gadget ungraft* ( gadget -- )
- surface>> cairo_surface_destroy ;
-
-: $bitmap ( element -- )
- [ first <png-gadget> gadget. ] ($block) ;
-
: $tetris ( element -- )
drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
}
{ $slide "Data flow combinators - cleave family"
{ { $link bi } ", " { $link tri } ", " { $link cleave } }
- { $bitmap "resource:extra/otug-talk/bi.png" }
+ { $image "resource:extra/otug-talk/bi.tiff" }
}
{ $slide "Data flow combinators - cleave family"
{ { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
- { $bitmap "resource:extra/otug-talk/2bi.png" }
+ { $image "resource:extra/otug-talk/2bi.tiff" }
}
{ $slide "Data flow combinators"
"First, let's define a data type:"
}
{ $slide "Data flow combinators - spread family"
{ { $link bi* } ", " { $link tri* } ", " { $link spread } }
- { $bitmap "resource:extra/otug-talk/bi_star.png" }
+ { $image "resource:extra/otug-talk/bi_star.tiff" }
}
{ $slide "Data flow combinators - spread family"
{ { $link 2bi* } }
- { $bitmap "resource:extra/otug-talk/2bi_star.png" }
+ { $image "resource:extra/otug-talk/2bi_star.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
- { $bitmap "resource:extra/otug-talk/bi_at.png" }
+ { $image "resource:extra/otug-talk/bi_at.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link 2bi@ } }
- { $bitmap "resource:extra/otug-talk/2bi_at.png" }
+ { $image "resource:extra/otug-talk/2bi_at.tiff" }
}
{ $slide "Shuffle words"
"When data flow combinators are not enough"
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-USING: parser-combinators.regexp tools.test kernel ;
-IN: parser-combinators.regexp.tests
-
-[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
-
-[ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a?" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "." f <regexp> matches? ] unit-test
-[ t ] [ "a" "." f <regexp> matches? ] unit-test
-[ t ] [ "." "." f <regexp> matches? ] unit-test
-! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
-
-[ f ] [ "" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "a" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-
-[ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
-[ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
-[ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
-
-[ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
-[ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
-
-[ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
-[ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
-[ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
-[ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
-
-[ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
-[ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
-
-! [ "^" "[^]" f <regexp> matches? ] must-fail
-[ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
-[ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
-
-[ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
-[ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
-
-[ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
-
-[ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
-
-[ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "0" "[^\\d]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\d]" f <regexp> matches? ] unit-test
-
-[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f <regexp> matches? ] unit-test
-
-[ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
-[ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
-
-[ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
-[ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
-[ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
-
-[ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
-[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u000078" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u000078" f <regexp> matches? ] unit-test
-
-[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
-[ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
-
-[ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
-[ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
-
-[ f ] [ "x" "\\." f <regexp> matches? ] unit-test
-[ t ] [ "." "\\." f <regexp> matches? ] unit-test
-
-[ t ] [ "aaaab" "a+ab" f <regexp> matches? ] unit-test
-[ f ] [ "aaaxb" "a+ab" f <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a+cb" f <regexp> matches? ] unit-test
-[ f ] [ "aaaab" "a++ab" f <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a++cb" f <regexp> matches? ] unit-test
-
-[ 3 ] [ "aaacb" "a*" f <regexp> match-head ] unit-test
-[ 1 ] [ "aaacb" "a+?" f <regexp> match-head ] unit-test
-[ 2 ] [ "aaacb" "aa?" f <regexp> match-head ] unit-test
-[ 1 ] [ "aaacb" "aa??" f <regexp> match-head ] unit-test
-[ 3 ] [ "aacb" "aa?c" f <regexp> match-head ] unit-test
-[ 3 ] [ "aacb" "aa??c" f <regexp> match-head ] unit-test
-
-[ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
-[ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
-[ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
-[ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
-[ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
-[ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
-[ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
-[ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
-
-[ ] [
- "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
- f <regexp> drop
-] unit-test
-
-[ t ] [ "fxxbar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
-[ f ] [ "foobar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
-
-[ 3 ] [ "foobar" "foo(?=bar)" f <regexp> match-head ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" f <regexp> match-head ] unit-test
-
-[ f ] [ "foobxr" "foo\\z" f <regexp> match-head ] unit-test
-[ 3 ] [ "foo" "foo\\z" f <regexp> match-head ] unit-test
-
-[ 3 ] [ "foo bar" "foo\\b" f <regexp> match-head ] unit-test
-[ f ] [ "fooxbar" "foo\\b" f <regexp> matches? ] unit-test
-[ t ] [ "foo" "foo\\b" f <regexp> matches? ] unit-test
-[ t ] [ "foo bar" "foo\\b bar" f <regexp> matches? ] unit-test
-[ f ] [ "fooxbar" "foo\\bxbar" f <regexp> matches? ] unit-test
-[ f ] [ "foo" "foo\\bbar" f <regexp> matches? ] unit-test
-
-[ f ] [ "foo bar" "foo\\B" f <regexp> matches? ] unit-test
-[ 3 ] [ "fooxbar" "foo\\B" f <regexp> match-head ] unit-test
-[ t ] [ "foo" "foo\\B" f <regexp> matches? ] unit-test
-[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
-[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
-[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test
-
-[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
-[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
-
-! Bug in parsing word
-[ t ] [
- "a"
- R' a'
- matches?
-] unit-test
+++ /dev/null
-USING: arrays combinators kernel lists math math.parser
-namespaces parser lexer parser-combinators
-parser-combinators.simple promises quotations sequences strings
-math.order assocs prettyprint.backend prettyprint.custom memoize
-ascii unicode.categories combinators.short-circuit
-accessors make io ;
-IN: parser-combinators.regexp
-
-<PRIVATE
-
-SYMBOL: ignore-case?
-
-: char=-quot ( ch -- quot )
- ignore-case? get
- [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
- curry ;
-
-: char-between?-quot ( ch1 ch2 -- quot )
- ignore-case? get
- [ [ ch>upper ] bi@ [ [ ch>upper ] 2dip between? ] ]
- [ [ between? ] ]
- if 2curry ;
-
-: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
-
-: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
-
-PRIVATE>
-
-: ascii? ( n -- ? )
- 0 HEX: 7f between? ;
-
-: octal-digit? ( n -- ? )
- CHAR: 0 CHAR: 7 between? ;
-
-: decimal-digit? ( n -- ? )
- CHAR: 0 CHAR: 9 between? ;
-
-: hex-digit? ( n -- ? )
- dup decimal-digit?
- over CHAR: a CHAR: f between? or
- swap CHAR: A CHAR: F between? or ;
-
-: control-char? ( n -- ? )
- dup 0 HEX: 1f between?
- swap HEX: 7f = or ;
-
-: punct? ( n -- ? )
- "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
- dup alpha? swap CHAR: _ = or ;
-
-: java-blank? ( n -- ? )
- {
- CHAR: \s
- CHAR: \t CHAR: \n CHAR: \r
- HEX: c HEX: 7 HEX: 1b
- } member? ;
-
-: java-printable? ( n -- ? )
- dup alpha? swap punct? or ;
-
-: 'ordinary-char' ( -- parser )
- [ "\\^*+?|(){}[$" member? not ] satisfy
- [ char=-quot ] <@ ;
-
-: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
-
-: 'octal' ( -- parser )
- "0" token 'octal-digit' 1 3 from-m-to-n &>
- [ oct> ] <@ ;
-
-: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
-
-: 'hex' ( -- parser )
- "x" token 'hex-digit' 2 exactly-n &>
- "u" token 'hex-digit' 6 exactly-n &> <|>
- [ hex> ] <@ ;
-
-: satisfy-tokens ( assoc -- parser )
- [ [ token ] dip <@literal ] { } assoc>map <or-parser> ;
-
-: 'simple-escape-char' ( -- parser )
- {
- { "\\" CHAR: \\ }
- { "t" CHAR: \t }
- { "n" CHAR: \n }
- { "r" CHAR: \r }
- { "f" HEX: c }
- { "a" HEX: 7 }
- { "e" HEX: 1b }
- } [ char=-quot ] assoc-map satisfy-tokens ;
-
-: 'predefined-char-class' ( -- parser )
- {
- { "d" [ digit? ] }
- { "D" [ digit? not ] }
- { "s" [ java-blank? ] }
- { "S" [ java-blank? not ] }
- { "w" [ c-identifier-char? ] }
- { "W" [ c-identifier-char? not ] }
- } satisfy-tokens ;
-
-: 'posix-character-class' ( -- parser )
- {
- { "Lower" [ letter? ] }
- { "Upper" [ LETTER? ] }
- { "ASCII" [ ascii? ] }
- { "Alpha" [ Letter? ] }
- { "Digit" [ digit? ] }
- { "Alnum" [ alpha? ] }
- { "Punct" [ punct? ] }
- { "Graph" [ java-printable? ] }
- { "Print" [ java-printable? ] }
- { "Blank" [ " \t" member? ] }
- { "Cntrl" [ control-char? ] }
- { "XDigit" [ hex-digit? ] }
- { "Space" [ java-blank? ] }
- } satisfy-tokens "p{" "}" surrounded-by ;
-
-: 'simple-escape' ( -- parser )
- 'octal'
- 'hex' <|>
- "c" token [ LETTER? ] satisfy &> <|>
- any-char-parser <|>
- [ char=-quot ] <@ ;
-
-: 'escape' ( -- parser )
- "\\" token
- 'simple-escape-char'
- 'predefined-char-class' <|>
- 'posix-character-class' <|>
- 'simple-escape' <|> &> ;
-
-: 'any-char' ( -- parser )
- "." token [ drop t ] <@literal ;
-
-: 'char' ( -- parser )
- 'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
-
-DEFER: 'regexp'
-
-TUPLE: group-result str ;
-
-C: <group-result> group-result
-
-: 'non-capturing-group' ( -- parser )
- "?:" token 'regexp' &> ;
-
-: 'positive-lookahead-group' ( -- parser )
- "?=" token 'regexp' &> [ ensure ] <@ ;
-
-: 'negative-lookahead-group' ( -- parser )
- "?!" token 'regexp' &> [ ensure-not ] <@ ;
-
-: 'simple-group' ( -- parser )
- 'regexp' [ [ <group-result> ] <@ ] <@ ;
-
-: 'group' ( -- parser )
- 'non-capturing-group'
- 'positive-lookahead-group'
- 'negative-lookahead-group'
- 'simple-group' <|> <|> <|>
- "(" ")" surrounded-by ;
-
-: 'range' ( -- parser )
- [ CHAR: ] = not ] satisfy "-" token <&
- [ CHAR: ] = not ] satisfy <&>
- [ first2 char-between?-quot ] <@ ;
-
-: 'character-class-term' ( -- parser )
- 'range'
- 'escape' <|>
- [ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
-
-: 'positive-character-class' ( -- parser )
- "]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
- 'character-class-term' <+> <|>
- [ [ 1|| ] curry ] <@ ;
-
-: 'negative-character-class' ( -- parser )
- "^" token 'positive-character-class' &>
- [ [ not ] append ] <@ ;
-
-: 'character-class' ( -- parser )
- 'negative-character-class' 'positive-character-class' <|>
- "[" "]" surrounded-by [ satisfy ] <@ ;
-
-: 'escaped-seq' ( -- parser )
- any-char-parser <*>
- [ ignore-case? get <token-parser> ] <@
- "\\Q" "\\E" surrounded-by ;
-
-: 'break' ( quot -- parser )
- satisfy ensure epsilon just <|> ;
-
-: 'break-escape' ( -- parser )
- "$" token [ "\r\n" member? ] 'break' <@literal
- "\\b" token [ blank? ] 'break' <@literal <|>
- "\\B" token [ blank? not ] 'break' <@literal <|>
- "\\z" token epsilon just <@literal <|> ;
-
-: 'simple' ( -- parser )
- 'escaped-seq'
- 'break-escape' <|>
- 'group' <|>
- 'character-class' <|>
- 'char' <|> ;
-
-: 'exactly-n' ( -- parser )
- 'integer' [ exactly-n ] <@delay ;
-
-: 'at-least-n' ( -- parser )
- 'integer' "," token <& [ at-least-n ] <@delay ;
-
-: 'at-most-n' ( -- parser )
- "," token 'integer' &> [ at-most-n ] <@delay ;
-
-: 'from-m-to-n' ( -- parser )
- 'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
-
-: 'greedy-interval' ( -- parser )
- 'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
-
-: 'interval' ( -- parser )
- 'greedy-interval'
- 'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
- 'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
- "{" "}" surrounded-by ;
-
-: 'repetition' ( -- parser )
- ! Posessive
- "*+" token [ <!*> ] <@literal
- "++" token [ <!+> ] <@literal <|>
- "?+" token [ <!?> ] <@literal <|>
- ! Reluctant
- "*?" token [ <(*)> ] <@literal <|>
- "+?" token [ <(+)> ] <@literal <|>
- "??" token [ <(?)> ] <@literal <|>
- ! Greedy
- "*" token [ <*> ] <@literal <|>
- "+" token [ <+> ] <@literal <|>
- "?" token [ <?> ] <@literal <|> ;
-
-: 'dummy' ( -- parser )
- epsilon [ ] <@literal ;
-
-MEMO: 'term' ( -- parser )
- 'simple'
- 'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
- <!+> [ <and-parser> ] <@ ;
-
-LAZY: 'regexp' ( -- parser )
- 'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
-! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
-! &> [ "caret" print ] <@ <|>
-! 'term' "|" token nonempty-list-of [ <or-parser> ] <@
-! "$" token <& [ "dollar" print ] <@ <|>
-! "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
-! "$" token [ "caret dollar" print ] <@ <& <|> ;
-
-TUPLE: regexp source parser ignore-case? ;
-
-: <regexp> ( string ignore-case? -- regexp )
- [
- ignore-case? [
- dup 'regexp' just parse-1
- ] with-variable
- ] keep regexp boa ;
-
-: do-ignore-case ( string regexp -- string regexp )
- dup ignore-case?>> [ [ >upper ] dip ] when ;
-
-: matches? ( string regexp -- ? )
- do-ignore-case parser>> just parse nil? not ;
-
-: match-head ( string regexp -- end )
- do-ignore-case parser>> parse dup nil?
- [ drop f ] [ car unparsed>> from>> ] if ;
-
-! Literal syntax for regexps
-: parse-options ( string -- ? )
- #! Lame
- {
- { "" [ f ] }
- { "i" [ t ] }
- } case ;
-
-: parse-regexp ( accum end -- accum )
- lexer get dup skip-blank
- [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
- lexer get dup still-parsing-line?
- [ (parse-token) parse-options ] [ drop f ] if
- <regexp> parsed ;
-
-: R! CHAR: ! parse-regexp ; parsing
-: R" CHAR: " parse-regexp ; parsing
-: R# CHAR: # parse-regexp ; parsing
-: R' CHAR: ' parse-regexp ; parsing
-: R( CHAR: ) parse-regexp ; parsing
-: R/ CHAR: / parse-regexp ; parsing
-: R@ CHAR: @ parse-regexp ; parsing
-: R[ CHAR: ] parse-regexp ; parsing
-: R` CHAR: ` parse-regexp ; parsing
-: R{ CHAR: } parse-regexp ; parsing
-: R| CHAR: | parse-regexp ; parsing
-
-: find-regexp-syntax ( string -- prefix suffix )
- {
- { "R/ " "/" }
- { "R! " "!" }
- { "R\" " "\"" }
- { "R# " "#" }
- { "R' " "'" }
- { "R( " ")" }
- { "R@ " "@" }
- { "R[ " "]" }
- { "R` " "`" }
- { "R{ " "}" }
- { "R| " "|" }
- } swap [ subseq? not nip ] curry assoc-find drop ;
-
-M: regexp pprint*
- [
- dup source>>
- dup find-regexp-syntax swap % swap % %
- dup ignore-case?>> [ "i" % ] when
- ] "" make
- swap present-text ;
+++ /dev/null
-Regular expressions
+++ /dev/null
-parsing
-text
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel urls alarms calendar ;
+IN: site-watcher
+
+HELP: run-site-watcher
+{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
+
+HELP: running-site-watcher
+{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
+
+HELP: site-watcher-from
+{ $var-description "The email address from which site-watcher sends emails." } ;
+
+HELP: sites
+{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
+
+HELP: watch-site
+{ $values
+ { "emails" "a string containing an email address, or an array of such" }
+ { "url" url }
+}
+{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
+
+HELP: watch-sites
+{ $values
+ { "assoc" assoc }
+ { "alarm" alarm }
+}
+{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
+
+HELP: site-watcher-frequency
+{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
+
+HELP: unwatch-site
+{ $values
+ { "emails" "a string containing an email, or an array of such" }
+ { "url" url }
+}
+{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
+
+HELP: delete-site
+{ $values
+ { "url" url }
+}
+{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
+
+ARTICLE: "site-watcher" "Site watcher"
+"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
+"To monitor a site:"
+{ $subsection watch-site }
+"To stop email addresses from being notified if a site's status changes:"
+{ $subsection unwatch-site }
+"To stop monitoring a site for all email addresses:"
+{ $subsection delete-site }
+"To run site-watcher using the sites variable:"
+{ $subsection run-site-watcher }
+;
+
+ABOUT: "site-watcher"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms assocs calendar combinators
+continuations fry http.client io.streams.string kernel init
+namespaces prettyprint smtp arrays sequences math math.parser
+strings sets ;
+IN: site-watcher
+
+SYMBOL: sites
+
+SYMBOL: site-watcher-from
+
+sites [ H{ } clone ] initialize
+
+TUPLE: watching emails url last-up up? send-email? error ;
+
+<PRIVATE
+
+: ?1array ( array/object -- array )
+ dup array? [ 1array ] unless ; inline
+
+: <watching> ( emails url -- watching )
+ watching new
+ swap >>url
+ swap ?1array >>emails
+ now >>last-up
+ t >>up? ;
+
+ERROR: not-watching-site url status ;
+
+: set-site-flags ( watching new-up? -- watching )
+ [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
+
+: site-bad ( watching error -- )
+ >>error f set-site-flags drop ;
+
+: site-good ( watching -- )
+ f >>error
+ t set-site-flags
+ now >>last-up drop ;
+
+: check-sites ( assoc -- )
+ [
+ swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
+ ] assoc-each ;
+
+: site-up-email ( email watching -- email )
+ last-up>> now swap time- duration>minutes 60 /mod
+ [ >integer number>string ] bi@
+ [ " hours, " append ] [ " minutes" append ] bi* append
+ "Site was down for (at least): " prepend >>body ;
+
+: ?unparse ( string/object -- string )
+ dup string? [ unparse ] unless ; inline
+
+: site-down-email ( email watching -- email )
+ error>> ?unparse >>body ;
+
+: send-report ( watching -- )
+ [ <email> ] dip
+ {
+ [ emails>> >>to ]
+ [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
+ [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
+ [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
+ [ f >>send-email? drop ]
+ } cleave send-email ;
+
+: report-sites ( assoc -- )
+ [ nip send-email?>> ] assoc-filter
+ [ nip send-report ] assoc-each ;
+
+PRIVATE>
+
+SYMBOL: site-watcher-frequency
+site-watcher-frequency [ 5 minutes ] initialize
+
+: watch-sites ( assoc -- alarm )
+ '[
+ _ [ check-sites ] [ report-sites ] bi
+ ] site-watcher-frequency get every ;
+
+: watch-site ( emails url -- )
+ sites get ?at [
+ [ [ ?1array ] dip append prune ] change-emails drop
+ ] [
+ <watching> dup url>> sites get set-at
+ ] if ;
+
+: delete-site ( url -- )
+ sites get delete-at ;
+
+: unwatch-site ( emails url -- )
+ [ ?1array ] dip
+ sites get ?at [
+ [ diff ] change-emails dup emails>> empty? [
+ url>> delete-site
+ ] [
+ drop
+ ] if
+ ] [
+ nip delete-site
+ ] if ;
+
+SYMBOL: running-site-watcher
+
+: run-site-watcher ( -- )
+ running-site-watcher get-global [
+ sites get-global watch-sites running-site-watcher set-global
+ ] unless ;
+
+[ f running-site-watcher set-global ] "site-watcher" add-init-hook
+
+MAIN: run-site-watcher
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
parser accessors colors ;
IN: slides
parse-definition strip-tease [ parsed ] each ; parsing
\ slides H{
+ { T{ button-down } [ request-focus ] }
{ T{ key-down f f "DOWN" } [ next-page ] }
{ T{ key-down f f "UP" } [ prev-page ] }
} set-gestures
-USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ;
+USING: accessors arrays colors colors.constants kernel tetris.board tetris.piece tools.test ;
[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
[ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test
[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
[ 2 3 <board> { 2 3 } block ] must-fail
-red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
+COLOR: red 1array [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test
[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test
[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
-[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
-[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
+[ { { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
+[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test
: scale-board ( width height board -- )
[ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
-: (draw-tetris) ( width height tetris -- )
+: draw-tetris ( width height tetris -- )
#! width and height are in pixels
GL_MODELVIEW [
{
[ next-piece draw-next-piece ]
[ current-piece draw-piece ]
} cleave
- ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
- origin get [ (draw-tetris) ] with-translation ;
+ ] do-matrix ;
\ No newline at end of file
--- /dev/null
+Alex Chapman
+Daniel Ehrenberg
--- /dev/null
+Alex Chapman
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup assocs ;
+IN: trees.avl
+
+HELP: AVL{
+{ $syntax "AVL{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an AVL tree." } ;
+
+HELP: <avl>
+{ $values { "tree" avl } }
+{ $description "Creates an empty AVL tree" } ;
+
+HELP: >avl
+{ $values { "assoc" assoc } { "avl" avl } }
+{ $description "Converts any " { $link assoc } " into an AVL tree." } ;
+
+HELP: avl
+{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ;
+
+ARTICLE: "trees.avl" "AVL trees"
+"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol."
+{ $subsection avl }
+{ $subsection <avl> }
+{ $subsection >avl }
+{ $subsection POSTPONE: AVL{ } ;
+
+ABOUT: "trees.avl"
--- /dev/null
+USING: kernel tools.test trees trees.avl math random sequences
+assocs accessors ;
+IN: trees.avl.tests
+
+[ "key1" 0 "key2" 0 ] [
+ T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 }
+ [ single-rotate ] go-left
+ [ left>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>>
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+ T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 }
+ [ select-rotate ] go-left
+ [ left>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>>
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+ T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
+ [ single-rotate ] go-right
+ [ right>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>>
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+ T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
+ [ select-rotate ] go-right
+ [ right>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>>
+] unit-test
+
+[ "key1" -1 "key2" 0 "key3" 0 ]
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f 1 } f -1 } 2 }
+ [ double-rotate ] go-left
+ [ left>> dup key>> swap balance>> ] keep
+ [ right>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+[ "key1" 0 "key2" 0 "key3" 0 ]
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f 0 } f -1 } 2 }
+ [ double-rotate ] go-left
+ [ left>> dup key>> swap balance>> ] keep
+ [ right>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+[ "key1" 0 "key2" 1 "key3" 0 ]
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f -1 } f -1 } 2 }
+ [ double-rotate ] go-left
+ [ left>> dup key>> swap balance>> ] keep
+ [ right>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+
+[ "key1" 1 "key2" 0 "key3" 0 ]
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f -1 } 1 } f -2 }
+ [ double-rotate ] go-right
+ [ right>> dup key>> swap balance>> ] keep
+ [ left>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+[ "key1" 0 "key2" 0 "key3" 0 ]
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f 0 } 1 } f -2 }
+ [ double-rotate ] go-right
+ [ right>> dup key>> swap balance>> ] keep
+ [ left>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+[ "key1" 0 "key2" -1 "key3" 0 ]
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f 1 } 1 } f -2 }
+ [ double-rotate ] go-right
+ [ right>> dup key>> swap balance>> ] keep
+ [ left>> dup key>> swap balance>> ] keep
+ dup key>> swap balance>> ] unit-test
+
+[ "eight" ] [
+ <avl> "seven" 7 pick set-at
+ "eight" 8 pick set-at "nine" 9 pick set-at
+ root>> value>>
+] unit-test
+
+[ "another eight" ] [ ! ERROR!
+ <avl> "seven" 7 pick set-at
+ "another eight" 8 pick set-at 8 swap at
+] unit-test
+
+: test-tree ( -- tree )
+ AVL{
+ { 7 "seven" }
+ { 9 "nine" }
+ { 4 "four" }
+ { 4 "replaced four" }
+ { 7 "replaced seven" }
+ } clone ;
+
+! test set-at, at, at*
+[ t ] [ test-tree avl? ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
+[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
+[ "nine" ] [ test-tree 9 swap at ] unit-test
+[ "replaced four" ] [ test-tree 4 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 7 swap at ] unit-test
+
+! test delete-at--all errors!
+[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
+[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel generic math math.functions
+math.parser namespaces io sequences trees
+assocs parser accessors math.order prettyprint.custom ;
+IN: trees.avl
+
+TUPLE: avl < tree ;
+
+: <avl> ( -- tree )
+ avl new-tree ;
+
+TUPLE: avl-node < node balance ;
+
+: <avl-node> ( key value -- node )
+ avl-node new-node
+ 0 >>balance ;
+
+: increase-balance ( node amount -- )
+ swap [ + ] change-balance drop ;
+
+: rotate ( node -- node )
+ dup node+link dup node-link pick set-node+link
+ tuck set-node-link ;
+
+: single-rotate ( node -- node )
+ 0 over (>>balance) 0 over node+link
+ (>>balance) rotate ;
+
+: pick-balances ( a node -- balance balance )
+ balance>> {
+ { [ dup zero? ] [ 2drop 0 0 ] }
+ { [ over = ] [ neg 0 ] }
+ [ 0 swap ]
+ } cond ;
+
+: double-rotate ( node -- node )
+ [
+ node+link [
+ node-link current-side get neg
+ over pick-balances rot 0 swap (>>balance)
+ ] keep (>>balance)
+ ] keep swap >>balance
+ dup node+link [ rotate ] with-other-side
+ over set-node+link rotate ;
+
+: select-rotate ( node -- node )
+ dup node+link balance>> current-side get =
+ [ double-rotate ] [ single-rotate ] if ;
+
+: balance-insert ( node -- node taller? )
+ dup balance>> {
+ { [ dup zero? ] [ drop f ] }
+ { [ dup abs 2 = ]
+ [ sgn neg [ select-rotate ] with-side f ] }
+ { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
+ } cond ;
+
+DEFER: avl-set
+
+: avl-insert ( value key node -- node taller? )
+ 2dup key>> before? left right ? [
+ [ node-link avl-set ] keep swap
+ [ tuck set-node-link ] dip
+ [ dup current-side get increase-balance balance-insert ]
+ [ f ] if
+ ] with-side ;
+
+: (avl-set) ( value key node -- node taller? )
+ 2dup key>> = [
+ -rot pick (>>key) over (>>value) f
+ ] [ avl-insert ] if ;
+
+: avl-set ( value key node -- node taller? )
+ [ (avl-set) ] [ swap <avl-node> t ] if* ;
+
+M: avl set-at ( value key node -- node )
+ [ avl-set drop ] change-root drop ;
+
+: delete-select-rotate ( node -- node shorter? )
+ dup node+link balance>> zero? [
+ current-side get neg over (>>balance)
+ current-side get over node+link (>>balance) rotate f
+ ] [
+ select-rotate t
+ ] if ;
+
+: rebalance-delete ( node -- node shorter? )
+ dup balance>> {
+ { [ dup zero? ] [ drop t ] }
+ { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
+ { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
+ } cond ;
+
+: balance-delete ( node -- node shorter? )
+ current-side get over balance>> {
+ { [ dup zero? ] [ drop neg over (>>balance) f ] }
+ { [ dupd = ] [ drop 0 >>balance t ] }
+ [ dupd neg increase-balance rebalance-delete ]
+ } cond ;
+
+: avl-replace-with-extremity ( to-replace node -- node shorter? )
+ dup node-link [
+ swapd avl-replace-with-extremity [ over set-node-link ] dip
+ [ balance-delete ] [ f ] if
+ ] [
+ [ copy-node-contents drop ] keep node+link t
+ ] if* ;
+
+: replace-with-a-child ( node -- node shorter? )
+ #! assumes that node is not a leaf, otherwise will recurse forever
+ dup node-link [
+ dupd [ avl-replace-with-extremity ] with-other-side
+ [ over set-node-link ] dip [ balance-delete ] [ f ] if
+ ] [
+ [ replace-with-a-child ] with-other-side
+ ] if* ;
+
+: avl-delete-node ( node -- node shorter? )
+ #! delete this node, returning its replacement, and whether this subtree is
+ #! shorter as a result
+ dup leaf? [
+ drop f t
+ ] [
+ left [ replace-with-a-child ] with-side
+ ] if ;
+
+GENERIC: avl-delete ( key node -- node shorter? deleted? )
+
+M: f avl-delete ( key f -- f f f ) nip f f ;
+
+: (avl-delete) ( key node -- node shorter? deleted? )
+ tuck node-link avl-delete [
+ [ over set-node-link ] dip [ balance-delete ] [ f ] if
+ ] dip ;
+
+M: avl-node avl-delete ( key node -- node shorter? deleted? )
+ 2dup key>> key-side dup zero? [
+ drop nip avl-delete-node t
+ ] [
+ [ (avl-delete) ] with-side
+ ] if ;
+
+M: avl delete-at ( key node -- )
+ [ avl-delete 2drop ] change-root drop ;
+
+M: avl new-assoc 2drop <avl> ;
+
+: >avl ( assoc -- avl )
+ T{ avl f f 0 } assoc-clone-like ;
+
+M: avl assoc-like
+ drop dup avl? [ >avl ] unless ;
+
+: AVL{
+ \ } [ >avl ] parse-literal ; parsing
+
+M: avl pprint-delims drop \ AVL{ \ } ;
--- /dev/null
+Balanced AVL trees
--- /dev/null
+collections
--- /dev/null
+Mackenzie Straight
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup assocs ;
+IN: trees.splay
+
+HELP: SPLAY{
+{ $syntax "SPLAY{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an splay tree." } ;
+
+HELP: <splay>
+{ $values { "tree" splay } }
+{ $description "Creates an empty splay tree" } ;
+
+HELP: >splay
+{ $values { "assoc" assoc } { "tree" splay } }
+{ $description "Converts any " { $link assoc } " into an splay tree." } ;
+
+HELP: splay
+{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ;
+
+ARTICLE: "trees.splay" "Splay trees"
+"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol."
+{ $subsection splay }
+{ $subsection <splay> }
+{ $subsection >splay }
+{ $subsection POSTPONE: SPLAY{ } ;
+
+ABOUT: "trees.splay"
--- /dev/null
+! Copyright (c) 2005 Mackenzie Straight.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test trees.splay math namespaces assocs
+sequences random sets make grouping ;
+IN: trees.splay.tests
+
+: randomize-numeric-splay-tree ( splay-tree -- )
+ 100 [ drop 100 random swap at drop ] with each ;
+
+: make-numeric-splay-tree ( n -- splay-tree )
+ <splay> [ [ conjoin ] curry each ] keep ;
+
+[ t ] [
+ 100 make-numeric-splay-tree dup randomize-numeric-splay-tree
+ [ [ drop , ] assoc-each ] { } make [ < ] monotonic?
+] unit-test
+
+[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
+[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
+
+[ f ] [ <splay> f 4 pick set-at 4 swap at ] unit-test
+
+! Ensure that f can be a value
+[ t ] [ <splay> f 4 pick set-at 4 swap key? ] unit-test
+
+[
+{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
+] [
+{
+ { 4 "d" } { 5 "e" } { 6 "f" }
+ { 1 "a" } { 2 "b" } { 3 "c" }
+} >splay >alist
+] unit-test
--- /dev/null
+! Copyright (c) 2005 Mackenzie Straight.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math namespaces sequences assocs parser
+trees generic math.order accessors prettyprint.custom ;
+IN: trees.splay
+
+TUPLE: splay < tree ;
+
+: <splay> ( -- tree )
+ \ splay new-tree ;
+
+: rotate-right ( node -- node )
+ dup left>>
+ [ right>> swap (>>left) ] 2keep
+ [ (>>right) ] keep ;
+
+: rotate-left ( node -- node )
+ dup right>>
+ [ left>> swap (>>right) ] 2keep
+ [ (>>left) ] keep ;
+
+: link-right ( left right key node -- left right key node )
+ swap [ [ swap (>>left) ] 2keep
+ nip dup left>> ] dip swap ;
+
+: link-left ( left right key node -- left right key node )
+ swap [ rot [ (>>right) ] 2keep
+ drop dup right>> swapd ] dip swap ;
+
+: cmp ( key node -- obj node -1/0/1 )
+ 2dup key>> key-side ;
+
+: lcmp ( key node -- obj node -1/0/1 )
+ 2dup left>> key>> key-side ;
+
+: rcmp ( key node -- obj node -1/0/1 )
+ 2dup right>> key>> key-side ;
+
+DEFER: (splay)
+
+: splay-left ( left right key node -- left right key node )
+ dup left>> [
+ lcmp 0 < [ rotate-right ] when
+ dup left>> [ link-right (splay) ] when
+ ] when ;
+
+: splay-right ( left right key node -- left right key node )
+ dup right>> [
+ rcmp 0 > [ rotate-left ] when
+ dup right>> [ link-left (splay) ] when
+ ] when ;
+
+: (splay) ( left right key node -- left right key node )
+ cmp dup 0 <
+ [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
+
+: assemble ( head left right node -- root )
+ [ right>> swap (>>left) ] keep
+ [ left>> swap (>>right) ] keep
+ [ swap left>> swap (>>right) ] 2keep
+ [ swap right>> swap (>>left) ] keep ;
+
+: splay-at ( key node -- node )
+ [ T{ node } clone dup dup ] 2dip
+ (splay) nip assemble ;
+
+: splay ( key tree -- )
+ [ root>> splay-at ] keep (>>root) ;
+
+: splay-split ( key tree -- node node )
+ 2dup splay root>> cmp 0 < [
+ nip dup left>> swap f over (>>left)
+ ] [
+ nip dup right>> swap f over (>>right) swap
+ ] if ;
+
+: get-splay ( key tree -- node ? )
+ 2dup splay root>> cmp 0 = [
+ nip t
+ ] [
+ 2drop f f
+ ] if ;
+
+: get-largest ( node -- node )
+ dup [ dup right>> [ nip get-largest ] when* ] when ;
+
+: splay-largest ( node -- node )
+ dup [ dup get-largest key>> swap splay-at ] when ;
+
+: splay-join ( n2 n1 -- node )
+ splay-largest [
+ [ (>>right) ] keep
+ ] [
+ drop f
+ ] if* ;
+
+: remove-splay ( key tree -- )
+ tuck get-splay nip [
+ dup dec-count
+ dup right>> swap left>> splay-join
+ swap (>>root)
+ ] [ drop ] if* ;
+
+: set-splay ( value key tree -- )
+ 2dup get-splay [ 2nip (>>value) ] [
+ drop dup inc-count
+ 2dup splay-split rot
+ [ [ swapd ] dip node boa ] dip (>>root)
+ ] if ;
+
+: new-root ( value key tree -- )
+ 1 >>count
+ [ swap <node> ] dip (>>root) ;
+
+M: splay set-at ( value key tree -- )
+ dup root>> [ set-splay ] [ new-root ] if ;
+
+M: splay at* ( key tree -- value ? )
+ dup root>> [
+ get-splay [ dup [ value>> ] when ] dip
+ ] [
+ 2drop f f
+ ] if ;
+
+M: splay delete-at ( key tree -- )
+ dup root>> [ remove-splay ] [ 2drop ] if ;
+
+M: splay new-assoc
+ 2drop <splay> ;
+
+: >splay ( assoc -- tree )
+ T{ splay f f 0 } assoc-clone-like ;
+
+: SPLAY{
+ \ } [ >splay ] parse-literal ; parsing
+
+M: splay assoc-like
+ drop dup splay? [ >splay ] unless ;
+
+M: splay pprint-delims drop \ SPLAY{ \ } ;
--- /dev/null
+Splay trees
--- /dev/null
+collections
+trees
--- /dev/null
+Binary search trees
--- /dev/null
+collections
+trees
--- /dev/null
+USING: help.syntax help.markup assocs ;
+IN: trees
+
+HELP: TREE{
+{ $syntax "TREE{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an unbalanced tree." } ;
+
+HELP: <tree>
+{ $values { "tree" tree } }
+{ $description "Creates an empty unbalanced binary tree" } ;
+
+HELP: >tree
+{ $values { "assoc" assoc } { "tree" tree } }
+{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ;
+
+HELP: tree
+{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ;
+
+ARTICLE: "trees" "Binary search trees"
+"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol."
+{ $subsection tree }
+{ $subsection <tree> }
+{ $subsection >tree }
+{ $subsection POSTPONE: TREE{ } ;
+
+ABOUT: "trees"
--- /dev/null
+USING: trees assocs tools.test kernel sequences ;
+IN: trees.tests
+
+: test-tree ( -- tree )
+ TREE{
+ { 7 "seven" }
+ { 9 "nine" }
+ { 4 "four" }
+ { 4 "replaced four" }
+ { 7 "replaced seven" }
+ } clone ;
+
+! test set-at, at, at*
+[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 swap at* ] unit-test
+[ f f ] [ <tree> "seven" 7 pick set-at 8 swap at* ] unit-test
+[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
+[ "replaced four" ] [ test-tree 4 swap at ] unit-test
+[ "nine" ] [ test-tree 9 swap at ] unit-test
+
+! test delete-at
+[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
+[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test
+[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
+[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic math sequences arrays io namespaces
+prettyprint.private kernel.private assocs random combinators
+parser math.order accessors deques make prettyprint.custom ;
+IN: trees
+
+TUPLE: tree root count ;
+
+: new-tree ( class -- tree )
+ new
+ f >>root
+ 0 >>count ; inline
+
+: <tree> ( -- tree )
+ tree new-tree ;
+
+INSTANCE: tree assoc
+
+TUPLE: node key value left right ;
+
+: new-node ( key value class -- node )
+ new
+ swap >>value
+ swap >>key ;
+
+: <node> ( key value -- node )
+ node new-node ;
+
+SYMBOL: current-side
+
+CONSTANT: left -1
+CONSTANT: right 1
+
+: key-side ( k1 k2 -- n )
+ <=> {
+ { +lt+ [ -1 ] }
+ { +eq+ [ 0 ] }
+ { +gt+ [ 1 ] }
+ } case ;
+
+: go-left? ( -- ? ) current-side get left eq? ;
+
+: inc-count ( tree -- ) [ 1+ ] change-count drop ;
+
+: dec-count ( tree -- ) [ 1- ] change-count drop ;
+
+: node-link@ ( node ? -- node )
+ go-left? xor [ left>> ] [ right>> ] if ;
+
+: set-node-link@ ( left parent ? -- )
+ go-left? xor [ (>>left) ] [ (>>right) ] if ;
+
+: node-link ( node -- child ) f node-link@ ;
+
+: set-node-link ( child node -- ) f set-node-link@ ;
+
+: node+link ( node -- child ) t node-link@ ;
+
+: set-node+link ( child node -- ) t set-node-link@ ;
+
+: with-side ( side quot -- )
+ [ swap current-side set call ] with-scope ; inline
+
+: with-other-side ( quot -- )
+ current-side get neg swap with-side ; inline
+
+: go-left ( quot -- ) left swap with-side ; inline
+
+: go-right ( quot -- ) right swap with-side ; inline
+
+: leaf? ( node -- ? )
+ [ left>> ] [ right>> ] bi or not ;
+
+: random-side ( -- side )
+ left right 2array random ;
+
+: choose-branch ( key node -- key node-left/right )
+ 2dup key>> key-side [ node-link ] with-side ;
+
+: node-at* ( key node -- value ? )
+ [
+ 2dup key>> = [
+ nip value>> t
+ ] [
+ choose-branch node-at*
+ ] if
+ ] [ drop f f ] if* ;
+
+M: tree at* ( key tree -- value ? )
+ root>> node-at* ;
+
+: node-set ( value key node -- node )
+ 2dup key>> key-side dup 0 eq? [
+ drop nip swap >>value
+ ] [
+ [
+ [ node-link [ node-set ] [ swap <node> ] if* ] keep
+ [ set-node-link ] keep
+ ] with-side
+ ] if ;
+
+M: tree set-at ( value key tree -- )
+ [ [ node-set ] [ swap <node> ] if* ] change-root drop ;
+
+: valid-node? ( node -- ? )
+ [
+ dup dup left>> [ key>> swap key>> before? ] when*
+ [
+ dup dup right>> [ key>> swap key>> after? ] when* ] dip and swap
+ dup left>> valid-node? swap right>> valid-node? and and
+ ] [ t ] if* ;
+
+: valid-tree? ( tree -- ? ) root>> valid-node? ;
+
+: (node>alist) ( node -- )
+ [
+ [ left>> (node>alist) ]
+ [ [ key>> ] [ value>> ] bi 2array , ]
+ [ right>> (node>alist) ]
+ tri
+ ] when* ;
+
+M: tree >alist [ root>> (node>alist) ] { } make ;
+
+M: tree clear-assoc
+ 0 >>count
+ f >>root drop ;
+
+: copy-node-contents ( new old -- new )
+ [ key>> >>key ]
+ [ value>> >>value ] bi ;
+
+! Deletion
+DEFER: delete-node
+
+: (prune-extremity) ( parent node -- new-extremity )
+ dup node-link [
+ rot drop (prune-extremity)
+ ] [
+ tuck delete-node swap set-node-link
+ ] if* ;
+
+: prune-extremity ( node -- new-extremity )
+ #! remove and return the leftmost or rightmost child of this node.
+ #! assumes at least one child
+ dup node-link (prune-extremity) ;
+
+: replace-with-child ( node -- node )
+ dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
+
+: replace-with-extremity ( node -- node )
+ dup node-link dup node+link [
+ ! predecessor/successor is not the immediate child
+ [ prune-extremity ] with-other-side copy-node-contents
+ ] [
+ ! node-link is the predecessor/successor
+ drop replace-with-child
+ ] if ;
+
+: delete-node-with-two-children ( node -- node )
+ #! randomised to minimise tree unbalancing
+ random-side [ replace-with-extremity ] with-side ;
+
+: delete-node ( node -- node )
+ #! delete this node, returning its replacement
+ dup left>> [
+ dup right>> [
+ delete-node-with-two-children
+ ] [
+ left>> ! left but no right
+ ] if
+ ] [
+ dup right>> [
+ right>> ! right but not left
+ ] [
+ drop f ! no children
+ ] if
+ ] if ;
+
+: delete-bst-node ( key node -- node )
+ 2dup key>> key-side dup 0 eq? [
+ drop nip delete-node
+ ] [
+ [ tuck node-link delete-bst-node over set-node-link ] with-side
+ ] if ;
+
+M: tree delete-at
+ [ delete-bst-node ] change-root drop ;
+
+M: tree new-assoc
+ 2drop <tree> ;
+
+M: tree clone dup assoc-clone-like ;
+
+: >tree ( assoc -- tree )
+ T{ tree f f 0 } assoc-clone-like ;
+
+M: tree assoc-like drop dup tree? [ >tree ] unless ;
+
+: TREE{
+ \ } [ >tree ] parse-literal ; parsing
+
+M: tree assoc-size count>> ;
+M: tree pprint-delims drop \ TREE{ \ } ;
+M: tree >pprint-sequence >alist ;
+M: tree pprint-narrow? drop t ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
-
-IN: ui.gadgets.handler
-
-TUPLE: handler < wrapper table ;
-
-: <handler> ( child -- handler ) handler new-wrapper ;
-
-M: handler handle-gesture ( gesture gadget -- ? )
- tuck table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors
-kernel sequences models opengl math math.order namespaces
-ui.commands ui.gestures ui.render ui.gadgets
-ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ;
+kernel sequences models opengl math math.order namespaces call
+ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
+ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
+ui.gadgets.packs ;
IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ;
hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
- keep [ >label text-theme ] dip
+ [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
<presentation>
swap >>hook ; inline
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-! Copyright (C) 2009 Eduardo Cavazos
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax multiline ;
-IN: ui.gadgets.slate
-
-ARTICLE: "ui.gadgets.slate" "Slate gadget"
-{ $description "A gadget with an 'action' slot which should be set to a callable."}
-{ $heading "Example" }
-{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
-[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
-gadget."> } ;
-
-ABOUT: "ui.gadgets.slate"
+++ /dev/null
-! Copyright (C) 2009 Eduardo Cavazos
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
-
-IN: ui.gadgets.slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math
- opengl.gl ui.gadgets.worlds ;
-
-: width ( rect -- w ) dim>> first ;
-: height ( rect -- h ) dim>> second ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#! On Windows, white is { 253 253 253 } ?
[ 10 /i ] map ;
-: stride ( bitmap -- n ) width>> 3 * ;
-
: bitmap= ( bitmap1 bitmap2 -- ? )
- [
- dup [ [ height>> ] [ stride ] bi * ] [ array>> length ] bi = [
- [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi
- '[ _ head twiddle ] map
- ] unless
- ] bi@ = ;
+ [ bitmap>> twiddle ] bi@ = ;
: check-rendering ( gadget -- )
screenshot
[ render-output set-global ]
[
- "resource:extra/ui/render/test/reference.bmp" load-image
+ "vocab:ui/render/test/reference.bmp" load-image
bitmap= "is perfect" "needs work" ?
"Your UI rendering " prepend
message-window
3array <grid>
{ 5 5 } >>gap
COLOR: blue <grid-lines> >>boundary
- add-gadget
- <gadget>
- { 14 14 } >>dim
- COLOR: black <checkmark-paint> >>interior
- COLOR: black <solid> >>boundary
- { 4 4 } <border>
add-gadget ;
: ui-render-test ( -- )
USING: kernel classes strings quotations words math math.parser arrays
- combinators.cleave
+ combinators.smart
accessors
system prettyprint splitting
sequences combinators sequences.deep
: datestamp ( -- string )
now
- { year>> month>> day>> hour>> minute>> } <arr>
+ [ { [ year>> ] [ month>> ] [ day>> ] [ hour>> ] [ minute>> ] } cleave ] output>array
[ pad-00 ] map "-" join ;
TUPLE: irclog-app < dispatcher ;
-: irc-link ( -- string )
+: irc-link ( channel -- string )
gmt -7 hours convert-timezone >date<
[ unparse 2 tail ] 2dip
- "http://bespin.org/~nef/logs/concatenative/%02s.%02d.%02d"
+ "http://bespin.org/~nef/logs/%s/%02s.%02d.%02d"
sprintf ;
: <display-irclog-action> ( -- action )
<action>
- [ irc-link <redirect> ] >>display ;
+ [ "concatenative" irc-link <redirect> ] >>display ;
: <irclog-app> ( -- dispatcher )
irclog-app new-dispatcher
! LINKS, ETC
! ! !
-: pastebin-url ( -- url )
- URL" $pastebin/list" ;
+CONSTANT: pastebin-url URL" $pastebin/"
: paste-url ( id -- url )
"$pastebin/paste" >url swap "id" set-query-param ;
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
] with-transaction
- URL" $pastebin/list" <redirect>
+ pastebin-url <redirect>
] >>submit
<protected>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$planet/feed.xml">[ planet-factor ]</t:atom>
+
<t:title>[ planet-factor ]</t:title>
<table width="100%" cellpadding="10">
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+ <head>
+ <title>SiteWatcher</title>
+ </head>
+ <body>
+ <h1>SiteWatcher</h1>
+ <h2>It tells you if your web site goes down.</h2>
+ <table>
+ <t:bind-each t:name="sites">
+ <tr>
+ <td> <t:label t:name="url" /> </td>
+ <td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
+ </tr>
+ </t:bind-each>
+ </table>
+ <p>
+ <t:button t:action="$site-watcher-app/check">Check now</t:button>
+ </p>
+ <hr />
+ <h3>Add a new site</h3>
+ <t:form t:action="$site-watcher-app/add">
+ <table>
+ <tr>
+ <th>URL:</th>
+ <td> <t:field t:name="url" t:size="80" /> </td>
+ </tr>
+ <tr>
+ <th>E-mail:</th>
+ <td> <t:field t:name="email" t:size="80" /> </td>
+ </tr>
+ </table>
+ <p> <button type="submit">Done</button> </p>
+ </t:form>
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.alloy furnace.redirection
+html.forms http.server http.server.dispatchers namespaces site-watcher
+site-watcher.private kernel urls validators db.sqlite assocs ;
+IN: webapps.site-watcher
+
+TUPLE: site-watcher-app < dispatcher ;
+
+CONSTANT: site-list-url URL" $site-watcher-app/"
+
+: <site-list-action> ( -- action )
+ <page-action>
+ { site-watcher-app "site-list" } >>template
+ [
+ begin-form
+ sites get values "sites" set-value
+ ] >>init ;
+
+: <add-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } { "email" [ v-email ] } } validate-params
+ ] >>validate
+ [
+ "email" value "url" value watch-site
+ site-list-url <redirect>
+ ] >>submit ;
+
+: <remove-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ "url" value delete-site
+ site-list-url <redirect>
+ ] >>submit ;
+
+: <check-sites-action> ( -- action )
+ <action>
+ [
+ sites get [ check-sites ] [ report-sites ] bi
+ site-list-url <redirect>
+ ] >>submit ;
+
+: <site-watcher-app> ( -- dispatcher )
+ site-watcher-app new-dispatcher
+ <site-list-action> "" add-responder
+ <add-site-action> "add" add-responder
+ <remove-site-action> "remove" add-responder
+ <check-sites-action> "check" add-responder ;
+
+<site-watcher-app> "resource:test.db" <sqlite-db> <alloy> main-responder set-global
\ No newline at end of file
(defun fuel-markup--vocab-list (e)
(let ((rows (mapcar '(lambda (elem)
- (list (car elem)
- (list '$vocab-link (cadr elem))
- (caddr elem)))
+ (list (list '$vocab-link (car elem))
+ (cadr elem)))
(cdr e))))
(fuel-markup--table (cons '$table rows))))
(modify-syntax-entry ?\r " " table)
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
- (modify-syntax-entry ?\( "()" table)
- (modify-syntax-entry ?\) ")(" table)
table))
(defconst fuel-syntax--syntactic-keywords
- `(;; CHARs:
- ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
- ;; Comments:
+ `(;; Comments
("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
- ;; Strings
+ ;; Strings and chars
+ ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
+ (1 "w") (2 "\"") (4 "\""))
+ ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (5 "\""))
- ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
+ ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
+ ("\\_<(\\((\\)\\_>" (1 "()"))
+ ("\\_<\\()\\))\\_>" (1 ")("))
;; Quotations:
("\\_<'\\(\\[\\)\\_>" (1 "(]")) ; fried
("\\_<\\(\\[\\)\\_>" (1 "(]"))
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.functions tools.test combinators.cleave ;
+
+IN: combinators.cleave.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
+
+[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
+
+[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
+
+[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
+
--- /dev/null
+
+USING: kernel combinators words quotations arrays sequences locals macros
+ shuffle generalizations fry ;
+
+IN: combinators.cleave
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: [ncleave] ( SEQ N -- quot )
+ SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
+
+MACRO: ncleave ( seq n -- quot ) [ncleave] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Cleave into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
+
+MACRO: narr ( seq n -- array ) [narr] ;
+
+MACRO: 0arr ( seq -- array ) 0 [narr] ;
+MACRO: 1arr ( seq -- array ) 1 [narr] ;
+MACRO: 2arr ( seq -- array ) 2 [narr] ;
+MACRO: 3arr ( seq -- array ) 3 [narr] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ cleave _ narray ] ;
+
+MACRO: <2arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ 2cleave _ narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x -- {x} ) 1array ; inline
+: {2} ( x y -- {x,y} ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Spread into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr*> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ spread _ narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
--- /dev/null
+
+USING: combinators.cleave fry kernel macros parser quotations ;
+
+IN: combinators.cleave.enhanced
+
+: \\
+ scan-word literalize parsed
+ scan-word literalize parsed ; parsing
+
+MACRO: bi ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ keep ] dip call ] ;
+
+MACRO: tri ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
+
+MACRO: bi* ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ dip ] dip call ] ;
+
+MACRO: tri* ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
+
--- /dev/null
+
+USING: kernel combinators sequences macros fry newfx combinators.cleave ;
+
+IN: combinators.conditional
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1cond ( tbl -- )
+ [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
+ [ cond ] prefix-on ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: accessors effects.parser kernel lexer multi-methods
+ parser sequences words ;
+
+IN: multi-method-syntax
+
+! A nicer specializer syntax to hold us over till multi-methods go in
+! officially.
+!
+! Use both 'multi-methods' and 'multi-method-syntax' in that order.
+
+: scan-specializer ( -- specializer )
+
+ scan drop ! eat opening parenthesis
+
+ ")" parse-effect in>> [ search ] map ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-specializer swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
--- /dev/null
+
+USING: kernel sequences multi-methods accessors math.vectors ;
+
+IN: math.physics.pos
+
+TUPLE: pos pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: distance ( a b -- c )
+
+METHOD: distance { sequence sequence } v- norm ;
+
+METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: math.physics.pos ;
+
+IN: math.physics.vel
+
+TUPLE: vel < pos vel ;
+
+++ /dev/null
-Alex Chapman
-Daniel Ehrenberg
+++ /dev/null
-Alex Chapman
-Daniel Ehrenberg
+++ /dev/null
-USING: help.syntax help.markup assocs ;
-IN: trees.avl
-
-HELP: AVL{
-{ $syntax "AVL{ { key value }... }" }
-{ $values { "key" "a key" } { "value" "a value" } }
-{ $description "Literal syntax for an AVL tree." } ;
-
-HELP: <avl>
-{ $values { "tree" avl } }
-{ $description "Creates an empty AVL tree" } ;
-
-HELP: >avl
-{ $values { "assoc" assoc } { "avl" avl } }
-{ $description "Converts any " { $link assoc } " into an AVL tree." } ;
-
-HELP: avl
-{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ;
-
-ARTICLE: { "avl" "intro" } "AVL trees"
-"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol."
-{ $subsection avl }
-{ $subsection <avl> }
-{ $subsection >avl }
-{ $subsection POSTPONE: AVL{ } ;
-
-ABOUT: { "avl" "intro" }
+++ /dev/null
-USING: kernel tools.test trees trees.avl math random sequences assocs ;
-IN: trees.avl.tests
-
-[ "key1" 0 "key2" 0 ] [
- T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 }
- [ single-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance
-] unit-test
-
-[ "key1" 0 "key2" 0 ] [
- T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 }
- [ select-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance
-] unit-test
-
-[ "key1" 0 "key2" 0 ] [
- T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
- [ single-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance
-] unit-test
-
-[ "key1" 0 "key2" 0 ] [
- T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
- [ select-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance
-] unit-test
-
-[ "key1" -1 "key2" 0 "key3" 0 ]
-[ T{ avl-node f "key1" f f
- T{ avl-node f "key2" f
- T{ avl-node f "key3" f f f 1 } f -1 } 2 }
- [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node f "key1" f f
- T{ avl-node f "key2" f
- T{ avl-node f "key3" f f f 0 } f -1 } 2 }
- [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 1 "key3" 0 ]
-[ T{ avl-node f "key1" f f
- T{ avl-node f "key2" f
- T{ avl-node f "key3" f f f -1 } f -1 } 2 }
- [ double-rotate ] go-left
- [ node-left dup node-key swap avl-node-balance ] keep
- [ node-right dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-
-[ "key1" 1 "key2" 0 "key3" 0 ]
-[ T{ avl-node f "key1" f
- T{ avl-node f "key2" f f
- T{ avl-node f "key3" f f f -1 } 1 } f -2 }
- [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node f "key1" f
- T{ avl-node f "key2" f f
- T{ avl-node f "key3" f f f 0 } 1 } f -2 }
- [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-[ "key1" 0 "key2" -1 "key3" 0 ]
-[ T{ avl-node f "key1" f
- T{ avl-node f "key2" f f
- T{ avl-node f "key3" f f f 1 } 1 } f -2 }
- [ double-rotate ] go-right
- [ node-right dup node-key swap avl-node-balance ] keep
- [ node-left dup node-key swap avl-node-balance ] keep
- dup node-key swap avl-node-balance ] unit-test
-
-[ "eight" ] [
- <avl> "seven" 7 pick set-at
- "eight" 8 pick set-at "nine" 9 pick set-at
- tree-root node-value
-] unit-test
-
-[ "another eight" ] [ ! ERROR!
- <avl> "seven" 7 pick set-at
- "another eight" 8 pick set-at 8 swap at
-] unit-test
-
-: test-tree ( -- tree )
- AVL{
- { 7 "seven" }
- { 9 "nine" }
- { 4 "four" }
- { 4 "replaced four" }
- { 7 "replaced seven" }
- } clone ;
-
-! test set-at, at, at*
-[ t ] [ test-tree avl? ] unit-test
-[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
-[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
-[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
-[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
-[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
-[ "nine" ] [ test-tree 9 swap at ] unit-test
-[ "replaced four" ] [ test-tree 4 swap at ] unit-test
-[ "replaced seven" ] [ test-tree 7 swap at ] unit-test
-
-! test delete-at--all errors!
-[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
-[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
-[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel generic math math.functions
-math.parser namespaces io prettyprint.backend sequences trees
-assocs parser accessors math.order ;
-IN: trees.avl
-
-TUPLE: avl < tree ;
-
-: <avl> ( -- tree )
- avl new-tree ;
-
-TUPLE: avl-node < node balance ;
-
-: <avl-node> ( key value -- node )
- avl-node new-node
- 0 >>balance ;
-
-: increase-balance ( node amount -- )
- swap [ + ] change-balance drop ;
-
-: rotate ( node -- node )
- dup node+link dup node-link pick set-node+link
- tuck set-node-link ;
-
-: single-rotate ( node -- node )
- 0 over (>>balance) 0 over node+link
- (>>balance) rotate ;
-
-: pick-balances ( a node -- balance balance )
- balance>> {
- { [ dup zero? ] [ 2drop 0 0 ] }
- { [ over = ] [ neg 0 ] }
- [ 0 swap ]
- } cond ;
-
-: double-rotate ( node -- node )
- [
- node+link [
- node-link current-side get neg
- over pick-balances rot 0 swap (>>balance)
- ] keep (>>balance)
- ] keep swap >>balance
- dup node+link [ rotate ] with-other-side
- over set-node+link rotate ;
-
-: select-rotate ( node -- node )
- dup node+link balance>> current-side get =
- [ double-rotate ] [ single-rotate ] if ;
-
-: balance-insert ( node -- node taller? )
- dup avl-node-balance {
- { [ dup zero? ] [ drop f ] }
- { [ dup abs 2 = ]
- [ sgn neg [ select-rotate ] with-side f ] }
- { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
- } cond ;
-
-DEFER: avl-set
-
-: avl-insert ( value key node -- node taller? )
- 2dup node-key before? left right ? [
- [ node-link avl-set ] keep swap
- >r tuck set-node-link r>
- [ dup current-side get increase-balance balance-insert ]
- [ f ] if
- ] with-side ;
-
-: (avl-set) ( value key node -- node taller? )
- 2dup node-key = [
- -rot pick set-node-key over set-node-value f
- ] [ avl-insert ] if ;
-
-: avl-set ( value key node -- node taller? )
- [ (avl-set) ] [ swap <avl-node> t ] if* ;
-
-M: avl set-at ( value key node -- node )
- [ avl-set drop ] change-root drop ;
-
-: delete-select-rotate ( node -- node shorter? )
- dup node+link avl-node-balance zero? [
- current-side get neg over set-avl-node-balance
- current-side get over node+link set-avl-node-balance rotate f
- ] [
- select-rotate t
- ] if ;
-
-: rebalance-delete ( node -- node shorter? )
- dup avl-node-balance {
- { [ dup zero? ] [ drop t ] }
- { [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
- { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
- } cond ;
-
-: balance-delete ( node -- node shorter? )
- current-side get over balance>> {
- { [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
- { [ dupd = ] [ drop 0 >>balance t ] }
- [ dupd neg increase-balance rebalance-delete ]
- } cond ;
-
-: avl-replace-with-extremity ( to-replace node -- node shorter? )
- dup node-link [
- swapd avl-replace-with-extremity >r over set-node-link r>
- [ balance-delete ] [ f ] if
- ] [
- tuck copy-node-contents node+link t
- ] if* ;
-
-: replace-with-a-child ( node -- node shorter? )
- #! assumes that node is not a leaf, otherwise will recurse forever
- dup node-link [
- dupd [ avl-replace-with-extremity ] with-other-side
- >r over set-node-link r> [ balance-delete ] [ f ] if
- ] [
- [ replace-with-a-child ] with-other-side
- ] if* ;
-
-: avl-delete-node ( node -- node shorter? )
- #! delete this node, returning its replacement, and whether this subtree is
- #! shorter as a result
- dup leaf? [
- drop f t
- ] [
- left [ replace-with-a-child ] with-side
- ] if ;
-
-GENERIC: avl-delete ( key node -- node shorter? deleted? )
-
-M: f avl-delete ( key f -- f f f ) nip f f ;
-
-: (avl-delete) ( key node -- node shorter? deleted? )
- tuck node-link avl-delete >r >r over set-node-link r>
- [ balance-delete r> ] [ f r> ] if ;
-
-M: avl-node avl-delete ( key node -- node shorter? deleted? )
- 2dup node-key key-side dup zero? [
- drop nip avl-delete-node t
- ] [
- [ (avl-delete) ] with-side
- ] if ;
-
-M: avl delete-at ( key node -- )
- [ avl-delete 2drop ] change-root drop ;
-
-M: avl new-assoc 2drop <avl> ;
-
-: >avl ( assoc -- avl )
- T{ avl f f 0 } assoc-clone-like ;
-
-M: avl assoc-like
- drop dup avl? [ >avl ] unless ;
-
-: AVL{
- \ } [ >avl ] parse-literal ; parsing
-
-M: avl pprint-delims drop \ AVL{ \ } ;
+++ /dev/null
-Balanced AVL trees
+++ /dev/null
-collections
+++ /dev/null
-Mackenzie Straight
-Daniel Ehrenberg
+++ /dev/null
-USING: help.syntax help.markup assocs ;
-IN: trees.splay
-
-HELP: SPLAY{
-{ $syntax "SPLAY{ { key value }... }" }
-{ $values { "key" "a key" } { "value" "a value" } }
-{ $description "Literal syntax for an splay tree." } ;
-
-HELP: <splay>
-{ $values { "tree" splay } }
-{ $description "Creates an empty splay tree" } ;
-
-HELP: >splay
-{ $values { "assoc" assoc } { "tree" splay } }
-{ $description "Converts any " { $link assoc } " into an splay tree." } ;
-
-HELP: splay
-{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ;
-
-ARTICLE: { "splay" "intro" } "Splay trees"
-"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol."
-{ $subsection splay }
-{ $subsection <splay> }
-{ $subsection >splay }
-{ $subsection POSTPONE: SPLAY{ } ;
-
-ABOUT: { "splay" "intro" }
+++ /dev/null
-! Copyright (c) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test trees.splay math namespaces assocs
-sequences random sets ;
-IN: trees.splay.tests
-
-: randomize-numeric-splay-tree ( splay-tree -- )
- 100 [ drop 100 random swap at drop ] with each ;
-
-: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ conjoin ] curry each ] keep ;
-
-[ t ] [
- 100 make-numeric-splay-tree dup randomize-numeric-splay-tree
- [ [ drop , ] assoc-each ] { } make [ < ] monotonic?
-] unit-test
-
-[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
-[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
-
-[ f ] [ <splay> f 4 pick set-at 4 swap at ] unit-test
-
-! Ensure that f can be a value
-[ t ] [ <splay> f 4 pick set-at 4 swap key? ] unit-test
-
-[
-{ { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
-] [
-{
- { 4 "d" } { 5 "e" } { 6 "f" }
- { 1 "a" } { 2 "b" } { 3 "c" }
-} >splay >alist
-] unit-test
+++ /dev/null
-! Copyright (c) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math namespaces sequences assocs parser
-prettyprint.backend trees generic math.order ;
-IN: trees.splay
-
-TUPLE: splay < tree ;
-
-: <splay> ( -- tree )
- \ splay new-tree ;
-
-: rotate-right ( node -- node )
- dup node-left
- [ node-right swap set-node-left ] 2keep
- [ set-node-right ] keep ;
-
-: rotate-left ( node -- node )
- dup node-right
- [ node-left swap set-node-right ] 2keep
- [ set-node-left ] keep ;
-
-: link-right ( left right key node -- left right key node )
- swap >r [ swap set-node-left ] 2keep
- nip dup node-left r> swap ;
-
-: link-left ( left right key node -- left right key node )
- swap >r rot [ set-node-right ] 2keep
- drop dup node-right swapd r> swap ;
-
-: cmp ( key node -- obj node -1/0/1 )
- 2dup node-key key-side ;
-
-: lcmp ( key node -- obj node -1/0/1 )
- 2dup node-left node-key key-side ;
-
-: rcmp ( key node -- obj node -1/0/1 )
- 2dup node-right node-key key-side ;
-
-DEFER: (splay)
-
-: splay-left ( left right key node -- left right key node )
- dup node-left [
- lcmp 0 < [ rotate-right ] when
- dup node-left [ link-right (splay) ] when
- ] when ;
-
-: splay-right ( left right key node -- left right key node )
- dup node-right [
- rcmp 0 > [ rotate-left ] when
- dup node-right [ link-left (splay) ] when
- ] when ;
-
-: (splay) ( left right key node -- left right key node )
- cmp dup 0 <
- [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
-
-: assemble ( head left right node -- root )
- [ node-right swap set-node-left ] keep
- [ node-left swap set-node-right ] keep
- [ swap node-left swap set-node-right ] 2keep
- [ swap node-right swap set-node-left ] keep ;
-
-: splay-at ( key node -- node )
- >r >r T{ node } clone dup dup r> r>
- (splay) nip assemble ;
-
-: splay ( key tree -- )
- [ tree-root splay-at ] keep set-tree-root ;
-
-: splay-split ( key tree -- node node )
- 2dup splay tree-root cmp 0 < [
- nip dup node-left swap f over set-node-left
- ] [
- nip dup node-right swap f over set-node-right swap
- ] if ;
-
-: get-splay ( key tree -- node ? )
- 2dup splay tree-root cmp 0 = [
- nip t
- ] [
- 2drop f f
- ] if ;
-
-: get-largest ( node -- node )
- dup [ dup node-right [ nip get-largest ] when* ] when ;
-
-: splay-largest ( node -- node )
- dup [ dup get-largest node-key swap splay-at ] when ;
-
-: splay-join ( n2 n1 -- node )
- splay-largest [
- [ set-node-right ] keep
- ] [
- drop f
- ] if* ;
-
-: remove-splay ( key tree -- )
- tuck get-splay nip [
- dup dec-count
- dup node-right swap node-left splay-join
- swap set-tree-root
- ] [ drop ] if* ;
-
-: set-splay ( value key tree -- )
- 2dup get-splay [ 2nip set-node-value ] [
- drop dup inc-count
- 2dup splay-split rot
- >r >r swapd r> node boa r> set-tree-root
- ] if ;
-
-: new-root ( value key tree -- )
- [ 1 swap set-tree-count ] keep
- >r swap <node> r> set-tree-root ;
-
-M: splay set-at ( value key tree -- )
- dup tree-root [ set-splay ] [ new-root ] if ;
-
-M: splay at* ( key tree -- value ? )
- dup tree-root [
- get-splay >r dup [ node-value ] when r>
- ] [
- 2drop f f
- ] if ;
-
-M: splay delete-at ( key tree -- )
- dup tree-root [ remove-splay ] [ 2drop ] if ;
-
-M: splay new-assoc
- 2drop <splay> ;
-
-: >splay ( assoc -- tree )
- T{ splay f f 0 } assoc-clone-like ;
-
-: SPLAY{
- \ } [ >splay ] parse-literal ; parsing
-
-M: splay assoc-like
- drop dup splay? [ >splay ] unless ;
-
-M: splay pprint-delims drop \ SPLAY{ \ } ;
+++ /dev/null
-Splay trees
+++ /dev/null
-collections
-trees
+++ /dev/null
-Binary search trees
+++ /dev/null
-collections
-trees
+++ /dev/null
-USING: help.syntax help.markup assocs ;
-IN: trees
-
-HELP: TREE{
-{ $syntax "TREE{ { key value }... }" }
-{ $values { "key" "a key" } { "value" "a value" } }
-{ $description "Literal syntax for an unbalanced tree." } ;
-
-HELP: <tree>
-{ $values { "tree" tree } }
-{ $description "Creates an empty unbalanced binary tree" } ;
-
-HELP: >tree
-{ $values { "assoc" assoc } { "tree" tree } }
-{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ;
-
-HELP: tree
-{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ;
-
-ARTICLE: { "trees" "intro" } "Binary search trees"
-"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol."
-{ $subsection tree }
-{ $subsection <tree> }
-{ $subsection >tree }
-{ $subsection POSTPONE: TREE{ } ;
-
-IN: trees
-ABOUT: { "trees" "intro" }
+++ /dev/null
-USING: trees assocs tools.test kernel sequences ;
-IN: trees.tests
-
-: test-tree ( -- tree )
- TREE{
- { 7 "seven" }
- { 9 "nine" }
- { 4 "four" }
- { 4 "replaced four" }
- { 7 "replaced seven" }
- } clone ;
-
-! test set-at, at, at*
-[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
-[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 swap at* ] unit-test
-[ f f ] [ <tree> "seven" 7 pick set-at 8 swap at* ] unit-test
-[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
-[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
-[ "replaced four" ] [ test-tree 4 swap at ] unit-test
-[ "nine" ] [ test-tree 9 swap at ] unit-test
-
-! test delete-at
-[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
-[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
-[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test
-[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
-[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math sequences arrays io namespaces
-prettyprint.private kernel.private assocs random combinators
-parser prettyprint.backend math.order accessors ;
-IN: trees
-
-TUPLE: tree root count ;
-
-: new-tree ( class -- tree )
- new
- f >>root
- 0 >>count ; inline
-
-: <tree> ( -- tree )
- tree new-tree ;
-
-INSTANCE: tree assoc
-
-TUPLE: node key value left right ;
-
-: new-node ( key value class -- node )
- new swap >>value swap >>key ;
-
-: <node> ( key value -- node )
- node new-node ;
-
-SYMBOL: current-side
-
-: left ( -- symbol ) -1 ; inline
-: right ( -- symbol ) 1 ; inline
-
-: key-side ( k1 k2 -- n )
- <=> {
- { +lt+ [ -1 ] }
- { +eq+ [ 0 ] }
- { +gt+ [ 1 ] }
- } case ;
-
-: go-left? ( -- ? ) current-side get left eq? ;
-
-: inc-count ( tree -- ) [ 1+ ] change-count drop ;
-
-: dec-count ( tree -- ) [ 1- ] change-count drop ;
-
-: node-link@ ( node ? -- node )
- go-left? xor [ left>> ] [ right>> ] if ;
-: set-node-link@ ( left parent ? -- )
- go-left? xor [ set-node-left ] [ set-node-right ] if ;
-
-: node-link ( node -- child ) f node-link@ ;
-: set-node-link ( child node -- ) f set-node-link@ ;
-: node+link ( node -- child ) t node-link@ ;
-: set-node+link ( child node -- ) t set-node-link@ ;
-
-: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
-: with-other-side ( quot -- )
- current-side get neg swap with-side ; inline
-: go-left ( quot -- ) left swap with-side ; inline
-: go-right ( quot -- ) right swap with-side ; inline
-
-: leaf? ( node -- ? )
- [ left>> ] [ right>> ] bi or not ;
-
-: random-side ( -- side ) left right 2array random ;
-
-: choose-branch ( key node -- key node-left/right )
- 2dup node-key key-side [ node-link ] with-side ;
-
-: node-at* ( key node -- value ? )
- [
- 2dup node-key = [
- nip node-value t
- ] [
- choose-branch node-at*
- ] if
- ] [ drop f f ] if* ;
-
-M: tree at* ( key tree -- value ? )
- root>> node-at* ;
-
-: node-set ( value key node -- node )
- 2dup key>> key-side dup 0 eq? [
- drop nip swap >>value
- ] [
- [
- [ node-link [ node-set ] [ swap <node> ] if* ] keep
- [ set-node-link ] keep
- ] with-side
- ] if ;
-
-M: tree set-at ( value key tree -- )
- [ [ node-set ] [ swap <node> ] if* ] change-root drop ;
-
-: valid-node? ( node -- ? )
- [
- dup dup left>> [ node-key swap node-key before? ] when* >r
- dup dup right>> [ node-key swap node-key after? ] when* r> and swap
- dup left>> valid-node? swap right>> valid-node? and and
- ] [ t ] if* ;
-
-: valid-tree? ( tree -- ? ) root>> valid-node? ;
-
-: (node>alist) ( node -- )
- [
- [ left>> (node>alist) ]
- [ [ node-key ] [ node-value ] bi 2array , ]
- [ right>> (node>alist) ]
- tri
- ] when* ;
-
-M: tree >alist [ root>> (node>alist) ] { } make ;
-
-M: tree clear-assoc
- 0 >>count
- f >>root drop ;
-
-: copy-node-contents ( new old -- )
- dup node-key pick set-node-key node-value swap set-node-value ;
-
-! Deletion
-DEFER: delete-node
-
-: (prune-extremity) ( parent node -- new-extremity )
- dup node-link [
- rot drop (prune-extremity)
- ] [
- tuck delete-node swap set-node-link
- ] if* ;
-
-: prune-extremity ( node -- new-extremity )
- #! remove and return the leftmost or rightmost child of this node.
- #! assumes at least one child
- dup node-link (prune-extremity) ;
-
-: replace-with-child ( node -- node )
- dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
-
-: replace-with-extremity ( node -- node )
- dup node-link dup node+link [
- ! predecessor/successor is not the immediate child
- [ prune-extremity ] with-other-side dupd copy-node-contents
- ] [
- ! node-link is the predecessor/successor
- drop replace-with-child
- ] if ;
-
-: delete-node-with-two-children ( node -- node )
- #! randomised to minimise tree unbalancing
- random-side [ replace-with-extremity ] with-side ;
-
-: delete-node ( node -- node )
- #! delete this node, returning its replacement
- dup left>> [
- dup right>> [
- delete-node-with-two-children
- ] [
- left>> ! left but no right
- ] if
- ] [
- dup right>> [
- right>> ! right but not left
- ] [
- drop f ! no children
- ] if
- ] if ;
-
-: delete-bst-node ( key node -- node )
- 2dup node-key key-side dup 0 eq? [
- drop nip delete-node
- ] [
- [ tuck node-link delete-bst-node over set-node-link ] with-side
- ] if ;
-
-M: tree delete-at
- [ delete-bst-node ] change-root drop ;
-
-M: tree new-assoc
- 2drop <tree> ;
-
-M: tree clone dup assoc-clone-like ;
-
-: >tree ( assoc -- tree )
- T{ tree f f 0 } assoc-clone-like ;
-
-M: tree assoc-like drop dup tree? [ >tree ] unless ;
-
-: TREE{
- \ } [ >tree ] parse-literal ; parsing
-
-M: tree pprint-delims drop \ TREE{ \ } ;
-M: tree assoc-size count>> ;
-M: tree >pprint-sequence >alist ;
-M: tree pprint-narrow? drop t ;
projects / factor.git / commitdiff
