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
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math kernel byte-arrays cairo.ffi cairo
-io.backend ui.gadgets accessors opengl.gl arrays fry
-classes ui.render namespaces destructors libc ;
-IN: cairo.gadgets
-
-<PRIVATE
-: width>stride ( width -- stride ) 4 * ;
-
-: image-dims ( gadget -- width height stride )
- dim>> first2 over width>stride ; inline
-: image-buffer ( width height stride -- alien )
- * nip malloc ; inline
-PRIVATE>
-
-GENERIC: render-cairo* ( gadget -- )
-
-: render-cairo ( gadget -- alien )
- [
- image-dims
- [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
-
-TUPLE: cairo-gadget < gadget ;
-
-: <cairo-gadget> ( dim -- gadget )
- cairo-gadget new
- swap >>dim ;
-
-M: cairo-gadget draw-gadget*
- [
- [ dim>> ] [ render-cairo &free ] bi
- origin get first2 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
- glDrawPixels
- ] with-destructors ;
-
-: copy-surface ( surface -- )
- cr swap 0 0 cairo_set_source_surface
- cr cairo_paint ;
+++ /dev/null
-UI gadget for rendering graphics with Cairo
[ 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
! 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 ]
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval strings ;
IN: compiler.tests
-GENERIC: method-redefine-test ( a -- b )
+GENERIC: method-redefine-generic-1 ( a -- b )
-M: integer method-redefine-test 3 + ;
+M: integer method-redefine-generic-1 3 + ;
-: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ;
[ 6 ] [ method-redefine-test-1 ] unit-test
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
-[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
+[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
+GENERIC: method-redefine-generic-2 ( a -- b )
+
+M: integer method-redefine-generic-2 3 + ;
+
+: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ;
+
+[ 6 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [
+ [
+ fixnum string [ \ method-redefine-generic-2 method forget ] bi@
+ ] with-compilation-unit
+] unit-test
+
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;
[ 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 -- ? )
{
! we are more eager to inline
SYMBOL: node-count
-: count-nodes ( nodes -- )
- 0 swap [ drop 1+ ] each-node node-count set ;
+: count-nodes ( nodes -- n )
+ 0 swap [ drop 1+ ] each-node ;
+
+: compute-node-count ( nodes -- ) count-nodes node-count set ;
! We try not to inline the same word too many times, to avoid
! combinatorial explosion
M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ;
-: propagate-body ( #call -- )
- body>> (propagate) ;
-
! Dispatch elimination
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
- propagate-body t
+ body>> (propagate) t
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
: inline-word-def ( #call word quot -- ? )
over history get memq? [ 3drop f ] [
[
- swap remember-inlining
- dupd splicing-nodes >>body
- propagate-body
- ] with-scope
+ [ remember-inlining ] dip
+ [ drop ] [ splicing-nodes ] 2bi
+ [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
+ ] with-scope node-count +@
t
] if ;
! [ 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
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
H{ } clone inlining-count set
- dup count-nodes
+ dup compute-node-count
dup (propagate) ;
} 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 )
--- /dev/null
+extensions
-! 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
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" ;
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup delegate.private ;
IN: delegate
HELP: define-protocol
HELP: PROTOCOL:
{ $syntax "PROTOCOL: protocol-name words... ;" }
-{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
+{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ;
{ 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:
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
+HELP: SLOT-PROTOCOL:
+{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
+{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+
+{ define-protocol POSTPONE: PROTOCOL: } related-words
+
{ define-consult POSTPONE: CONSULT: } related-words
HELP: group-words
"Defining new protocols:"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
+"Defining new protocols consisting of slot accessors:"
+{ $subsection POSTPONE: SLOT-PROTOCOL: }
"Defining consultation:"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline ;
+accessors eval multiline generic.standard delegate.protocols
+delegate.private assocs see ;
IN: delegate.tests
TUPLE: hello this that ;
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
-[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
+[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
[ ] [ T{ a-tuple } do-me ] unit-test
+! Change method definition to consultation
[ [ ] ] [
<" IN: delegate.tests
USE: kernel
CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
] unit-test
+! Method should be there
[ ] [ T{ a-tuple } do-me ] unit-test
+! Now try removing the consulation
+[ [ ] ] [
+ <" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
+] unit-test
+
+! Method should be gone
+[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
+
! A slot protocol issue
DEFER: slot-protocol-test-3
SLOT: y
-[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
<" IN: delegate.tests
<string-reader> "delegate-test-1" parse-stream
] unit-test
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
<" IN: delegate.tests
<string-reader> "delegate-test-1" parse-stream
] unit-test
-[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
\ No newline at end of file
+! We now have a real accessor for the y slot; we don't want it to
+! get lost
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+! We want to be able to override methods after consultation
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: delegate kernel sequences delegate.protocols accessors ;
+ TUPLE: override-method-test seq ;
+ CONSULT: sequence-protocol override-method-test seq>> ;
+ M: override-method-test like drop ; ">
+ <string-reader> "delegate-test-2" parse-stream
+] unit-test
+
+DEFER: seq-delegate
+
+! See if removing a consultation updates protocol-consult word prop
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: accessors delegate delegate.protocols ;
+ TUPLE: seq-delegate seq ;
+ CONSULT: sequence-protocol seq-delegate seq>> ;">
+ <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ t ] [
+ seq-delegate
+ sequence-protocol \ protocol-consult word-prop
+ key?
+] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: delegate delegate.protocols ;
+ TUPLE: seq-delegate seq ;">
+ <string-reader> "remove-consult-test" parse-stream
+] unit-test
+
+[ f ] [
+ seq-delegate
+ sequence-protocol \ protocol-consult word-prop
+ key?
+] unit-test
\ No newline at end of file
! Portions copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions generic
-generic.standard hashtables kernel lexer make math parser
-generic.parser sequences sets slots words words.symbol fry ;
+generic.standard hashtables kernel lexer math parser
+generic.parser sequences sets slots words words.symbol fry
+compiler.units ;
IN: delegate
+<PRIVATE
+
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
! Consultation
-: consult-method ( word class quot -- )
- [ drop swap first create-method-in ]
- [ nip [ swap [ second [ [ dip ] curry ] times % ] [ first , ] bi ] [ ] make ] 3bi
+TUPLE: consultation group class quot loc ;
+
+: <consultation> ( group class quot -- consultation )
+ f consultation boa ;
+
+: create-consult-method ( word consultation -- method )
+ [ class>> swap first create-method dup fake-definition ] keep
+ [ drop ] [ "consultation" set-word-prop ] 2bi ;
+
+PREDICATE: consult-method < method-body "consultation" word-prop ;
+
+M: consult-method reset-word
+ [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
+
+: consult-method-quot ( quot word -- object )
+ [ second [ [ dip ] curry ] times ] [ first ] bi
+ '[ _ call _ execute ] ;
+
+: consult-method ( word consultation -- )
+ [ create-consult-method ]
+ [ quot>> swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
[ swap props>> ] dip change-at ; inline
-: register-protocol ( group class quot -- )
- [ \ protocol-consult ] 2dip
- '[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
+: each-generic ( consultation quot -- )
+ [ [ group>> group-words ] keep ] dip curry each ; inline
+
+: register-consult ( consultation -- )
+ [ group>> \ protocol-consult ] [ ] [ class>> ] tri
+ '[ [ _ _ ] dip ?set-at ] change-word-prop ;
+
+: consult-methods ( consultation -- )
+ [ consult-method ] each-generic ;
+
+: unregister-consult ( consultation -- )
+ [ class>> ] [ group>> ] bi
+ \ protocol-consult word-prop delete-at ;
+
+: unconsult-method ( word consultation -- )
+ [ class>> swap first method ] keep
+ over [
+ over "consultation" word-prop eq?
+ [ forget ] [ drop ] if
+ ] [ 2drop ] if ;
-: define-consult ( group class quot -- )
- [ register-protocol ]
- [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
- 3bi ;
+: unconsult-methods ( consultation -- )
+ [ unconsult-method ] each-generic ;
+
+PRIVATE>
+
+: define-consult ( consultation -- )
+ [ register-consult ] [ consult-methods ] bi ;
: CONSULT:
- scan-word scan-word parse-definition define-consult ; parsing
+ scan-word scan-word parse-definition <consultation>
+ [ save-location ] [ define-consult ] bi ; parsing
+
+M: consultation where loc>> ;
+
+M: consultation set-where (>>loc) ;
+
+M: consultation forget*
+ [ unconsult-methods ] [ unregister-consult ] bi ;
! Protocols
+<PRIVATE
: cross-2each ( seq1 seq2 quot -- )
[ with each ] 2curry each ; inline
swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
- [ drop protocol-consult >alist ] [ added-words ] 2bi
- [ swap first2 consult-method ] cross-2each ;
+ [ drop protocol-consult values ] [ added-words ] 2bi
+ [ swap consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+PRIVATE>
+
: define-protocol ( protocol wordlist -- )
[ drop define-symbol ] [
fill-in-depth
M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ;
-: show-words ( wordlist' -- wordlist )
- [ dup second zero? [ first ] when ] map ;
M: protocol definition protocol-words show-words ;
--- /dev/null
+extensions
[ "<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 [
M: object deep-fry , ;
-: '[ \ ] parse-until fry over push-all ; parsing
+: '[ parse-quotation fry over push-all ; parsing
functor-words use get delq ;
: parse-functor-body ( -- form )
- t in-lambda? [
- V{ } clone
- push-functor-words
- "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
- <let*> parsed-lambda
- pop-functor-words
- >quotation
- ] with-variable ;
+ push-functor-words
+ "WHERE" parse-bindings*
+ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
+ pop-functor-words ;
: (FUNCTOR:) ( -- word def )
- CREATE
- parse-locals dup push-locals
- parse-functor-body swap pop-locals <lambda>
- rewrite-closures first ;
+ CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
PRIVATE>
[ 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
[ "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
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
swap >>width
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
+ t >>upside-down?
] ;
: bgr>bitmap ( array height width -- bitmap )
{ R32G32B32A32 [ 16 ] }
} case ;
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
M: ABGR normalize-component-order*
drop ARGB>RGBA 4 BGR>RGB ;
-GENERIC: normalize-scan-line-order ( image -- image )
-
-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 ;
: 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*
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
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private accessors sequences.private
-io.streams.sequence destructors ;
+io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
M: byte-reader stream-read-until sequence-read-until ;
M: byte-reader dispose drop ;
+M: byte-reader stream-seek ( n seek-type stream -- )
+ swap {
+ { seek-absolute [ (>>i) ] }
+ { seek-relative [ [ + ] change-i drop ] }
+ { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
+ [ bad-seek-type ]
+ } case ;
+
: <byte-reader> ( byte-array encoding -- stream )
[ B{ } like 0 byte-reader boa ] dip <decoder> ;
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 -- )
! 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 ;
M: :>-outside-lambda-error summary
drop ":> cannot be used outside of lambda expressions" ;
-ERROR: bad-lambda-rewrite output ;
+ERROR: bad-local args obj ;
-M: bad-lambda-rewrite summary
+M: bad-local summary
drop "You have found a bug in locals. Please report." ;
-ERROR: bad-local args obj ;
+ERROR: bad-rewrite args obj ;
-M: bad-local summary
+M: bad-rewrite summary
drop "You have found a bug in locals. Please report." ;
USING: help.syntax help.markup kernel macros prettyprint
-memoize combinators arrays generalizations ;
+memoize combinators arrays generalizations see ;
IN: locals
HELP: [|
"ordinary-word-test ordinary-word-test eq? ."
"t"
}
-"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+"In a word with locals, literals which do not contain locals still behave in the same way:"
{ $example
"USE: locals"
"IN: scratchpad"
"TUPLE: person first-name last-name ;"
- ":: ordinary-word-test ( -- tuple )"
+ ":: locals-word-test ( -- tuple )"
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
- "ordinary-word-test ordinary-word-test eq? ."
+ "locals-word-test locals-word-test eq? ."
+ "t"
+}
+"However, literals with locals in them actually expand into code for constructing a new object:"
+{ $example
+ "USING: locals splitting ;"
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ":: constructor-test ( -- tuple )"
+ " \"Jane Smith\" \" \" split1 :> last :> first"
+ " T{ person { first-name first } { last-name last } } ;"
+ "constructor-test constructor-test eq? ."
"f"
}
"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
{ $heading "Example" }
-"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+"Here is an implementation of the " { $link 3array } " word which uses this feature:"
{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
ARTICLE: "locals-mutable" "Mutable locals"
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 ;
[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
:: literal-identity-test ( -- a b )
- { } V{ } ;
+ { 1 } V{ } ;
-[ t f ] [
+[ t t ] [
literal-identity-test
literal-identity-test
- swapd [ eq? ] [ eq? ] 2bi*
+ [ eq? ] [ eq? ] bi-curry* bi*
] unit-test
:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
- "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+ "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
+ eval call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
-
+
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
] unit-test
-! Discovered by littledan
+! littledan found this problem
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
! erg found this problem
-:: erg's-:>-bug ( n ? -- n ) [ n :> n n ] [ n :> b b ] if ;
+:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
[ 3 ] [ 3 f erg's-:>-bug ] unit-test
-[ 3 ] [ 3 t erg's-:>-bug ] unit-test
\ No newline at end of file
+[ 3 ] [ 3 t erg's-:>-bug ] unit-test
+
+:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
+
+[ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
+
+[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test
+
+! dharmatech found this problem
+GENERIC: ed's-bug ( a -- b )
+
+M: string ed's-bug reverse ;
+M: integer ed's-bug neg ;
+
+:: ed's-test-case ( a -- b )
+ { [ a ed's-bug ] } && ;
+
+[ t ] [ \ ed's-test-case optimized>> ] unit-test
\ No newline at end of file
scan locals get [ :>-outside-lambda-error ] unless*
[ make-local ] bind <def> parsed ; parsing
-: [| parse-lambda parsed-lambda ; parsing
+: [| parse-lambda over push-all ; parsing
-: [let
- "|" expect "|" parse-bindings
- \ ] (parse-lambda) <let> parsed-lambda ; parsing
+: [let parse-let over push-all ; parsing
-: [let*
- "|" expect "|" parse-bindings*
- \ ] (parse-lambda) <let*> parsed-lambda ; parsing
+: [let* parse-let* over push-all ; parsing
-: [wlet
- "|" expect "|" parse-wbindings
- \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
+: [wlet parse-wlet over push-all ; parsing
: :: (::) define ; parsing
: MEMO:: (::) define-memoized ; parsing
+USE: syntax
+
{
"locals.macros"
"locals.fry"
quotations sequences splitting words vocabs.parser ;
IN: locals.parser
+SYMBOL: in-lambda?
+
+: ?rewrite-closures ( form -- form' )
+ in-lambda? get [ 1array ] [ rewrite-closures ] if ;
+
: make-local ( name -- word )
"!" ?tail [
<local-reader>
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
-SYMBOL: locals
-
: push-locals ( assoc -- )
use get push ;
: pop-locals ( assoc -- )
- use get delete ;
+ use get delq ;
-SYMBOL: in-lambda?
+SINGLETON: lambda-parser
-: (parse-lambda) ( assoc end -- quot )
- [
+SYMBOL: locals
+
+: ((parse-lambda)) ( assoc quot -- quot' )
+ '[
in-lambda? on
- over locals set
- over push-locals
- parse-until >quotation
- swap pop-locals
- ] with-scope ;
+ lambda-parser quotation-parser set
+ [ locals set ] [ push-locals @ ] [ pop-locals ] tri
+ ] with-scope ; inline
+
+: (parse-lambda) ( assoc -- quot )
+ [ \ ] parse-until >quotation ] ((parse-lambda)) ;
: parse-lambda ( -- lambda )
"|" parse-tokens make-locals
- \ ] (parse-lambda) <lambda> ;
+ (parse-lambda) <lambda>
+ ?rewrite-closures ;
+
+M: lambda-parser parse-quotation ( -- quotation )
+ H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
scan {
: parse-bindings ( end -- bindings vars )
[ (parse-bindings) ] with-bindings ;
+: parse-let ( -- form )
+ "|" expect "|" parse-bindings
+ (parse-lambda) <let> ?rewrite-closures ;
+
: parse-bindings* ( end -- words assoc )
[
namespace push-locals
namespace pop-locals
] with-bindings ;
+: parse-let* ( -- form )
+ "|" expect "|" parse-bindings*
+ (parse-lambda) <let*> ?rewrite-closures ;
+
: (parse-wbindings) ( end -- )
dup parse-binding dup [
first2 [ make-local-word ] keep 2array ,
: parse-wbindings ( end -- bindings vars )
[ (parse-wbindings) ] with-bindings ;
+: parse-wlet ( -- form )
+ "|" expect "|" parse-wbindings
+ (parse-lambda) <wlet> ?rewrite-closures ;
+
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals ;
-: parse-locals-definition ( word -- word quot )
- parse-locals \ ; (parse-lambda) <lambda>
+: parse-locals-definition ( word reader -- word quot )
+ [ parse-locals ] dip
+ ((parse-lambda)) <lambda>
[ "lambda" set-word-prop ]
- [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
+ [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
-: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
+: (::) ( -- word def )
+ CREATE-WORD
+ [ parse-definition ]
+ parse-locals-definition ;
: (M::) ( -- word def )
CREATE-METHOD
- [ parse-locals-definition ] with-method-definition ;
-
-: parsed-lambda ( accum form -- accum )
- in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;
+ [
+ [ parse-definition ]
+ parse-locals-definition
+ ] with-method-definition ;
\ No newline at end of file
M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
-M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
+M: vector rewrite-literal? [ rewrite-literal? ] any? ;
-M: hashtable rewrite-literal? drop t ;
+M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
-M: vector rewrite-literal? drop t ;
+M: hashtable rewrite-literal? >alist rewrite-literal? ;
-M: tuple rewrite-literal? drop t ;
+M: tuple rewrite-literal? tuple>array rewrite-literal? ;
M: object rewrite-literal? drop f ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
-M: vector rewrite-element rewrite-sequence ;
+M: vector rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
-M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+M: hashtable rewrite-element
+ dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
M: tuple rewrite-element
- [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
+ dup rewrite-literal? [
+ [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] %
+ ] [ , ] if ;
M: quotation rewrite-element rewrite-sugar* ;
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 }
[ words>values ] dip '[ _ _ (all-enabled) ] ;
MACRO: all-enabled-client-state ( seq quot -- )
- [ words>values ] dip '[ _ (all-enabled-client-state) ] ;
+ [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
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 ;
#! 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
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: 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 -- )
[
[ [ 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. nl 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" "Regular expression combinators"
+"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
+{ $subsection <literal> }
+{ $subsection <nothing> }
+{ $subsection <or> }
+{ $subsection <and> }
+{ $subsection <not> }
+{ $subsection <sequence> }
+{ $subsection <zero-or-more> }
+{ $subsection <one-or-more> }
+{ $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 call 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 -- )
+ [ ! with-compilation-unit doesn't compile, so we need call( -- )
+ [
+ '[
+ dup _ word>quot
+ (( last-match index string -- ? ))
+ define-declared
+ ] each
+ ] with-compilation-unit
+ ] call( words dfa -- ) ;
+
+: 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 ] call( quot effect -- word ) ;
+
+: 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.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 ;
IN: regexp
+ABOUT: "regexp"
+
+ARTICLE: "regexp" "Regular expressions"
+"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
+{ $subsection { "regexp" "syntax" } }
+{ $subsection { "regexp" "construction" } }
+{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
+{ $subsection { "regexp" "operations" } }
+{ $subsection regexp }
+{ $subsection { "regexp" "theory" } } ;
+
+ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
+"Words which are useful for creating regular expressions:"
+{ $subsection POSTPONE: R/ }
+{ $subsection <regexp> }
+{ $subsection <optioned-regexp> }
+{ $heading "See also" }
+{ $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." $nl
+"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
+"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
+"A distinction from Perl is that " { $snippet "\\G" } ", 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" "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"
+{ $subsection matches? }
+{ $subsection re-contains? }
+{ $subsection first-match }
+{ $subsection all-matching-slices }
+{ $subsection all-matching-subseqs }
+{ $subsection re-split }
+{ $subsection re-replace }
+{ $subsection count-matches } ;
+
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" string } { "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/i" }
+{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
+
+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
"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 )
[
[ [ [ 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
USING: tools.test tools.annotations tools.time math parser eval
-io.streams.string kernel ;
+io.streams.string kernel strings ;
IN: tools.annotations.tests
: foo ;
{ string blah-generic } watch
-[ ] [ "hi" blah-generic ] unit-test
\ No newline at end of file
+[ "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 )
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
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 -- )
[
M: vocab-tag article-content
\ $tagged-vocabs swap name>> 2array ;
-M: vocab-tag article-parent drop "vocab-index" ;
+M: vocab-tag article-parent drop "vocab-tags" ;
M: vocab-tag summary article-title ;
M: vocab-author article-content
\ $authored-vocabs swap name>> 2array ;
-M: vocab-author article-parent drop "vocab-index" ;
+M: vocab-author article-parent drop "vocab-authors" ;
M: vocab-author summary article-title ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.backend ui.gadgets
-ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-classes.tuple colors accessors ;
+USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl
+opengl.gl kernel namespaces classes.tuple colors colors.constants
+accessors ;
IN: ui.gadgets.canvas
TUPLE: canvas < gadget dlist ;
: new-canvas ( class -- canvas )
- new black <solid> >>interior ; inline
+ new COLOR: black <solid> >>interior ; inline
: delete-canvas-dlist ( canvas -- )
[ find-gl-context ]
[ 2nip ] [ drop make-canvas-dlist ] if ; inline
: draw-canvas ( canvas quot -- )
- origin get [
- cache-canvas-dlist glCallList
- ] with-translation ; inline
+ cache-canvas-dlist glCallList ; inline
M: canvas ungraft* delete-canvas-dlist ;
--- /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
{ 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 -- )
{ $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 } ;
{ $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
+
+<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
+USING: colors help.markup help.syntax ui.pens ;
IN: ui.pens.polygon
-USING: help.markup help.syntax ;
HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: accessors colors help.markup help.syntax kernel opengl
+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
--- /dev/null
+unportable
[ [ 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
{ $operations \ word }
{ $command-map interactor "quotation" }
{ $heading "Editing commands" }
-"The text editing commands are standard; see " { $link "ui.gadgets.editors" } "."
+"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
! 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
[ 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" }
+++ /dev/null
-Windows UI backend
+++ /dev/null
-X11 UI backend
+++ /dev/null
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-ui.event-loop assocs kernel math namespaces opengl sequences
-strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
-x11.constants x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators combinators.short-circuit command-line
-math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ascii ;
-IN: ui.x11
-
-SINGLETON: x11-ui-backend
-
-: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-
-TUPLE: x11-handle-base glx ;
-TUPLE: x11-handle < x11-handle-base xic window ;
-TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
-
-C: <x11-handle> x11-handle
-C: <x11-pixmap-handle> x11-pixmap-handle
-
-M: world expose-event nip relayout ;
-
-M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
- ! In case dimensions didn't change
- relayout-1 ;
-
-CONSTANT: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- }
-
-CONSTANT: key-codes
- H{
- { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RET" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESC" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE_UP" }
- { HEX: FF56 "PAGE_DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- }
-
-: key-code ( keysym -- keycode action? )
- dup key-codes at [ t ] [ 1string f ] ?if ;
-
-: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
-
-: valid-input? ( string gesture -- ? )
- over empty? [ 2drop f ] [
- mods>> { f { S+ } } member? [
- [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
- ] [
- [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
- ] if
- ] if ;
-
-: key-down-event>gesture ( event world -- string gesture )
- dupd
- handle>> xic>> lookup-string
- [ swap event-modifiers ] dip key-code <key-down> ;
-
-M: world key-down-event
- [ key-down-event>gesture ] keep
- [ propagate-key-gesture drop ]
- [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
- 3bi ;
-
-: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
-
-M: world key-up-event
- [ key-up-event>gesture ] dip propagate-key-gesture ;
-
-: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
-
-M: world button-down-event
- [ mouse-event>gesture [ <button-down> ] dip ] dip
- send-button-down ;
-
-M: world button-up-event
- [ mouse-event>gesture [ <button-up> ] dip ] dip
- send-button-up ;
-
-: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
- { 4 { 0 -1 } }
- { 5 { 0 1 } }
- { 6 { -1 0 } }
- { 7 { 1 0 } }
- } at ;
-
-M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
- send-wheel ;
-
-M: world enter-event motion-event ;
-
-M: world leave-event 2drop forget-rollover ;
-
-M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
-
-M: world focus-in-event
- nip
- dup handle>> xic>> XSetICFocus focus-world ;
-
-M: world focus-out-event
- nip
- dup handle>> xic>> XUnsetICFocus unfocus-world ;
-
-M: world selection-notify-event
- [ handle>> window>> selection-from-event ] keep
- user-input ;
-
-: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with any? ;
-
-: clipboard-for-atom ( atom -- clipboard )
- {
- { XA_PRIMARY [ selection get ] }
- { XA_CLIPBOARD [ clipboard get ] }
- [ drop <clipboard> ]
- } case ;
-
-: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
-
-: set-selection-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
-
-M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
- { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- [ drop send-notify-failure ]
- } cond ;
-
-M: x11-ui-backend (close-window) ( handle -- )
- dup xic>> XDestroyIC
- dup glx>> destroy-glx
- window>> dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic rot <x11-handle>
- 2dup window>> register-window
- >>handle drop ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ drop wait-event ] unless
- ] [
- ui-wait wait-event
- ] if ;
-
-M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
- [ handle-event ] [ 2drop ] if ;
-
-: x-clipboard@ ( gadget clipboard -- prop win )
- atom>> swap
- find-world handle>> window>> ;
-
-M: x-clipboard copy-clipboard
- [ x-clipboard@ own-selection ] keep
- (>>contents) ;
-
-M: x-clipboard paste-clipboard
- [ find-world handle>> window>> ] dip atom>> convert-selection ;
-
-: init-clipboard ( -- )
- XA_PRIMARY <x-clipboard> selection set-global
- XA_CLIPBOARD <x-clipboard> clipboard set-global ;
-
-: set-title-old ( dpy window string -- )
- dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
-
-: set-title-new ( dpy window string -- )
- [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
- utf8 encode dup length XChangeProperty drop ;
-
-M: x11-ui-backend set-title ( string world -- )
- handle>> window>> swap
- [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- handle>> window>> "XClientMessageEvent" <c-object>
- tuck set-XClientMessageEvent-window
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
-
-M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- handle>> window>> dup set-closable map-window ;
-
-M: x11-ui-backend raise-window* ( world -- )
- handle>> [
- dpy get swap window>> XRaiseWindow drop
- ] when* ;
-
-M: x11-handle select-gl-context ( handle -- )
- dpy get swap
- [ window>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-handle flush-gl-context ( handle -- )
- dpy get swap window>> glXSwapBuffers ;
-
-M: x11-pixmap-handle select-gl-context ( handle -- )
- dpy get swap
- [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-pixmap-handle flush-gl-context ( handle -- )
- drop ;
-
-M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
-M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
- dpy get swap
- [ glx-pixmap>> glXDestroyGLXPixmap ]
- [ pixmap>> XFreePixmap drop ]
- [ glx>> glXDestroyContext ] 2tri ;
-
-M: x11-ui-backend offscreen-pixels ( world -- alien w h )
- [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
-
-M: x11-ui-backend ui ( -- )
- [
- f [
- [
- init-clipboard
- start-ui
- event-loop
- ] with-xim
- ] with-x
- ] ui-running ;
-
-M: x11-ui-backend beep ( -- )
- dpy get 100 XBell drop ;
-
-x11-ui-backend ui-backend set-global
-
-[ "DISPLAY" os-env "ui" "listener" ? ]
-main-vocab-hook set-global
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
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>
-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 ;
M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
[ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
+
+DEFER: change-slot-test
+SLOT: kex
+
+[ ] [
+ "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
+ <string-reader> "change-slot-test" parse-stream
+ drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
+ <string-reader> "change-slot-test" parse-stream
+ drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
+ <string-reader> "change-slot-test" parse-stream
+ drop
+] unit-test
+
+[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
+[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
\ No newline at end of file
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
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
+: fake-definition ( definition -- )
+ old-definitions get [ delete-at ] with each ;
+
: remember-class ( class loc -- )
[ dup new-definitions get first key? [ dup redefine-error ] when ] dip
new-definitions get second (remember-definition) ;
SYMBOL: update-tuples-hook
SYMBOL: remake-generics-hook
+: index>= ( obj1 obj2 seq -- ? )
+ [ index ] curry bi@ >= ;
+
: dependency>= ( how1 how2 -- ? )
- [
- {
- called-dependency
- flushed-dependency
- inlined-dependency
- } index
- ] bi@ >= ;
+ { called-dependency flushed-dependency inlined-dependency }
+ index>= ;
: strongest-dependency ( how1 how2 -- how )
[ called-dependency or ] bi@ [ dependency>= ] most ;
{ $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: flushed-dependency
SYMBOL: called-dependency
-<PRIVATE
-
: set-in-unit ( value key assoc -- )
[ set-at ] [ no-compilation-unit ] if* ;
-PRIVATE>
-
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
SYMBOL: changed-generics
-: changed-generic ( class generic -- )
- changed-generics get set-in-unit ;
-
SYMBOL: remake-generics
-: remake-generic ( generic -- )
- dup remake-generics get set-in-unit ;
-
SYMBOL: new-classes
: new-class ( word -- )
SYMBOL: forgotten-definitions
: forgotten-definition ( defspec -- )
- dup forgotten-definitions get
- [ no-compilation-unit ] unless*
- set-at ;
+ dup forgotten-definitions get set-in-unit ;
-: forget ( defspec -- ) dup forgotten-definition forget* ;
+: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ;
: forget-all ( definitions -- ) [ forget ] each ;
{ $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:"
\ check-method boa throw
] unless ; inline
+: changed-generic ( class generic -- )
+ changed-generics get
+ [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
+
+: remake-generic ( generic -- )
+ dup remake-generics get set-in-unit ;
+
: with-methods ( class generic quot -- )
[ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
2bi ;
: create-method ( class generic -- method )
- 2dup method dup [ 2nip ] [
+ 2dup method dup [ 2nip dup reset-generic ] [
drop
[ <method> dup ] 2keep
reveal-method
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' )
"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 }" }
} ;
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with
+
+! Two similar bugs
+
+! Replace : def with something in << >>
+[ [ ] ] [
+ "IN: parser.tests : was-once-a-word-bug ( -- ) ;"
+ <string-reader> "was-once-a-word-test" parse-stream
+] unit-test
+
+[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] (( -- )) define-declared >>"
+ <string-reader> "was-once-a-word-test" parse-stream
+] unit-test
+
+[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
+
+! Replace : def with DEFER:
+[ [ ] ] [
+ "IN: parser.tests : is-not-deferred ( -- ) ;"
+ <string-reader> "is-not-deferred" parse-stream
+] unit-test
+
+[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
+[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests DEFER: is-not-deferred"
+ <string-reader> "is-not-deferred" parse-stream
+] unit-test
+
+[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
+[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
combinators sorting splitting math.parser effects continuations
io.files vocabs io.encodings.utf8 source-files
classes hashtables compiler.errors compiler.units accessors sets
-lexer vocabs.parser ;
+lexer vocabs.parser slots ;
IN: parser
: location ( -- loc )
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
+SYMBOL: quotation-parser
+
+HOOK: parse-quotation quotation-parser ( -- quot )
+
+M: f parse-quotation \ ] parse-until >quotation ;
+
: parsed ( accum obj -- accum ) over push ;
: (parse-lines) ( lexer -- quot )
- [
- f parse-until >quotation
- ] with-lexer ;
+ [ f parse-until >quotation ] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
"memory"
"namespaces"
"prettyprint"
+ "see"
"sequences"
"slicing"
"sorting"
"quiet" get [ drop ] [ "Loading " write print flush ] if ;
: filter-moved ( assoc1 assoc2 -- seq )
- swap assoc-diff [
- drop where dup [ first ] when
- file get path>> =
- ] assoc-filter keys ;
+ swap assoc-diff keys [
+ {
+ { [ dup where dup [ first ] when file get path>> = not ] [ f ] }
+ { [ dup reader-method? ] [ f ] }
+ { [ dup writer-method? ] [ f ] }
+ [ t ]
+ } cond nip
+ ] filter ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
[ 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
PREDICATE: reader < word "reader" word-prop ;
+PREDICATE: reader-method < method-body "reading" word-prop ;
+
PREDICATE: writer < word "writer" word-prop ;
+PREDICATE: writer-method < method-body "writing" word-prop ;
+
: <slot-spec> ( -- slot-spec )
slot-spec new
object bootstrap-word >>class ;
lexer get skip-blank parse-string <pathname> parsed
] define-syntax
- "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
+ "[" [ parse-quotation parsed ] define-syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"DEFER:" [
scan current-vocab create
- dup old-definitions get [ delete-at ] with each
- set-word
+ [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
] define-syntax
":" [
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
-{ $see-also "vocabularies" "vocabs.loader" "definitions" } ;
+{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ;
ABOUT: "words"
USING: kernel \r
namespaces\r
accessors\r
+assocs\r
make\r
math\r
math.functions\r
combinators\r
continuations\r
colors\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.theme\r
ui.gadgets.frames\r
ui.gadgets.tracks\r
ui.gadgets.labels\r
- ui.gadgets.labelled \r
+ ui.gadgets.labeled \r
ui.gadgets.lists\r
ui.gadgets.buttons\r
ui.gadgets.packs\r
ui.gadgets.grids\r
ui.gestures\r
- ui.tools.workspace\r
ui.gadgets.scrollers\r
splitting\r
vectors\r
math.vectors\r
-rewrite-closures\r
-self\r
values\r
4DNav.turtle\r
4DNav.window3D\r
adsoda\r
adsoda.tools\r
;\r
+QUALIFIED-WITH: ui.pens.solid s\r
+QUALIFIED-WITH: ui.gadgets.wrappers w\r
+\r
\r
IN: 4DNav\r
VALUE: selected-file\r
\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
-! replacement of namespaces.lib\r
+! namespace utilities\r
\r
: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
\r
+: closed-quot ( quot -- quot )\r
+ namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
+\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! waiting for deep-cleave-quots\r
\r
: model-projection-chooser ( -- gadget )\r
observer3d> projection-mode>>\r
{ { 1 "perspective" } { 0 "orthogonal" } } \r
- <toggle-buttons> ;\r
+ <radio-buttons> ;\r
\r
: collision-detection-chooser ( -- gadget )\r
observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <toggle-buttons> ;\r
+ { { t "on" } { f "off" } } <radio-buttons> ;\r
\r
: model-projection ( x -- space ) \r
present-space> swap space-project ;\r
! menu\r
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
+USE: ui.gadgets.labeled.private\r
+\r
: menu-rotations-4D ( -- gadget )\r
- <frame>\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
<pile> 1 >>fill\r
"XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
button* add-gadget\r
;\r
\r
: menu-translations-4D ( -- gadget )\r
- <frame> \r
+ 3 3 <frame> \r
+ { 1 1 } >>filled-cell\r
<pile> 1 >>fill\r
<shelf> 1 >>fill \r
"X+" [ drop { 1 0 0 0 } translation-step v*n \r
[ ".xml" tail? ] filter \r
[ append-path ] with map\r
[ <run-file-button> add-gadget ] each\r
- swap <labelled-gadget> ;\r
+ swap <labeled-gadget> ;\r
\r
! -----------------------------------------------------\r
\r
: menu-rotations-3D ( -- gadget )\r
- <frame>\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
"Turn\n left" [ rotation-step turn-left ] \r
camera-button @left grid-add \r
"Turn\n right" [ rotation-step turn-right ] \r
;\r
\r
: menu-translations-3D ( -- gadget )\r
- <frame>\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
"left\n(alt)" [ translation-step strafe-left ]\r
camera-button @left grid-add \r
"right\n(alt)" [ translation-step strafe-right ]\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
{ 0 1 } <track>\r
menu-bar f track-add\r
<list-runner> \r
- <limited-scroller> \r
- { 200 400 } >>max-dim\r
+ <scroller>\r
f track-add\r
<shelf>\r
"Projection mode : " <label> add-gadget\r
<pile>\r
0.5 >>align \r
menu-4D add-gadget \r
- light-purple solid-interior\r
- "4D movements" <labelled-gadget>\r
+ COLOR: purple s:<solid> >>interior\r
+ "4D movements" <labeled-gadget>\r
f track-add\r
<pile>\r
0.5 >>align\r
{ 2 2 } >>gap\r
menu-3D add-gadget\r
- light-purple solid-interior \r
- "Camera 3D" <labelled-gadget>\r
+ COLOR: purple s:<solid> >>interior\r
+ "Camera 3D" <labeled-gadget>\r
f track-add \r
- gray solid-interior\r
+ COLOR: gray s:<solid> >>interior\r
;\r
\r
: viewer-windows* ( -- )\r
-USING: kernel namespaces math.vectors opengl 4DNav.turtle
-self ;
+USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
IN: 4DNav.camera
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
f track-add\r
<shelf> \r
over [ swap fc-go-parent ] curry "go up" \r
- swap <bevel-button> add-gadget\r
+ swap <border-button> add-gadget\r
over [ swap fc-go-home ] curry "go home" \r
- swap <bevel-button> add-gadget\r
+ swap <border-button> add-gadget\r
! over [ swap fc-ok-action ] curry "OK" \r
! swap <bevel-button> add-gadget\r
! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
namespaces make
math.constants math.functions
math.vectors
-splitting grouping self math.trig
- sequences accessors 4DNav.deep models ;
+splitting grouping math.trig
+ sequences accessors 4DNav.deep models vars ;
IN: 4DNav.turtle
+! replacement of self
+
+VAR: self
+
+: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
+
+: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: turtle pos ori ;
TUPLE: window3D < gadget observer ; \r
\r
: <window3D> ( model observer -- gadget )\r
- window3D new-gadget \r
+ window3D new\r
swap 2dup \r
projection-mode>> add-connection\r
2dup \r
+++ /dev/null
-
-USING: accessors arrays assocs calendar colors
-combinators.short-circuit help.markup help.syntax kernel locals
-math math.functions math.matrices math.order math.parser
-math.trig math.vectors opengl opengl.demo-support opengl.gl
-sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
-ui.gestures ui.render ui.tools.workspace ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: L-system
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
-
-DEFER: default-L-parser-values
-
-: reset-turtle ( turtle -- turtle )
- { 0 0 0 } clone >>pos
- 3 identity-matrix >>ori
- V{ } clone >>vertices
- V{ } clone >>saved
-
- default-L-parser-values ;
-
-: turtle ( -- turtle ) <turtle> new reset-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: step-turtle ( TURTLE LENGTH -- turtle )
-
- TURTLE
- TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
- >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: Rx ( ANGLE -- Rx )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin neg ]
- C [ ANGLE sin ]
- D [ ANGLE cos ] |
-
- { { 1 0 0 }
- { 0 A B }
- { 0 C D } }
-
- ] ] ;
-
-:: Ry ( ANGLE -- Ry )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin ]
- C [ ANGLE sin neg ]
- D [ ANGLE cos ] |
-
- { { A 0 B }
- { 0 1 0 }
- { C 0 D } }
-
- ] ] ;
-
-:: Rz ( ANGLE -- Rz )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin neg ]
- C [ ANGLE sin ]
- D [ ANGLE cos ] |
-
- { { A B 0 }
- { C D 0 }
- { 0 0 1 } }
-
- ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: apply-rotation ( TURTLE ROTATION -- turtle )
-
- TURTLE TURTLE ori>> ROTATION m. >>ori ;
-
-: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
-: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
-: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
-: pitch-down ( turtle angle -- turtle ) rotate-x ;
-
-: turn-left ( turtle angle -- turtle ) rotate-y ;
-: turn-right ( turtle angle -- turtle ) neg rotate-y ;
-
-: roll-left ( turtle angle -- turtle ) neg rotate-z ;
-: roll-right ( turtle angle -- turtle ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( turtle -- 3array ) ori>> [ first ] map ;
-: Y ( turtle -- 3array ) ori>> [ second ] map ;
-: Z ( turtle -- 3array ) ori>> [ third ] map ;
-
-: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
-: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
-: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
-
-:: roll-until-horizontal ( TURTLE -- turtle )
-
- TURTLE
-
- V TURTLE Z cross normalize set-X
-
- TURTLE Z TURTLE X cross normalize set-Y ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: strafe-up ( TURTLE LENGTH -- turtle )
- TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
-
-:: strafe-down ( TURTLE LENGTH -- turtle )
- TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
-
-:: strafe-left ( TURTLE LENGTH -- turtle )
- TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
-
-:: strafe-right ( TURTLE LENGTH -- turtle )
- TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
-
-: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
-
-: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
-
-: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
-
-: draw-forward ( turtle length -- turtle )
- GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
-
-: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
-
-: sneak-forward ( turtle length -- turtle ) step-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scale-length ( turtle m -- turtle ) over length>> * >>length ;
-: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
-
-: scale-thickness ( turtle m -- turtle )
- over thickness>> * 0.5 max set-thickness ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-table ( -- colors )
- {
- T{ rgba f 0 0 0 1 } ! black
- T{ rgba f 0.5 0.5 0.5 1 } ! grey
- T{ rgba f 1 0 0 1 } ! red
- T{ rgba f 1 1 0 1 } ! yellow
- T{ rgba f 0 1 0 1 } ! green
- T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
- T{ rgba f 0 0 1 1 } ! blue
- T{ rgba f 0.63 0.13 0.94 1 } ! purple
- T{ rgba f 0.00 0.50 0.00 1 } ! dark green
- T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
- T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
- T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
- T{ rgba f 0.50 0.00 0.00 1 } ! dark red
- T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
- T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
- T{ rgba f 1 1 1 1 } ! white
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : material-color ( color -- )
-! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
-
-: material-color ( color -- )
- GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
-
-: set-color ( turtle i -- turtle )
- dup color-table nth dup gl-color material-color >>color ;
-
-: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
-
-: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-L-parser-values ( turtle -- turtle )
- 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
-
-: L-parser-dialect ( -- commands )
-
- {
- { "+" [ dup angle>> turn-left ] }
- { "-" [ dup angle>> turn-right ] }
- { "&" [ dup angle>> pitch-down ] }
- { "^" [ dup angle>> pitch-up ] }
- { "<" [ dup angle>> roll-left ] }
- { ">" [ dup angle>> roll-right ] }
-
- { "|" [ 180.0 rotate-y ] }
- { "%" [ 180.0 rotate-z ] }
- { "$" [ roll-until-horizontal ] }
-
- { "F" [ dup length>> draw-forward ] }
- { "Z" [ dup length>> 2 / draw-forward ] }
- { "f" [ dup length>> move-forward ] }
- { "z" [ dup length>> 2 / move-forward ] }
- { "g" [ dup length>> sneak-forward ] }
- { "." [ polygon-vertex ] }
-
- { "[" [ save-turtle ] }
- { "]" [ restore-turtle ] }
-
- { "{" [ start-polygon ] }
- { "}" [ finish-polygon ] }
-
- { "/" [ 1.1 scale-length ] } ! double quote command in lparser
- { "'" [ 0.9 scale-length ] }
- { ";" [ 1.1 scale-angle ] }
- { ":" [ 0.9 scale-angle ] }
- { "?" [ 1.4 scale-thickness ] }
- { "!" [ 0.7 scale-thickness ] }
-
- { "c" [ dup color>> 1 + color-table length mod set-color ] }
-
- }
- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <L-system> < gadget
- camera display-list pedestal paused
- turtle-values
- commands axiom rules string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-rotation-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: open-paren ( -- ch ) CHAR: ( ;
-: close-paren ( -- ch ) CHAR: ) ;
-
-: open-paren? ( obj -- ? ) open-paren = ;
-: close-paren? ( obj -- ? ) close-paren = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: read-instruction ( STRING -- next rest )
-
- { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
- [ STRING close-paren STRING index 1 + cut ]
- [ STRING 1 cut ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-string-loop ( STRING RULES ACCUM -- )
- STRING empty? not
- [
- STRING read-instruction
-
- [let | REST [ ] NEXT [ ] |
-
- NEXT 1 head RULES at NEXT or ACCUM push-all
-
- REST RULES ACCUM iterate-string-loop ]
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-string ( STRING RULES -- string )
-
- [let | ACCUM [ STRING length 10 * <sbuf> ] |
-
- STRING RULES ACCUM iterate-string-loop
-
- ACCUM >string ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: interpret-string ( STRING COMMANDS -- )
-
- STRING empty? not
- [
- STRING read-instruction
-
- [let | REST [ ] NEXT [ ] |
-
- [let | COMMAND [ NEXT 1 head COMMANDS at ] |
-
- COMMAND
- [
- NEXT length 1 =
- [ COMMAND call ]
- [
- NEXT 2 tail 1 head* string>number
- COMMAND 1 tail*
- call
- ]
- if
- ]
- when ]
-
- REST COMMANDS interpret-string ]
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-L-system-string ( L-SYSTEM -- )
- L-SYSTEM string>> L-SYSTEM axiom>> or
- L-SYSTEM rules>>
- iterate-string
- L-SYSTEM (>>string) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: do-camera-look-at ( CAMERA -- )
-
- [let | EYE [ CAMERA pos>> ]
- FOCUS [ CAMERA clone 1 step-turtle pos>> ]
- UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
- |
-
- EYE FOCUS UP gl-look-at ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: generate-display-list ( L-SYSTEM -- )
-
- L-SYSTEM find-gl-context
-
- L-SYSTEM display-list>> GL_COMPILE glNewList
-
- turtle
- L-SYSTEM turtle-values>> [ ] or call
- L-SYSTEM string>> L-SYSTEM axiom>> or
- L-SYSTEM commands>>
- interpret-string
- drop
-
- glEndList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> draw-gadget* ( L-SYSTEM -- )
-
- black gl-clear
-
- GL_FLAT glShadeModel
-
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- -1 1 -1 1 1.5 200 glFrustum
-
- GL_MODELVIEW glMatrixMode
-
- glLoadIdentity
-
- L-SYSTEM camera>> do-camera-look-at
-
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
-
- ! draw axis
- white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
-
- ! rotate pedestal
-
- L-SYSTEM pedestal>> 0 0 1 glRotated
-
- L-SYSTEM display-list>> glCallList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> graft* ( L-SYSTEM -- )
-
- L-SYSTEM find-gl-context
-
- 1 glGenLists L-SYSTEM (>>display-list) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: with-camera ( L-SYSTEM QUOT -- )
- L-SYSTEM camera>> QUOT call drop
- L-SYSTEM relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<L-system>
-H{
- { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
- { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
- { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
- { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
-
- { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
- { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
-
- { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
- { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
-
- { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
- { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
- { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
- { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
-
- { T{ key-down f f "r" } [ start-rotation-thread ] }
-
- {
- T{ key-down f f "x" }
- [
- dup iterate-L-system-string
- dup generate-display-list
- dup relayout-1
- drop
- ]
- }
-
- { T{ key-down f f "F1" } [ drop "L-system" help-window ] }
-
-}
-set-gestures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: L-system ( -- L-system )
-
- <L-system> new-gadget
-
- 0 >>pedestal
-
- ! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
-
- turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
-
- dup start-rotation-thread
-
- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "L-system" "L-system"
-
-"Press 'x' to iterate the L-system." $nl
-
-"Camera control:"
-
-{ $table
-
- { "a" "Forward" }
- { "z" "Backward" }
-
- { "LEFT" "Turn left" }
- { "RIGHT" "Turn right" }
- { "UP" "Pitch down" }
- { "DOWN" "Pitch up" }
-
- { "q" "Roll left" }
- { "w" "Roll right" } } ;
-
-ABOUT: "L-system"
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-1
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-1 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- "c(12)FFAL" >>axiom
-
- {
- { "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
- { "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
- { "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
-
- { "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-2
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-2 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 30 >>angle ] >>turtle-values
-
- "c(12)FAL" >>axiom
-
- {
- { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
-
- { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
- { "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
-
- { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
-
- } >>rules ;
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-3
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-3 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 30 >>angle ] >>turtle-values
-
- "c(12)FA" >>axiom
-
- {
- { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
- { "B" "[&t(.4)F$A]" }
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-4
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-4 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 18 >>angle ] >>turtle-values
-
- "c(12)&(20)N" >>axiom
-
- {
- {
- "N"
- "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
- }
- { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
- { "l" "g(.2)l" }
- { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
- { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
- { "f" "_" }
-
- { "A" "B" }
- { "B" "C" }
- { "C" "D" }
- { "D" "E" }
- { "E" "G" }
- { "G" "H" }
- { "H" "N" }
-
- { "I" "FoO" }
- { "O" "FoP" }
- { "P" "FoQ" }
- { "Q" "FoR" }
- { "R" "FoS" }
- { "S" "FoT" }
- { "T" "FoU" }
- { "U" "FoV" }
- { "V" "FoW" }
- { "W" "FoX" }
- { "X" "_" }
-
- { "o" "$t(-0.03)" }
- { "r" "~(30)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-5-angular
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5-angular ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- "&(90)+(90)a" >>axiom
-
- {
- { "a" "F[+(45)l][-(45)l]^;ca" }
-
- { "l" "j" }
- { "j" "h" }
- { "h" "s" }
- { "s" "d" }
- { "d" "x" }
- { "x" "a" }
-
- { "F" "'(1.17)F'(.855)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-5
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- "a" >>axiom
-
- {
- { "a" "F[+(45)l][-(45)l]^;ca" }
-
- { "l" "j" }
- { "j" "h" }
- { "h" "s" }
- { "s" "d" }
- { "d" "x" }
- { "x" "a" }
-
- { "F" "'(1.17)F'(.855)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-6
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-6 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- ! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
- "FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
- >>axiom
-
- {
- { "a" "F[cdx][cex]F!(.9)a" }
- { "x" "a" }
-
- { "d" "+d" }
- { "e" "-e" }
-
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.airhorse
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: airhorse ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 10 >>angle ] >>turtle-values
-
- "C" >>axiom
-
- {
- { "C" "LBW" }
-
- { "B" "[[''aH]|[g]]" }
- { "a" "Fs+;'a" }
- { "g" "Ft+;'g" }
- { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
- { "t" "[c!!!!&[FF]^^FF]" }
-
- { "L" "O" }
- { "O" "P" }
- { "P" "Q" }
- { "Q" "R" }
- { "R" "U" }
- { "U" "X" }
- { "X" "Y" }
- { "Y" "V" }
- { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
- { "p" "h>(120)h>(120)h" }
- { "h" "[+(40)!F'''p]" }
-
- { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
- { "d" "Z!&Z!&:'d" }
- { "e" "Z!^Z!^:'e" }
- { "i" "-:/i" }
-
- { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
- { "b" "Fl!+Fl+;'b" }
- { "l" "[-cc{--z++z++z--|--z++z++z}]" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.tree-5
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tree-5 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- "c(4)FFS" >>axiom
-
- {
- { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
- { "R" "[Ba]" }
- { "a" "$tF[Cx]Fb" }
- { "b" "$tF[Dy]Fa" }
- { "B" "&B" }
- { "C" "+C" }
- { "D" "-D" }
-
- { "x" "a" }
- { "y" "b" }
-
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
! (c)2009 Joe Groff, Doug Coleman. see BSD license
USING: accessors combinators.short-circuit definitions functors
-kernel lexer namespaces parser prettyprint sequences words ;
+kernel lexer namespaces parser prettyprint tools.crossref
+sequences words ;
IN: annotations
<<
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.parser random arrays hashtables assocs sequences
- grouping vars ;
-
-IN: automata
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! set-rule
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: rule VAR: rule-number
-
-: init-rule ( -- ) 8 <hashtable> >rule ;
-
-: rule-keys ( -- array )
- { { 1 1 1 }
- { 1 1 0 }
- { 1 0 1 }
- { 1 0 0 }
- { 0 1 1 }
- { 0 1 0 }
- { 0 0 1 }
- { 0 0 0 } } ;
-
-: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
-
-: set-rule ( n -- )
- dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! step-capped-line
-! step-wrapped-line
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pattern>state ( {_a_b_c_} -- state ) rule> at ;
-
-: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
-
-: wrap-line ( a-line-z -- za-line-za )
- dup peek 1array swap dup first 1array append append ;
-
-: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
-
-: step-capped-line ( line -- new-line ) cap-line step-line ;
-: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: width height ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-line ( -- line ) width> [ drop 2 random ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: center-i ( -- i ) width> 2 / >fixnum ;
-
-: center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: interesting ( -- seq )
- { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
- 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
-
-: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
-
-: set-interesting ( -- ) interesting random set-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: bitmap
-
-VAR: last-line
-
-: run-rule ( -- )
- last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-random ( -- ) random-line >last-line run-rule ;
-
-: start-center ( -- ) center-line >last-line run-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: loop-flag
-
-! DEFER: loop
-
-! : (loop) ( -- ) run-rule 3000 sleep loop ;
-
-! : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
-
-! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
-
-! : stop-loop ( -- ) f >loop-flag ;
+++ /dev/null
-Cellular Automata Explorer (one dimensional, two state)
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Cellular Automata" }
-}
+++ /dev/null
-
-USING: kernel namespaces math quotations arrays hashtables sequences threads
- opengl
- opengl.gl
- colors
- ui
- ui.gestures
- ui.gadgets
- ui.gadgets.slate
- ui.gadgets.labels
- ui.gadgets.buttons
- ui.gadgets.frames
- ui.gadgets.packs
- ui.gadgets.grids
- ui.gadgets.theme
- ui.gadgets.handler
- accessors
- vars fry
- rewrite-closures automata math.geometry.rect newfx ;
-
-IN: automata.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
-
-: draw-line ( y line -- ) 0 swap [ [ 2dup ] dip draw-point 1+ ] each 2drop ;
-
-: (draw-bitmap) ( bitmap -- ) 0 swap [ [ dup ] dip draw-line 1+ ] each drop ;
-
-: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-
-: display ( -- ) black gl-color bitmap> draw-bitmap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-! Call a 'model' quotation with the current 'view'.
-
-: with-view ( quot -- )
- slate> rect-dim first >width
- slate> rect-dim second >height
- call
- slate> relayout-1 ;
-
-! Create a quotation that is appropriate for buttons and gesture handler.
-
-: view-action ( quot -- quot ) '[ drop _ with-view ] closed-quot ;
-
-: view-button ( label quot -- button ) [ <label> ] dip view-action <bevel-button> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Helper word to make things less verbose
-
-: random-rule ( -- ) set-interesting start-center ;
-
-DEFER: automata-window
-
-: automata-window* ( -- )
- init-rule
- set-interesting
-
- <frame>
-
- <shelf>
-
- "1 - Center" [ start-center ] view-button add-gadget
- "2 - Random" [ start-random ] view-button add-gadget
- "3 - Continue" [ run-rule ] view-button add-gadget
- "5 - Random Rule" [ random-rule ] view-button add-gadget
- "n - New" [ automata-window ] view-button add-gadget
-
- @top grid-add
-
- C[ display ] <slate>
- { 400 400 } >>pdim
- dup >slate
-
- @center grid-add
-
- <handler>
-
- H{ }
- T{ key-down f f "1" } [ start-center ] view-action is
- T{ key-down f f "2" } [ start-random ] view-action is
- T{ key-down f f "3" } [ run-rule ] view-action is
- T{ key-down f f "5" } [ random-rule ] view-action is
- T{ key-down f f "n" } [ automata-window ] view-action is
-
- >>table
-
- "Automata" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
-
-MAIN: automata-window
! 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
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel
- namespaces
- arrays
- accessors
- strings
- sequences
- locals
- threads
- math
- math.functions
- math.trig
- math.order
- math.ranges
- math.vectors
- random
- calendar
- opengl.gl
- opengl
- ui
- ui.gadgets
- ui.gadgets.tracks
- ui.gadgets.frames
- ui.gadgets.grids
- ui.render
- multi-methods
- multi-method-syntax
- combinators.short-circuit
- processing.shapes
- flatland ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: boids
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constrain ( n a b -- n ) rot min max ;
-
-: angle-between ( vec vec -- angle )
- [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
-
-: relative-angle ( self other -- angle )
- over vel>> -rot relative-position angle-between ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
-: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
-
-: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
-
-: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
-: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <boid> < <vel> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <behaviour>
- { weight initial: 1.0 }
- { view-angle initial: 180 }
- { radius } ;
-
-TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
-TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
-TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
-
- SELF OTHER
- {
- [ BEHAVIOUR radius>> in-radius? ]
- [ BEHAVIOUR view-angle>> in-view? ]
- [ eq? not ]
- }
- 2&& ;
-
-:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
- OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: force* ( sequence <boid> <behaviour> -- force )
-
-:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
-
-:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
-
-:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
- SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
-
-METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
-METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
-METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
-
-:: force ( OTHERS SELF BEHAVIOUR -- force )
- SELF OTHERS BEHAVIOUR neighborhood
- [ { 0 0 } ]
- [ SELF BEHAVIOUR force* ]
- if-empty ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-boids ( count -- boids )
- [
- drop
- <boid> new
- 2 [ drop 1000 random ] map >>pos
- 2 [ drop -10 10 [a,b] random ] map >>vel
- ]
- map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-boid ( boid -- )
- glPushMatrix
- dup pos>> gl-translate-2d
- vel>> first2 rect> arg rad>deg 0 0 1 glRotated
- { { 0 5 } { 0 -5 } { 20 0 } } triangle
- fill-mode
- glPopMatrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
-
-TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
-
-M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
-M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( BOIDS-GADGET -- )
-
- [let | SKY [ BOIDS-GADGET gadget->sky ]
- BOIDS [ BOIDS-GADGET boids>> ]
- TIME-SLICE [ BOIDS-GADGET time-slice>> ]
- BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
-
- BOIDS
-
- [| SELF |
-
- [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
-
- ! F = m a. M is 1. So F = a.
-
- [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
-
- [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
- VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
-
- [let | POS [ POS SKY wrap ]
- VEL [ VEL normalize* ] |
-
- T{ <boid> f POS VEL } ] ] ] ]
-
- ]
-
- map
-
- BOIDS-GADGET (>>boids) ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
- origin get
- [ BOIDS-GADGET boids>> [ draw-boid ] each ]
- with-translation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-boids-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-behaviours ( -- seq )
- { <cohesion> <alignment> <separation> } [ new ] map ;
-
-: boids-gadget ( -- gadget )
- <boids-gadget> new-gadget
- 100 random-boids >>boids
- default-behaviours >>behaviours
- 10 >>time-slice
- t >>clipped? ;
-
-: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: math.parser
- ui.gadgets.labels
- ui.gadgets.buttons
- ui.gadgets.packs ;
-
-: truncate-number ( n -- n ) 10 * round 10 / ;
-
-:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
- [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
- VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
-
- [wlet | update-value-label [ ! ( -- )
- BEHAVIOUR weight>> truncate-number number>string
- VALUE-LABEL
- (>>string) ] |
-
- update-value-label
-
- <pile> 1 >>fill
- { 1 0 } <track>
- NAME-LABEL 0.5 track-add
- VALUE-LABEL 0.5 track-add
- add-gadget
-
- "+0.1"
- [
- drop
- BEHAVIOUR [ 0.1 + ] change-weight drop
- update-value-label
- ]
- <bevel-button> add-gadget
-
- "-0.1"
- [
- drop
- BEHAVIOUR weight>> 0.1 >
- [
- BEHAVIOUR [ 0.1 - ] change-weight drop
- update-value-label
- ]
- when
- ]
- <bevel-button> add-gadget ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: make-population-control ( BOIDS-GADGET -- gadget )
- [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
-
- [wlet | update-value-label [ ( -- )
- BOIDS-GADGET boids>> length number>string
- VALUE-LABEL
- (>>string) ] |
-
- update-value-label
-
- <pile> 1 >>fill
-
- { 1 0 } <track>
- "Population: " <label> reverse-video-theme 0.5 track-add
- VALUE-LABEL 0.5 track-add
- add-gadget
-
- "Add 10"
- [
- drop
- BOIDS-GADGET
- BOIDS-GADGET boids>> 10 random-boids append
- >>boids
- drop
- update-value-label
- ]
- <bevel-button>
- add-gadget
-
- "Sub 10"
- [
- drop
- BOIDS-GADGET boids>> length 10 >
- [
- BOIDS-GADGET
- BOIDS-GADGET boids>> 10 tail
- >>boids
- drop
- update-value-label
- ]
- when
- ]
- <bevel-button>
- add-gadget ] ] ( gadget -- gadget ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: pause-toggle ( BOIDS-GADGET -- )
- BOIDS-GADGET paused>>
- [ BOIDS-GADGET start-boids-thread ]
- [ BOIDS-GADGET t >>paused drop ]
- if ;
-
-:: randomize-boids ( BOIDS-GADGET -- )
- BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
-
-: boids-app ( -- )
-
- [let | BOIDS-GADGET [ boids-gadget ] |
-
- <frame>
-
- <shelf>
-
- 1 >>fill
-
- "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
-
- "Randomize"
- [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
-
- BOIDS-GADGET make-population-control add-gadget
-
- "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
- "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
- "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
-
- [ add-gadget ] tri@
-
- @top grid-add
-
- BOIDS-GADGET @center grid-add
-
- "Boids" open-window
-
- BOIDS-GADGET start-boids-thread ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boids-main ( -- ) [ boids-app ] with-ui ;
-
-MAIN: boids-main
\ No newline at end of file
+++ /dev/null
-Artificial life program simulating simulating the flocking behaviour of birds
+++ /dev/null
-
-USING: kernel syntax accessors sequences
- arrays calendar
- combinators.cleave combinators.short-circuit
- locals math math.constants math.functions math.libm
- math.order math.points math.vectors
- namespaces random sequences threads ui ui.gadgets ui.gestures
- math.ranges
- colors
- colors.gray
- vars
- multi-methods
- multi-method-syntax
- processing.shapes
- frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! This is a Factor implementation of an art piece by Jared Tarbell:
-!
-! http://complexification.net/gallery/machines/bubblechamber/
-!
-! Jared's version is written in Processing (Java)
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! processing
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle
- bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 rgba boa >>myc
- 0 0 0 1 rgba boa >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
-
-DEFER: collision-theta
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
-
-: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
-: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
-: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: out-of-bounds? ( PARTICLE -- ? )
- [let | X [ PARTICLE pos>> first ]
- Y [ PARTICLE pos>> second ]
- WIDTH [ PARTICLE bubble-chamber>> size>> first ]
- HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
-
- [let | LEFT [ WIDTH neg ]
- RIGHT [ WIDTH 2 * ]
- BOTTOM [ HEIGHT neg ]
- TOP [ HEIGHT 2 * ] |
-
- { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.axion
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <axion> < particle ;
-
-: axion ( -- <axion> ) <axion> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <axion> -- )
-
- dup center >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
-! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
-
-: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y point ;
-: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <axion> -- )
-
- T{ gray f 0.06 0.59 } \ stroke-color set
- dup pos>> point
-
- 1 4 [a,b] [ axion-white axion-point- ] each
- 1 4 [a,b] [ axion-black axion-point+ ] each
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- 1000 random 996 >
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- 100 random 30 > [ collide ] [ drop ] if
- ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.hadron
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <hadron> < particle ;
-
-: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <hadron> -- )
-
- dup center >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- 0 1 0 1 rgba boa >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <hadron> -- )
-
- T{ gray f 1 0.11 } \ stroke-color set dup pos>> 1 v-y point
- T{ gray f 0 0.11 } \ stroke-color set dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- 100 random 70 > [ dup collide ] when
- ]
- when
-
- dup out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.muon.colors
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ good-colors at-fraction-of >>myc ]
- [ drop ]
- if ;
-
-: set-anti-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ anti-colors at-fraction-of >>mya ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.muon
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <muon> < particle ;
-
-: muon ( -- <muon> ) <muon> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <muon> -- )
-
- dup center >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- dup collision-theta -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
-
- set-good-color
- set-anti-color
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <muon> -- )
-
- [let | MUON [ ] |
-
- [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
-
- MUON
-
- dup myc>> 0.16 >>alpha \ stroke-color set
- dup pos>> point
-
- dup mya>> 0.16 >>alpha \ stroke-color set
- dup pos>> first2 [ WIDTH swap - ] dip 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- step-theta
- step-theta-d
- step-speed-sub
-
- dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.quark
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <quark> < particle ;
-
-: quark ( -- <quark> ) <quark> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <quark> -- )
-
- dup center >>pos
- dup collision-theta -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <quark> -- )
-
- [let | QUARK [ ] |
-
- [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
-
- QUARK
-
- dup myc>> 0.13 >>alpha \ stroke-color set
- dup pos>> point
-
- dup pos>> first2 [ WIDTH swap - ] dip 2array point
-
- [ ] [ vel>> ] bi move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
-
-TUPLE: <bubble-chamber> < <frame-buffer>
- paused particles collision-theta size ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
-! 0 2 pi * 0.001 <range> random >>collision-theta ;
-
-: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
- pi neg pi 0.001 <range> random >>collision-theta ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
-
-M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-particle ( particle -- ) move ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
-
- BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-system ( <bubble-chamber> -- ) drop ;
-
-:: start-bubble-chamber-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber ( -- <bubble-chamber> )
- <bubble-chamber> new-gadget
- { 1000 1000 } >>size
- randomize-collision-theta ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber-window ( -- <bubble-chamber> )
- bubble-chamber
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
-
- PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
-
- BUBBLE-CHAMBER BUBBLE-CHAMBER particles>> PARTICLE suffix >>particles ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
- mouse
- BUBBLE-CHAMBER size>> 2 v/n
- v-
- first2
- fatan2
- BUBBLE-CHAMBER (>>collision-theta)
- BUBBLE-CHAMBER ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: mouse-pressed ( BUBBLE-CHAMBER -- )
-
- BUBBLE-CHAMBER mouse->collision-theta drop
-
- 11
- [
- BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
- BUBBLE-CHAMBER particles>> [ <quark>? ] filter random [ collide ] when*
- BUBBLE-CHAMBER particles>> [ <muon>? ] filter random [ collide ] when*
- ]
- times ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-random-particle ( bubble-chamber -- bubble-chamber )
- dup particles>> random collide ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: big-bang ( bubble-chamber -- bubble-chamber )
- dup particles>> [ collide ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-one-of-each ( bubble-chamber -- bubble-chamber )
- dup
- particles>>
- [ [ <muon>? ] filter random collide ]
- [ [ <quark>? ] filter random collide ]
- [ [ <hadron>? ] filter random collide ]
- tri ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Some initial configurations
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ten-hadrons ( -- )
- bubble-chamber-window
- 10 [ drop hadron add-particle ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original ( -- )
-
- bubble-chamber-window
-
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
-
- particles>>
- [ [ <muon>? ] filter random collide ]
- [ [ <quark>? ] filter random collide ]
- [ [ <hadron>? ] filter random collide ]
- tri ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hadron-chamber ( -- )
- bubble-chamber-window
- 1000 [ hadron add-particle ] times
- big-bang
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: quark-chamber ( -- )
- bubble-chamber-window
- 100 [ quark add-particle ] times
- big-bang
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: small ( -- )
- <bubble-chamber> new-gadget
- { 200 200 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 42 [ muon add-particle ] times
- 30 [ quark add-particle ] times
- 21 [ hadron add-particle ] times
- 7 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: medium ( -- )
- <bubble-chamber> new-gadget
- { 400 400 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 100 [ muon add-particle ] times
- 81 [ quark add-particle ] times
- 60 [ hadron add-particle ] times
- 9 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: large ( -- )
- <bubble-chamber> new-gadget
- { 600 600 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 550 [ muon add-particle ] times
- 339 [ quark add-particle ] times
- 100 [ hadron add-particle ] times
- 11 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Experimental
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: muon-chamber ( -- )
- bubble-chamber-window
- 1000 [ muon add-particle ] times
- dup particles>> [ collide randomize-collision-theta ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original-big-bang ( -- )
- bubble-chamber
- { 1000 1000 } >>size
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
-
- big-bang
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original-big-bang-variant ( -- )
- bubble-chamber-window
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
- dup particles>> [ collide randomize-collision-theta ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.hadron-chamber
-
-: main ( -- ) [ hadron-chamber ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.large
-
-: main ( -- ) [ large ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.medium
-
-: main ( -- ) [ medium ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.original
-
-: main ( -- ) [ original ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.quark-chamber
-
-: main ( -- ) [ quark-chamber ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.small
-
-: main ( -- ) [ small ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.ten-hadrons
-
-: main ( -- ) [ ten-hadrons ] with-ui ;
-
-MAIN: main
\ No newline at end of file
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.demo-support fry
+opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry
opengl.capabilities sequences ui.gadgets combinators accessors
macros locals ;
IN: bunny.outlined
+++ /dev/null
-Sampo Vuori
+++ /dev/null
-! Cairo "Hello World" demo
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-!
-! This example is an adaptation of the following cairo sample code:
-! http://cairographics.org/samples/text/
-
-
-USING: cairo.ffi math math.constants byte-arrays kernel ui
-ui.render combinators ui.gadgets opengl.gl accessors
-namespaces opengl ;
-
-IN: cairo-demo
-
-: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
-
-: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
-TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
-
-M: cairo-demo-gadget draw-gadget* ( gadget -- )
- origin get [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
- image-array>> glDrawPixels
- ] with-translation ;
-
-: create-surface ( gadget -- cairo_surface_t )
- make-image-array [ swap (>>image-array) ] keep
- convert-array-to-surface ;
-
-: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
-
-M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
-
-ERROR: no-cairo-t ;
-
-<PRIVATE
-
-: draw-hello-world ( gadget -- )
- cairo-t>> [ no-cairo-t ] unless*
- {
- [
- "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- ]
- [ 90.0 cairo_set_font_size ]
- [ 10.0 135.0 cairo_move_to ]
- [ "Hello" cairo_show_text ]
- [ 70.0 165.0 cairo_move_to ]
- [ "World" cairo_text_path ]
- [ 0.5 0.5 1 cairo_set_source_rgb ]
- [ cairo_fill_preserve ]
- [ 0 0 0 cairo_set_source_rgb ]
- [ 2.56 cairo_set_line_width ]
- [ cairo_stroke ]
- [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
- [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
- [ cairo_close_path ]
- [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
- [ cairo_fill ]
- } cleave ;
-
-PRIVATE>
-
-M: cairo-demo-gadget graft* ( gadget -- )
- dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
-
-M: cairo-demo-gadget ungraft* ( gadget -- )
- cairo-t>> cairo_destroy ;
-
-: <cairo-demo-gadget> ( -- gadget )
- cairo-demo-gadget new-gadget ;
-
-: run ( -- )
- [
- <cairo-demo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
-
-MAIN: run
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis
-! See http://factorcode.org/license.txt for BSD license.
-!
-! these samples are a subset of the samples on
-! http://cairographics.org/samples/
-USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces
-cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
-
-IN: cairo-samples
-
-TUPLE: arc-gadget < cairo-gadget ;
-M:: arc-gadget render-cairo* ( gadget -- )
- [let | xc [ 128.0 ]
- yc [ 128.0 ]
- radius [ 100.0 ]
- angle1 [ pi 1/4 * ]
- angle2 [ pi ] |
- cr 10.0 cairo_set_line_width
- cr xc yc radius angle1 angle2 cairo_arc
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6.0 cairo_set_line_width
-
- cr xc yc 10.0 0 2 pi * cairo_arc
- cr cairo_fill
-
- cr xc yc radius angle1 angle1 cairo_arc
- cr xc yc cairo_line_to
- cr xc yc radius angle2 angle2 cairo_arc
- cr xc yc cairo_line_to
- cr cairo_stroke
- ] ;
-
-TUPLE: clip-gadget < cairo-gadget ;
-M: clip-gadget render-cairo* ( gadget -- )
- drop
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 0 0 256 256 cairo_rectangle
- cr cairo_fill
- cr 0 1 0 cairo_set_source_rgb
- cr 0 0 cairo_move_to
- cr 256 256 cairo_line_to
- cr 256 0 cairo_move_to
- cr 0 256 cairo_line_to
- cr 10 cairo_set_line_width
- cr cairo_stroke ;
-
-TUPLE: clip-image-gadget < cairo-gadget ;
-M:: clip-image-gadget render-cairo* ( gadget -- )
- [let* | png [ "resource:misc/icons/Factor_128x128.png"
- normalize-path cairo_image_surface_create_from_png ]
- w [ png cairo_image_surface_get_width ]
- h [ png cairo_image_surface_get_height ] |
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 192.0 w / 192.0 h / cairo_scale
- cr png 32 32 cairo_set_source_surface
- cr cairo_paint
- png cairo_surface_destroy
- ] ;
-
-TUPLE: dash-gadget < cairo-gadget ;
-M:: dash-gadget render-cairo* ( gadget -- )
- [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
- ndash [ 4 ] |
- cr dashes ndash -50 cairo_set_dash
- cr 10 cairo_set_line_width
- cr 128.0 25.6 cairo_move_to
- cr 230.4 230.4 cairo_line_to
- cr -102.4 0 cairo_rel_line_to
- cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
- cr cairo_stroke
- ] ;
-
-TUPLE: gradient-gadget < cairo-gadget ;
-M:: gradient-gadget render-cairo* ( gadget -- )
- [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
- radial [ 115.2 102.4 25.6 102.4 102.4 128.0
- cairo_pattern_create_radial ] |
- pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- cr 0 0 256 256 cairo_rectangle
- cr pat cairo_set_source
- cr cairo_fill
- pat cairo_pattern_destroy
-
- radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- cr radial cairo_set_source
- cr 128.0 128.0 76.8 0 2 pi * cairo_arc
- cr cairo_fill
- radial cairo_pattern_destroy
- ] ;
-
-TUPLE: text-gadget < cairo-gadget ;
-M: text-gadget render-cairo* ( gadget -- )
- drop
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- cr 50 cairo_set_font_size
- cr 10 135 cairo_move_to
- cr "Hello" cairo_show_text
-
- cr 70 165 cairo_move_to
- cr "factor" cairo_text_path
- cr 0.5 0.5 1 cairo_set_source_rgb
- cr cairo_fill_preserve
- cr 0 0 0 cairo_set_source_rgb
- cr 2.56 cairo_set_line_width
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 10 135 5.12 0 2 pi * cairo_arc
- cr cairo_close_path
- cr 70 165 5.12 0 2 pi * cairo_arc
- cr cairo_fill ;
-
-TUPLE: utf8-gadget < cairo-gadget ;
-M: utf8-gadget render-cairo* ( gadget -- )
- drop
- cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
- cr 50 cairo_set_font_size
- "cairo_text_extents_t" malloc-object
- cr "日本語" pick cairo_text_extents
- cr over
- [ cairo_text_extents_t-width 2 / ]
- [ cairo_text_extents_t-x_bearing ] bi +
- 128 swap - pick
- [ cairo_text_extents_t-height 2 / ]
- [ cairo_text_extents_t-y_bearing ] bi +
- 128 swap - cairo_move_to
- free
- cr "日本語" cairo_show_text
-
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6 cairo_set_line_width
- cr 128 0 cairo_move_to
- cr 0 256 cairo_rel_line_to
- cr 0 128 cairo_move_to
- cr 256 0 cairo_rel_line_to
- cr cairo_stroke ;
-
- USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
- : samples ( -- )
- {
- arc-gadget clip-gadget clip-image-gadget dash-gadget
- gradient-gadget text-gadget utf8-gadget
- }
- [ new-gadget { 256 256 } >>dim gadget. ] each ;
-
- MAIN: samples
! 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 alien.c-types combinators namespaces make arrays
- sequences splitting
- math math.functions math.vectors math.trig
- opengl.gl opengl.glu opengl ui ui.gadgets.slate
- vars colors self self.slots
- random-weighted colors.hsv cfdg.gl accessors
- ui.gadgets.handler ui.gestures assocs ui.gadgets macros
- specialized-arrays.double ;
-
-QUALIFIED: syntax
-
-IN: cfdg
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SELF-SLOTS: hsva
-
-: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! if (adjustment < 0)
-! base + base * adjustment
-
-! if (adjustment > 0)
-! base + (1 - base) * adjustment
-
-: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hue ( num -- ) hue-> + 360 mod ->hue ;
-
-: saturation ( num -- ) saturation-> swap adjust ->saturation ;
-: brightness ( num -- ) value-> swap adjust ->value ;
-: alpha ( num -- ) alpha-> swap adjust ->alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: h ( num -- ) hue ;
-: sat ( num -- ) saturation ;
-: b ( num -- ) brightness ;
-: a ( num -- ) alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: color-stack
-
-: init-color-stack ( -- ) V{ } clone >color-stack ;
-
-: push-color ( -- ) self> color-stack> push self> clone >self ;
-
-: pop-color ( -- ) color-stack> pop dup >self gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
-
-: double-nth* ( c-array indices -- seq )
- swap byte-array>double-array [ nth ] curry map ;
-
-: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map supremum ;
-
-VAR: threshold
-
-: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! cos 2a sin 2a 0 0
-! sin 2a -cos 2a 0 0
-! 0 0 1 0
-! 0 0 0 1
-
-! column major order
-
-: gl-flip ( angle -- ) deg>rad dup dup dup
- [ 2 * cos , 2 * sin , 0 , 0 ,
- 2 * sin , 2 * cos neg , 0 , 0 ,
- 0 , 0 , 1 , 0 ,
- 0 , 0 , 0 , 1 , ]
- double-array{ } make underlying>> glMultMatrixd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( -- )
- self> gl-color
- gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
-
-: triangle ( -- )
- self> gl-color
- GL_POLYGON glBegin
- 0 0.577 glVertex2d
- 0.5 -0.289 glVertex2d
- -0.5 -0.289 glVertex2d
- glEnd ;
-
-: square ( -- )
- self> gl-color
- GL_POLYGON glBegin
- -0.5 0.5 glVertex2d
- 0.5 0.5 glVertex2d
- 0.5 -0.5 glVertex2d
- -0.5 -0.5 glVertex2d
- glEnd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size ( scale -- ) dup 1 glScaled ;
-
-: size* ( scale-x scale-y -- ) 1 glScaled ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-: x ( x -- ) 0 0 glTranslated ;
-
-: y ( y -- ) 0 swap 0 glTranslated ;
-
-: flip ( angle -- ) gl-flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: s ( scale -- ) size ;
-: s* ( scale-x scale-y -- ) size* ;
-: r ( angle -- ) rotate ;
-: f ( angle -- ) flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: do ( quot -- )
- push-modelview-matrix
- push-color
- call
- pop-modelview-matrix
- pop-color ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recursive ( quot -- ) iterate? swap when ; inline
-
-: multi ( seq -- ) random-weighted* call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rules] ( seq -- quot )
- [ unclip swap [ [ do ] curry ] map concat 2array ] map
- [ call-random-weighted ] swap prefix
- [ when ] swap prefix
- [ iterate? ] swap append ;
-
-MACRO: rules ( seq -- quot ) [rules] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rule] ( seq -- quot )
- [ [ do ] swap prefix ] map concat
- [ when ] swap prefix
- [ iterate? ] prepend ;
-
-MACRO: rule ( seq -- quot ) [rule] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: background
-
-: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
-
-: set-background ( -- )
- set-initial-background
- background> call
- self> clear-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: rewrite-closures ;
-
-VAR: viewport ! { left width bottom height }
-
-VAR: start-shape
-
-: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: dlist
-
-! : build-model-dlist ( -- )
-! 1 glGenLists dlist set
-! dlist get GL_COMPILE_AND_EXECUTE glNewList
-! start-shape> call
-! glEndList ;
-
-: build-model-dlist ( -- )
- 1 glGenLists dlist set
- dlist get GL_COMPILE_AND_EXECUTE glNewList
-
- set-initial-color
-
- self> gl-color
-
- start-shape> call
-
- glEndList ;
-
-: display ( -- )
-
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- viewport> first dup viewport> second +
- viewport> third dup viewport> fourth + gluOrtho2D
-
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
-
- set-background
-
- GL_COLOR_BUFFER_BIT glClear
-
- init-modelview-matrix-stack
- init-color-stack
-
- dlist get not
- [ build-model-dlist ]
- [ dlist get glCallList ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
-
-: cfdg-window* ( -- slate )
- C[ display ] <slate>
- { 500 500 } >>pdim
- C[ delete-dlist ] >>ungraft
- dup "CFDG" open-window ;
-
-: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: the-slate
-
-: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
-
-: <cfdg-gadget> ( -- slate )
- C[ display ] <slate>
- dup the-slate set
- { 500 500 } >>pdim
- C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
- <handler>
- H{ } clone
- T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
- T{ button-down } C[ drop rebuild ] swap pick set-at
- >>table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: fry
-
-: cfdg-window. ( quot -- )
- '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien.c-types namespaces sequences opengl.gl ;
-
-IN: cfdg.gl
-
-: get-modelview-matrix ( -- alien )
- GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
-
-SYMBOL: modelview-matrix-stack
-
-: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
-
-: push-modelview-matrix ( -- )
- get-modelview-matrix modelview-matrix-stack get push ;
-
-: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.aqua-star
-
-: tentacle ( -- )
-iterate? [
- { { 1 [ circle
- [ .23 y .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .17 y 2 r .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
- call-random-weighted
-] when ;
-
-: anemone ( -- )
-iterate? [
- tentacle
- [ 10 x -11 r .995 s -.002 b anemone ] do
-] when ;
-
-: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -60 140 -120 140 } >viewport
- 0.1 >threshold
- [ anemone-begin ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.chiaroscuro
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: white
-
-: black ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
- { 1 [ white black ] }
- }
- rules ;
-
-: white ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
- { 1 [ black white ] }
- }
- rules ;
-
-: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -0.5 b ] >background
- { -3 6 -2 6 } >viewport
- 0.03 >threshold
- [ chiaroscuro ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 2 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { "bundle-name" "cfdg.models.flower6.app" }
-}
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.flower6
-
-: petal6 ( -- )
-iterate? [
- [ 1 0.001 s* square ] do
- [ -0.5 x 0.01 s -1 b circle ] do
- [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
-] when ;
-
-: flower6 ( -- )
-12 [ [ [ 30 r ] times petal6 ] do ] each
-12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -1 2 -1 2 } >viewport
- 0.01 >threshold
- [ flower6 ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.game1-turn6
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: f-triangles ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
- [ 10 hue 0.9 sat 0.33 b triangle ]
- [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
- [ 0.8 s 5 r f-triangles ]
- }
- rule ;
-
-: f-squares ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
- [ 220 hue 0.90 sat 0.33 b square ]
- [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
- [ 0.8 s 5 r f-squares ]
- }
- rule ;
-
-DEFER: start
-
-: spiral ( -- )
- {
- { 1 [ f-squares ]
- [ 0.5 x 0.5 y 45 r f-triangles ]
- [ 1 y 25 r 0.9 s spiral ] }
-
- { 0.022 [ 90 flip 50 hue start ] }
- }
- rules ;
-
-: start ( -- )
- [ spiral ] do
- [ 120 r spiral ] do
- [ 240 r spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ 66 hue 0.4 sat 0.5 b ] >background
- { -5 10 -5 10 } >viewport
- 0.001 >threshold
- [ start ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.lesson
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shapes ( -- )
-[ square ] do
-[ 0.3 b circle ] do
-[ 0.5 b triangle ] do
-[ 0.7 b 60 r triangle ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-1 ( -- )
-[ 2 x 5 y 3 size square ] do
-[ 6 x 5 y 3 size circle ] do
-[ 4 x 2 y 3 size triangle ] do
-[ 1 y 3 size shapes ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: foursquare ( -- )
-[ 0 x 0 y 5 3 size* square ] do
-[ 0 x 5 y 2 4 size* square ] do
-[ 5 x 5 y 3 size square ] do
-[ 5 x 0 y 2 size square ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-2 ( -- )
-[ square ] do
-[ 3 x 7 y square ] do
-[ 5 x 7 y 30 r square ] do
-[ 3 x 5 y 0.75 size square ] do
-[ 5 x 5 y 0.5 b square ] do
-[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
-[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: spiral ( -- )
-iterate? [
- [ 0.5 size circle ] do
- [ 0.2 y -3 r 0.995 size spiral ] do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: tree
-
-: branch-left ( -- )
-{ { 1 [ 20 r tree ] }
- { 1 [ 30 r tree ] }
- { 1 [ 40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch-right ( -- )
-{ { 1 [ -20 r tree ] }
- { 1 [ -30 r tree ] }
- { 1 [ -40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch ( -- ) branch-left branch-right ;
-
-: tree ( -- )
-iterate? [
- {
- { 20 [ [ 0.25 size circle ] do
- [ 0.1 y 0.97 size tree ] do ] }
- { 1.5 [ branch ] }
- } random-weighted* do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-4 ( -- )
-[ 1 x 0 y tree ] do
-[ 6 x 0 y tree ] do
-[ 1 x 4 y tree ] do
-[ 6 x 4 y tree ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: toc ( -- )
-[ 0 x 0 y chapter-1 ] do
-[ 10 x 0 y chapter-2 ] do
-[ 0 x -10 y chapter-3 ] do
-[ 10 x -10 y chapter-4 ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -5 25 -15 25 } >viewport
- 0.03 >threshold
- [ toc ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.rules08
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insct ( -- )
- [ 1.5 5.5 size* -1 brightness triangle ] do
- 10
- [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
- each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: line
-
-: ligne ( -- )
- {
- { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
- { 0.5 [ ] }
- }
- rules ;
-
-: line ( -- ) { [ insct ligne ] } rule ;
-
-: sole ( -- )
- {
- { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
- { 0.01 [ ] }
- }
- rules ;
-
-: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } viewport set
- [ centre ] >start-shape
- 0.0001 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.sierpinski
-
-: shape ( -- ) circle ;
-
-! : sierpinski ( -- )
-! iterate? [
-! shape
-! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
-! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
-! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
-! ] when ;
-
-: sierpinski ( -- )
-iterate? [
- shape
- [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
- [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
- [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
-] when ;
-
-: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -4 8 -4 8 } >viewport
- 0.01 >threshold
- [ top ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.snowflake
-
-: spike ( -- )
-iterate? [
- { { 1 [ square
- [ 0.95 y 0.97 s spike ] do ] }
- { 0.03 [ square
- [ 60 r spike ] do
- [ -60 r spike ] do
- [ 0.95 y 0.97 s spike ] do ] } }
- call-random-weighted
-] when ;
-
-: snowflake ( -- )
-spike
-[ 60 r spike ] do
-[ 120 r spike ] do
-[ 180 r spike ] do
-[ 240 r spike ] do
-[ 300 r spike ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -40 80 -40 80 } >viewport
- 0.1 >threshold
- [ snowflake ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.spirales
-
-DEFER: line
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
-
-: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
-
-: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } >viewport
- [ line ] >start-shape
- 0.04 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Implementation of: http://contextfreeart.org
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models
models.arrow models.range models.product sequences ui
-ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
-ui.gadgets.sliders ui.render math.rectangles accessors
+ui.gadgets ui.gadgets.tracks ui.gadgets.labels ui.gadgets.packs
+ui.gadgets.sliders ui.pens.solid ui.render math.rectangles accessors
ui.gadgets.grids colors ;
IN: color-picker
TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget )
- color-preview new-gadget
+ color-preview new
swap >>model
{ 100 100 } >>dim ;
bi ;
: <color-picker> ( -- gadget )
- <frame>
+ vertical <track>
{ 5 5 } >>gap
<color-sliders>
- [ @top grid-add ]
+ [ f track-add ]
[
- [ <color-model> <color-preview> @center grid-add ]
+ [ <color-model> <color-preview> 1 track-add ]
[
[ [ truncate number>string ] map " " join ]
<arrow> <label-control>
- @bottom grid-add
+ f track-add
] bi
] bi* ;
+++ /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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
- dup '[ drop [ _ run ] call-listener ] <bevel-button> { 0 0 } >>align ;
+ dup '[ drop [ _ run ] call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-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 ;
+++ /dev/null
-
-USING: arrays assocs compiler.units
- grouping help help.markup help.topics kernel lexer multiline
- namespaces parser sequences splitting words
- easy-help.expand-markup ;
-
-IN: easy-help
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: parse-text-block ( -- array )
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ expand-markup ] map
- concat
- [ dup "" = [ drop { $nl } ] [ ] if ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Text: parse-text-block parsed ; parsing
-
-: Block: scan-word 1array parse-text-block append parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Notes: { $notes } parse-text-block append parsed ; parsing
-: Description: { $description } parse-text-block append parsed ; parsing
-: Contract: { $contract } parse-text-block append parsed ; parsing
-: Checked-Example: { $example } parse-text-block append parsed ; parsing
-
-: Class-Description:
- { $class-description } parse-text-block append parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Code:
-
- { $code }
- parse-text-block [ dup array? [ drop "" ] [ ] if ] map
- append
- parsed
-
- ; parsing
-
-: Example:
- { $heading "Example" }
- { $code }
- parse-text-block
- [ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
- append
- 2array parsed ; parsing
-
-: Introduction:
-
- { $heading "Introduction" }
- parse-text-block
- 2array parsed ; parsing
-
-: Summary:
-
- { $heading "Summary" }
- parse-text-block
- 2array parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Values:
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ " " split1 [ " " first = ] trim-head 2array ] map
- \ $values prefix
- parsed
-
- ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Word:
-
- scan current-vocab create dup old-definitions get
- [ delete-at ] with each dup set-word
-
- bootstrap-word dup set-word
- dup >link save-location
- \ ; parse-until >array swap set-word-help ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: List:
-
- { $list }
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ expand-markup ] map
-
- append parsed
-
- ; parsing
+++ /dev/null
-
-USING: accessors arrays kernel lexer locals math namespaces parser
- sequences splitting ;
-
-IN: easy-help.expand-markup
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scan-one-array ( string -- array rest )
- string-lines
- lexer-factory get call
- [
- [
- \ } parse-until >array
- lexer get line-text>>
- lexer get column>> tail
- ]
- with-lexer
- ]
- with-scope ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: expand-markup ( LINE -- lines )
-
- LINE contains-markup?
- [
-
- [let | N [ "{ $" LINE start ] |
-
- LINE N head
-
- LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
-
- [ 2array ] dip
-
- expand-markup
-
- append ]
-
- ]
- [ LINE 1array ]
- if ;
+++ /dev/null
-
-USING: accessors arrays fry kernel math math.vectors sequences
- math.intervals
- multi-methods
- combinators.short-circuit
- combinators.cleave.enhanced
- multi-method-syntax ;
-
-IN: flatland
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Two dimensional world protocol
-
-GENERIC: x ( obj -- x )
-GENERIC: y ( obj -- y )
-
-GENERIC: (x!) ( x obj -- )
-GENERIC: (y!) ( y obj -- )
-
-: x! ( obj x -- obj ) over (x!) ;
-: y! ( obj y -- obj ) over (y!) ;
-
-GENERIC: width ( obj -- width )
-GENERIC: height ( obj -- height )
-
-GENERIC: (width!) ( width obj -- )
-GENERIC: (height!) ( height obj -- )
-
-: width! ( obj width -- obj ) over (width!) ;
-: height! ( obj height -- obj ) over (width!) ;
-
-! Predicates on relative placement
-
-GENERIC: to-the-left-of? ( obj obj -- ? )
-GENERIC: to-the-right-of? ( obj obj -- ? )
-
-GENERIC: below? ( obj obj -- ? )
-GENERIC: above? ( obj obj -- ? )
-
-GENERIC: in-between-horizontally? ( obj obj -- ? )
-
-GENERIC: horizontal-interval ( obj -- interval )
-
-GENERIC: move-to ( obj obj -- )
-
-GENERIC: move-by ( obj delta -- )
-
-GENERIC: move-left-by ( obj obj -- )
-GENERIC: move-right-by ( obj obj -- )
-
-GENERIC: left ( obj -- left )
-GENERIC: right ( obj -- right )
-GENERIC: bottom ( obj -- bottom )
-GENERIC: top ( obj -- top )
-
-GENERIC: distance ( a b -- c )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some of the above methods work on two element sequences.
-! A two element sequence may represent a point in space or describe
-! width and height.
-
-METHOD: x ( sequence -- x ) first ;
-METHOD: y ( sequence -- y ) second ;
-
-METHOD: (x!) ( number sequence -- ) set-first ;
-METHOD: (y!) ( number sequence -- ) set-second ;
-
-METHOD: width ( sequence -- width ) first ;
-METHOD: height ( sequence -- height ) second ;
-
-: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
-: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
-
-METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
-METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
-
-METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
-METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
-
-! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
-! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
-
-! METHOD:: move-left-by ( SEQ:sequence X:number -- )
-! SEQ { X 0 } { -1 0 } v* move-by ;
-
-METHOD: distance ( sequence sequence -- dist ) v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with a position
-
-TUPLE: <pos> pos ;
-
-METHOD: x ( <pos> -- x ) pos>> first ;
-METHOD: y ( <pos> -- y ) pos>> second ;
-
-METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
-METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
-
-METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
-METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
-
-METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
-METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
-
-METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
-METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
-
-METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
-
-METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with velocity. It inherits from <pos>. Hey, if
-! it's moving it has a position right? Unless it's some alternate universe...
-
-TUPLE: <vel> < <pos> vel ;
-
-: moving-up? ( obj -- ? ) vel>> y 0 > ;
-: moving-down? ( obj -- ? ) vel>> y 0 < ;
-
-: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
-: move-for ( vel time -- ) dupd step-size move-by ;
-
-: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! The 'pos' slot indicates the lower left hand corner of the
-! rectangle. The 'dim' is holds the width and height.
-
-TUPLE: <rectangle> < <pos> dim ;
-
-METHOD: width ( <rectangle> -- width ) dim>> first ;
-METHOD: height ( <rectangle> -- height ) dim>> second ;
-
-METHOD: left ( <rectangle> -- x ) x ;
-METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
-METHOD: bottom ( <rectangle> -- y ) y ;
-METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
-
-: bottom-left ( rectangle -- pos ) pos>> ;
-
-: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
-: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
-
-: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
-
-METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
-METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
-
-METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
-METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
-
-METHOD: horizontal-interval ( <rectangle> -- interval )
- \\ left right bi [a,b] ;
-
-METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
- \\ x horizontal-interval bi* interval-contains? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <extent> left right bottom top ;
-
-METHOD: left ( <extent> -- left ) left>> ;
-METHOD: right ( <extent> -- right ) right>> ;
-METHOD: bottom ( <extent> -- bottom ) bottom>> ;
-METHOD: top ( <extent> -- top ) top>> ;
-
-METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
-METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
-
-! METHOD: to-extent ( <rectangle> -- <extent> )
-! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: to-the-left-of? ( sequence <rectangle> -- ? ) \\ x left bi* < ;
-METHOD: to-the-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
-
-METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
-METHOD: above? ( sequence <rectangle> -- ? ) \\ y top bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some support for the' 'rect' class from math.geometry.rect'
-
-! METHOD: width ( rect -- width ) dim>> first ;
-! METHOD: height ( rect -- height ) dim>> second ;
-
-! METHOD: left ( rect -- left ) loc>> x
-! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
-
-! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
-! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: locals combinators ;
-
-:: wrap ( POINT RECT -- POINT )
-
- {
- { [ POINT RECT to-the-left-of? ] [ RECT right ] }
- { [ POINT RECT to-the-right-of? ] [ RECT left ] }
- { [ t ] [ POINT x ] }
- }
- cond
-
- {
- { [ POINT RECT below? ] [ RECT top ] }
- { [ POINT RECT above? ] [ RECT bottom ] }
- { [ t ] [ POINT y ] }
- }
- cond
-
- 2array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: within? ( a b -- ? )
-
-METHOD: within? ( <pos> <rectangle> -- ? )
- {
- [ left to-the-right-of? ]
- [ right to-the-left-of? ]
- [ bottom above? ]
- [ top below? ]
- }
- 2&& ;
+++ /dev/null
-
-USING: accessors alien.c-types combinators grouping kernel
- locals math math.geometry.rect math.vectors opengl.gl sequences
- ui.gadgets ui.render ;
-
-IN: frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <frame-buffer> < gadget pixels last-dim ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: update-frame-buffer ( <frame-buffer> -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- )
- dup
- rect-dim product "uint[4]" <c-array>
- >>pixels
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: draw-pixels ( FRAME-BUFFER -- )
-
- FRAME-BUFFER rect-dim first2
- GL_RGBA
- GL_UNSIGNED_INT
- FRAME-BUFFER pixels>>
- glDrawPixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: read-pixels ( FRAME-BUFFER -- )
-
- 0
- 0
- FRAME-BUFFER rect-dim first2
- GL_RGBA
- GL_UNSIGNED_INT
- FRAME-BUFFER pixels>>
- glReadPixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: copy-row ( OLD NEW -- )
-
- [let | LEN [ OLD NEW min-length ] |
-
- OLD LEN head-slice 0 NEW copy ] ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
- [ 16 * <sliced-groups> ] 2bi@
- [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
-
-M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
-
- {
- {
- [ FRAME-BUFFER last-dim>> f = ]
- [
- FRAME-BUFFER init-frame-buffer-pixels
-
- FRAME-BUFFER update-last-dim
- ]
- }
- {
- [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
- [
- [let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
- OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
-
- FRAME-BUFFER init-frame-buffer-pixels
-
- FRAME-BUFFER update-last-dim
-
- [let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
- NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
-
- OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
- ]
- }
- { [ t ] [ ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
-
- FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
-
- FRAME-BUFFER draw-pixels
-
- FRAME-BUFFER update-frame-buffer
-
- glFlush
-
- FRAME-BUFFER read-pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
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
--- /dev/null
+IN: game-input.tests
+USING: game-input tools.test kernel system ;
+
+os windows? os macosx? or [
+ [ ] [ open-game-input ] unit-test
+ [ ] [ close-game-input ] unit-test
+] when
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Golden Section" }
-}
+++ /dev/null
-
-USING: kernel namespaces math math.constants math.functions math.order
- arrays sequences
- opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
- ui.gadgets.cartesian colors accessors combinators.cleave
- processing.shapes ;
-
-IN: golden-section
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! omega(i) = 2*pi*i*(phi-1)
-
-! x(i) = 0.5*i*cos(omega(i))
-! y(i) = 0.5*i*sin(omega(i))
-
-! radius(i) = 10*sin((pi*i)/720)
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: omega ( i -- omega ) phi 1- * 2 * pi * ;
-
-: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
-: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
-
-: center ( i -- point ) { x y } 1arr ;
-
-: radius ( i -- radius ) pi * 720 / sin 10 * ;
-
-: color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ;
-
-: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;
-
-: draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ;
-
-: dot ( i -- ) color line-width draw ;
-
-: golden-section ( -- ) 720 [ dot ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <golden-section> ( -- gadget )
- <cartesian>
- { 600 600 } >>pdim
- { -400 400 } x-range
- { -400 400 } y-range
- [ golden-section ] >>action ;
-
-: golden-section-window ( -- )
- [ <golden-section> "Golden Section" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: golden-section-window
+++ /dev/null
-Golden section demo
! 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 ;
: <image-gadget> ( image -- gadget )
- \ image-gadget new-gadget
+ \ image-gadget new
swap >>image ;
: image-window ( path -- gadget )
: [infix|
"|" parse-bindings "infix]" parse-infix-locals <let>
- parsed-lambda ; parsing
+ ?rewrite-closures over push-all ; parsing
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
3bi ; ! FIXME
-DEFER: me?
-
! ======================================
! IRC client messages
! ======================================
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
-\r
-IN: irc.ui.commandparser\r
-\r
-: command ( string string -- string command )\r
- [ "say" ] when-empty\r
- dup "irc.ui.commands" lookup\r
- [ nip ]\r
- [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
-\r
-: parse-message ( string -- )\r
- "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel sequences arrays irc.client\r
- irc.messages irc.ui namespaces ;\r
-\r
-IN: irc.ui.commands\r
-\r
-: say ( string -- )\r
- irc-tab get\r
- [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
- [ chat>> speak ] 2bi ;\r
-\r
-: me ( string -- ) ! Placeholder until I make /me look different\r
- "ACTION " 1 prefix prepend 1 suffix say ;\r
-\r
-: join ( string -- )\r
- irc-tab get window>> join-channel ;\r
-\r
-: query ( string -- )\r
- irc-tab get window>> query-nick ;\r
-\r
-: whois ( string -- )\r
- "WHOIS" swap { } clone swap <irc-client-message>\r
- irc-tab get listener>> speak ;\r
-\r
-: quote ( string -- )\r
- drop ; ! THIS WILL CHANGE\r
+++ /dev/null
-! Default system ircui-rc file\r
-! Copy into .ircui-rc in your home directory and then change username and such\r
-! To find your home directory, type "home ." into a Factor listener\r
-\r
-USING: irc.client irc.ui ;\r
-\r
-"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
-{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
-server-open\r
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel io.files io.pathnames parser editors sequences ;\r
-\r
-IN: irc.ui.load\r
-\r
-: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
-\r
-: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
-\r
-: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
-\r
-: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
-\r
-: run-ircui ( -- ) ircui-rc run-file ;\r
+++ /dev/null
-A simple IRC client
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel threads combinators concurrency.mailboxes\r
- sequences strings hashtables splitting fry assocs hashtables colors\r
- sorting unicode.collation math.order\r
- ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
- ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
- io io.styles namespaces calendar calendar.format models continuations\r
- irc.client irc.client.private irc.messages\r
- irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
-\r
-RENAME: join sequences => sjoin\r
-\r
-IN: irc.ui\r
-\r
-SYMBOL: chat\r
-\r
-SYMBOL: client\r
-\r
-TUPLE: ui-window < tabbed client ;\r
-\r
-M: ui-window ungraft*\r
- client>> terminate-irc ;\r
-\r
-TUPLE: irc-tab < frame chat client window ;\r
-\r
-: write-color ( str color -- )\r
- foreground associate format ;\r
-CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
-CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
-CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
-\r
-: dot-or-parens ( string -- string )\r
- [ "." ]\r
- [ "(" prepend ")" append ] if-empty ;\r
-\r
-GENERIC: write-irc ( irc-message -- )\r
-\r
-M: ping write-irc\r
- drop "* Ping" blue write-color ;\r
-\r
-M: privmsg write-irc\r
- "<" dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- "> " dark-blue write-color\r
- trailing>> write ;\r
-\r
-M: notice write-irc\r
- [ type>> dark-blue write-color ] keep\r
- ": " dark-blue write-color\r
- trailing>> write ;\r
-\r
-TUPLE: own-message message nick timestamp ;\r
-\r
-: <own-message> ( message nick -- own-message )\r
- now own-message boa ;\r
-\r
-M: own-message write-irc\r
- "<" dark-blue write-color\r
- [ nick>> bold font-style associate format ] keep\r
- "> " dark-blue write-color\r
- message>> write ;\r
-\r
-M: join write-irc\r
- "* " dark-green write-color\r
- irc-message-sender write\r
- " has entered the channel." dark-green write-color ;\r
-\r
-M: part write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: quit write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left IRC" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: kick write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has kicked " dark-red write-color\r
- [ who>> write ] keep\r
- " from the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: mode write-irc\r
- "* " dark-blue write-color\r
- [ name>> write ] keep\r
- " has applied mode " dark-blue write-color\r
- [ mode>> write ] keep\r
- " to " dark-blue write-color\r
- parameter>> write ;\r
-\r
-M: nick write-irc\r
- "* " dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- " is now known as " blue write-color\r
- trailing>> write ;\r
-\r
-M: unhandled write-irc\r
- "UNHANDLED: " write\r
- line>> dark-blue write-color ;\r
-\r
-M: irc-end write-irc\r
- drop "* You have left IRC" dark-red write-color ;\r
-\r
-M: irc-disconnected write-irc\r
- drop "* Disconnected" dark-red write-color ;\r
-\r
-M: irc-connected write-irc\r
- drop "* Connected" dark-green write-color ;\r
-\r
-M: irc-chat-end write-irc\r
- drop ;\r
-\r
-M: irc-message write-irc\r
- "UNIMPLEMENTED" write\r
- [ class pprint ] keep\r
- ": " write\r
- line>> dark-blue write-color ;\r
-\r
-GENERIC: time-happened ( message -- timestamp )\r
-\r
-M: irc-message time-happened timestamp>> ;\r
-\r
-M: object time-happened drop now ;\r
-\r
-: print-irc ( irc-message -- )\r
- [ time-happened timestamp>hms write " " write ]\r
- [ write-irc nl ] bi ;\r
-\r
-: send-message ( message -- )\r
- [ print-irc ]\r
- [ chat get speak ] bi ;\r
-\r
-GENERIC: handle-inbox ( tab message -- )\r
-\r
-: value-labels ( assoc val -- seq )\r
- '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
-\r
-: add-gadget-color ( pack seq color -- pack )\r
- '[ _ >>color add-gadget ] each ;\r
-\r
-M: object handle-inbox\r
- nip print-irc ;\r
-\r
-: display ( stream tab -- )\r
- '[ _ [ [ t ]\r
- [ _ dup chat>> hear handle-inbox ]\r
- while ] with-output-stream ] "ircv" spawn drop ;\r
-\r
-: <irc-pane> ( tab -- tab pane )\r
- <scrolling-pane>\r
- [ <pane-stream> swap display ] 2keep ;\r
-\r
-TUPLE: irc-editor < editor outstream tab ;\r
-\r
-: <irc-editor> ( tab pane -- tab editor )\r
- irc-editor new-editor\r
- swap <pane-stream> >>outstream ;\r
-\r
-: editor-send ( irc-editor -- )\r
- { [ outstream>> ]\r
- [ [ irc-tab? ] find-parent ]\r
- [ editor-string ]\r
- [ "" swap set-editor-string ] } cleave\r
- '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
-\r
-irc-editor "general" f {\r
- { T{ key-down f f "RET" } editor-send }\r
- { T{ key-down f f "ENTER" } editor-send }\r
-} define-command-map\r
-\r
-: new-irc-tab ( chat ui-window class -- irc-tab )\r
- new-frame\r
- swap >>window\r
- swap >>chat\r
- <irc-pane> [ <scroller> @center grid-add ] keep\r
- <irc-editor> <scroller> @bottom grid-add ;\r
-\r
-M: irc-tab graft*\r
- [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
-\r
-M: irc-tab ungraft*\r
- chat>> detach-chat ;\r
-\r
-TUPLE: irc-channel-tab < irc-tab userlist ;\r
-\r
-: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
- irc-channel-tab new-irc-tab\r
- <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
-\r
-: update-participants ( tab -- )\r
- [ userlist>> [ clear-gadget ] keep ]\r
- [ chat>> participants>> ] bi\r
- [ +operator+ value-labels dark-green add-gadget-color ]\r
- [ +voice+ value-labels blue add-gadget-color ]\r
- [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
-\r
-M: participant-changed handle-inbox\r
- drop update-participants ;\r
-\r
-TUPLE: irc-server-tab < irc-tab ;\r
-\r
-: <irc-server-tab> ( chat -- irc-tab )\r
- f irc-server-tab new-irc-tab ;\r
-\r
-: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
- irc-tab new-irc-tab ;\r
-\r
-M: irc-tab pref-dim*\r
- drop { 480 480 } ;\r
-\r
-: join-channel ( name ui-window -- )\r
- [ dup <irc-channel-chat> ] dip\r
- [ <irc-channel-tab> swap ] keep\r
- add-page ;\r
-\r
-: query-nick ( nick ui-window -- )\r
- [ dup <irc-nick-chat> ] dip\r
- [ <irc-nick-tab> swap ] keep\r
- add-page ;\r
-\r
-: irc-window ( ui-window -- )\r
- [ ]\r
- [ client>> profile>> server>> ] bi\r
- open-window ;\r
-\r
-: ui-connect ( profile -- ui-window )\r
- <irc-client>\r
- { [ [ <irc-server-chat> ] dip attach-chat ]\r
- [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
- "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
- [ >>client ]\r
- [ connect-irc ] } cleave ;\r
-\r
-: server-open ( server port nick password channels -- )\r
- [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each drop ;\r
-\r
-: main-run ( -- ) run-ircui ;\r
-\r
-MAIN: main-run\r
-\r
-"irc.ui.commands" require\r
USING: ui ui.gadgets sequences kernel arrays math colors
-ui.render math.vectors accessors fry ui.gadgets.packs game-input
-ui.gadgets.labels ui.gadgets.borders alarms
-calendar locals strings ui.gadgets.buttons
+colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
+accessors fry ui.gadgets.packs game-input ui.gadgets.labels
+ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
[ z-indicator>> (>>loc) ] 2bi* ;
: move-pov ( gadget pov -- )
- swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
+ swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
with assoc-each ;
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
- gadget white polygon <polygon-gadget> [ add-gadget ] keep
+ gadget
COLOR: white polygon <polygon-gadget> [ add-gadget ] keep
direction swap ;
: add-pov-gadgets ( gadget -- gadget )
: <axis-gadget> ( -- gadget )
axis-gadget new
add-pov-gadgets
- black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
- red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
+ COLOR: black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
+ COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
- { 2 2 } <border> gray <solid> >>boundary add-gadget ;
+ { 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
- number>string [ ] <bevel-button>
+ number>string [ drop ] <border-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
[ >>selected? drop ] 2each ;
: kill-update-axes ( gadget -- )
- gray <solid> >>interior
+ COLOR: gray <solid> >>interior
[ [ cancel-alarm ] when* f ] change-alarm
relayout-1 ;
: make-key-gadget ( scancode dim array -- )
[
swap [
- " " [ drop ] <bevel-button>
+ " " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel math io calendar grouping
-calendar.format calendar.model arrays models models.arrow
-namespaces ui.gadgets ui.gadgets.labels ui.gadgets.theme ui ;
+calendar.format calendar.model fonts arrays models models.arrow
+namespaces ui.gadgets ui.gadgets.labels ui ;
IN: lcd
: lcd-digit ( row digit -- str )
IN: literals.tests
<<
-: six-six-six 6 6 6 ;
+: six-six-six ( -- a b c ) 6 6 6 ;
>>
-: five 5 ;
-: seven-eleven 7 11 ;
+: five ( -- a ) 5 ;
+: seven-eleven ( -- b c ) 7 11 ;
[ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
IN: literals
: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
-: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
+: $[ parse-quotation with-datastack >vector ; parsing
-! 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 ;
-
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.rectangles ;
+math.order math.rectangles accessors ;
IN: maze
CONSTANT: line-width 8
+++ /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
: nehe-window ( -- )
[
<filled-pile>
- "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
- "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
- "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
- "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
+ "Nehe 2" [ drop run2 ] <border-button> add-gadget
+ "Nehe 3" [ drop run3 ] <border-button> add-gadget
+ "Nehe 4" [ drop run4 ] <border-button> add-gadget
+ "Nehe 5" [ drop run5 ] <border-button> add-gadget
"Nehe examples" open-window
] with-ui ;
new
swap >>distance
swap >>pitch
- swap >>yaw ;
+ swap >>yaw ; inline
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
- { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
+ { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
} set-gestures
+++ /dev/null
-IN: opengl.gadgets.tests
-USING: tools.test opengl.gadgets ;
-
-\ render* must-infer
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: locals math.functions math namespaces
-opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
-fry assocs
-destructors sequences ui.render colors ;
-IN: opengl.gadgets
-
-TUPLE: texture-gadget < gadget ;
-
-GENERIC: render* ( gadget -- texture dims )
-GENERIC: cache-key* ( gadget -- key )
-
-M: texture-gadget cache-key* ;
-
-SYMBOL: textures
-SYMBOL: refcounts
-
-: init-cache ( symbol -- )
- dup get [ drop ] [ H{ } clone swap set-global ] if ;
-
-textures init-cache
-refcounts init-cache
-
-: refcount-change ( gadget quot -- )
- [ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
-
-TUPLE: cache-entry tex dims ;
-C: <entry> cache-entry
-
-: make-entry ( gadget -- entry )
- dup render* <entry>
- [ swap cache-key* textures get set-at ] keep ;
-
-: get-entry ( gadget -- {texture,dims} )
- dup cache-key* textures get at
- [ nip ] [ make-entry ] if* ;
-
-: get-dims ( gadget -- dims )
- get-entry dims>> ;
-
-: get-texture ( gadget -- texture )
- get-entry tex>> ;
-
-: release-texture ( gadget -- )
- cache-key* textures get delete-at*
- [ tex>> delete-texture ] [ drop ] if ;
-
-: clear-textures ( -- )
- textures get values [ tex>> delete-texture ] each
- H{ } clone textures set-global
- H{ } clone refcounts set-global ;
-
-M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
-
-M: texture-gadget ungraft* ( gadget -- )
- dup [ 1- ] refcount-change
- dup cache-key* refcounts get at
- zero? [ release-texture ] [ drop ] if ;
-
-: 2^-ceil ( x -- y )
- dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
-
-: 2^-bounds ( dim -- dim' )
- [ 2^-ceil ] map ; foldable flushable
-
-:: (render-bytes) ( dims bytes format texture -- )
- GL_ENABLE_BIT [
- GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D texture glBindTexture
- GL_TEXTURE_2D
- 0
- GL_RGBA
- dims 2^-bounds first2
- 0
- format
- GL_UNSIGNED_BYTE
- bytes
- glTexImage2D
- init-texture
- GL_TEXTURE_2D 0 glBindTexture
- ] do-attribs ;
-
-: render-bytes ( dims bytes format -- texture )
- gen-texture [ (render-bytes) ] keep ;
-
-: render-bytes* ( dims bytes format -- texture dims )
- pick [ render-bytes ] dip ;
-
-:: four-corners ( dim -- )
- [let* | w [ dim first ]
- h [ dim second ]
- dim' [ dim dup 2^-bounds [ /f ] 2map ]
- w' [ dim' first ]
- h' [ dim' second ] |
- 0 0 glTexCoord2d 0 0 glVertex2d
- 0 h' glTexCoord2d 0 h glVertex2d
- w' h' glTexCoord2d w h glVertex2d
- w' 0 glTexCoord2d w 0 glVertex2d
- ] ;
-
-M: texture-gadget draw-gadget* ( gadget -- )
- origin get [
- GL_ENABLE_BIT [
- white gl-color
- 1.0 -1.0 glPixelZoom
- GL_TEXTURE_2D glEnable
- GL_TEXTURE_2D over get-texture glBindTexture
- GL_QUADS [
- get-dims four-corners
- ] do-state
- GL_TEXTURE_2D 0 glBindTexture
- ] do-attribs
- ] with-translation ;
-
-M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-IN: ori.tests
-USING: ori tools.test ;
-
-\ pitch-up must-infer
-\ pitch-down must-infer
-\ turn-left must-infer
-\ turn-right must-infer
-\ roll-left must-infer
-\ roll-right must-infer
+++ /dev/null
-
-USING: kernel namespaces make accessors
- math math.constants math.functions math.matrices math.vectors
- sequences splitting grouping self math.trig ;
-
-IN: ori
-
-TUPLE: ori val ;
-
-C: <ori> ori
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ori> ( -- val ) self> val>> ;
-
-: >ori ( val -- ) self> (>>val) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These rotation matrices are from
-! `Computer Graphics: Principles and Practice'
-
-: Rz ( angle -- Rx ) deg>rad
-[ dup cos , dup sin neg , 0 ,
- dup sin , dup cos , 0 ,
- 0 , 0 , 1 , ] 3 make-matrix nip ;
-
-: Ry ( angle -- Ry ) deg>rad
-[ dup cos , 0 , dup sin ,
- 0 , 1 , 0 ,
- dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
-
-: Rx ( angle -- Rz ) deg>rad
-[ 1 , 0 , 0 ,
- 0 , dup cos , dup sin neg ,
- 0 , dup sin , dup cos , ] 3 make-matrix nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) ori> swap m. >ori ;
-
-: rotate-x ( angle -- ) Rx apply-rotation ;
-: rotate-y ( angle -- ) Ry apply-rotation ;
-: rotate-z ( angle -- ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( angle -- ) neg rotate-x ;
-: pitch-down ( angle -- ) rotate-x ;
-
-: turn-left ( angle -- ) rotate-y ;
-: turn-right ( angle -- ) neg rotate-y ;
-
-: roll-left ( angle -- ) neg rotate-z ;
-: roll-right ( angle -- ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( -- 3array ) ori> [ first ] map ;
-: Y ( -- 3array ) ori> [ second ] map ;
-: Z ( -- 3array ) ori> [ third ] map ;
-
-: set-X ( seq -- ) ori> [ set-first ] 2each ;
-: set-Y ( seq -- ) ori> [ set-second ] 2each ;
-: set-Z ( seq -- ) ori> [ set-third ] 2each ;
-
-: roll-until-horizontal ( -- )
-V Z cross normalize set-X
-Z X cross normalize set-Y ;
-
! 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
-
-USING: kernel accessors locals math math.intervals math.order
- namespaces sequences threads
- ui
- ui.gadgets
- ui.gestures
- ui.render
- calendar
- multi-methods
- multi-method-syntax
- combinators.short-circuit.smart
- combinators.cleave.enhanced
- processing.shapes
- flatland ;
-
-IN: pong
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
-!
-! Which was based on this Nodebox version: http://billmill.org/pong.html
-! by Bill Mill.
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clamp-to-interval ( x interval -- x )
- [ from>> first max ] [ to>> first min ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-TUPLE: <computer> < <paddle> { speed initial: 10 } ;
-
-: computer-move-left ( computer -- ) dup speed>> move-left-by ;
-: computer-move-right ( computer -- ) dup speed>> move-right-by ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <ball> < <vel>
- { diameter initial: 20 }
- { bounciness initial: 1.2 }
- { max-speed initial: 10 } ;
-
-: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
-: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
-
-: in-bounds? ( ball field -- ? )
- {
- [ above-lower-bound? ]
- [ below-upper-bound? ]
- } && ;
-
-:: bounce-change-vertical-velocity ( BALL -- )
-
- BALL vel>> y neg
- BALL bounciness>> *
-
- BALL max-speed>> min
-
- BALL vel>> (y!) ;
-
-:: bounce-off-paddle ( BALL PADDLE -- )
-
- BALL bounce-change-vertical-velocity
-
- BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
-
- PADDLE top BALL pos>> (y!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-x ( -- x ) hand-loc get first ;
-
-:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-
- PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
-
-:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
-
- mouse-x
-
- PADDLE PLAY-FIELD valid-paddle-interval
-
- clamp-to-interval
-
- PADDLE pos>> (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Protocol for drawing PONG objects
-
-GENERIC: draw ( obj -- )
-
-METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
- ! by multi-methods
-
-TUPLE: <pong> < gadget paused field ball player computer ;
-
-: pong ( -- gadget )
- <pong> new-gadget
- T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
- T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
- T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
- T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
-
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <pong> draw-gadget* ( PONG -- )
-
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- [let | FIELD [ GADGET field>> ]
- BALL [ GADGET ball>> ]
- PLAYER [ GADGET player>> ]
- COMPUTER [ GADGET computer>> ] |
-
- [wlet | align-player-with-mouse [ ( -- )
- PLAYER FIELD align-paddle-with-mouse ]
-
- move-ball [ ( -- ) BALL 1 move-for ]
-
- player-blocked-ball? [ ( -- ? )
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
-
- computer-blocked-ball? [ ( -- ? )
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
-
- bounce-off-wall? [ ( -- ? )
- BALL FIELD in-between-horizontally? not ]
-
- stop-game [ ( -- ) t GADGET (>>paused) ] |
-
- BALL FIELD in-bounds?
- [
-
- align-player-with-mouse
-
- move-ball
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
- computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
- bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
- ]
- [ stop-game ]
- if
-
- ] ] ( gadget -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-pong-thread ( GADGET -- )
- f GADGET (>>paused)
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
-
-: pong-main ( -- ) [ pong-window ] with-ui ;
-
-MAIN: pong-window
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.functions math.vectors sequences self
-accessors ;
-
-IN: pos
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: pos val ;
-
-C: <pos> pos
-
-: pos> ( -- val ) self> val>> ;
-
-: >pos ( val -- ) self> (>>val) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
-
-: move-by ( point -- ) pos> v+ >pos ;
-
+++ /dev/null
-
-USING: kernel namespaces arrays sequences grouping
- alien.c-types
- math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl generalizations vars
- combinators.cleave colors ;
-
-IN: processing.shapes
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: do-state ( mode quot -- ) swap glBegin call glEnd ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: fill-color
-VAR: stroke-color
-
-T{ rgba f 0 0 0 1 } stroke-color set-global
-T{ rgba f 1 1 1 1 } fill-color set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill-mode ( -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-mode ( -- )
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
-
-: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
-: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
-: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line** ( x y x y -- )
- stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
-
-: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
-
-: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
-
-: line ( seq -- ) lines ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: triangles ( seq -- )
- [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
-
-: triangle ( seq -- ) triangles ;
-
-: triangle* ( a b c -- ) 3array triangles ;
-
-: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: polygon ( seq -- )
- [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rectangle ( loc dim -- )
- <rect>
- { top-left top-right bottom-right bottom-left }
- 1arr
- polygon ;
-
-: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
-
-: gl-scale-2d ( xy -- ) first2 1 glScaled ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-ellipse ( center dim -- )
- glPushMatrix
- [ gl-translate-2d ] [ gl-scale-2d ] bi*
- gluNewQuadric
- dup 0 0.5 20 1 gluDisk
- gluDeleteQuadric
- glPopMatrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-get-line-width ( -- width )
- GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
-
-: ellipse ( center dim -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> gl-color gl-ellipse ]
- [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( center size -- ) dup 2array ellipse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays quotations sequences assocs combinators
- mirrors math math.vectors random macros fry ;
-
-IN: random-weighted
-
-: probabilities ( weights -- probabilities ) dup sum v/n ;
-
-: layers ( probabilities -- layers )
-dup length 1+ [ head ] with map rest [ sum ] map ;
-
-: random-weighted ( weights -- elt )
-probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
-
-: random-weighted* ( seq -- elt )
-dup [ second ] map swap [ first ] map random-weighted swap nth ;
-
-MACRO: call-random-weighted ( exp -- )
- [ keys ] [ values <enum> >alist ] bi
- '[ _ random-weighted _ case ] ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel parser math quotations namespaces sequences macros fry ;
-
-IN: rewrite-closures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
-
-MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: parametric-quot ( parameters quot -- quot ) '[ _ set-parameters _ call ] ;
-
-: scoped-quot ( quot -- quot ) '[ _ with-scope ] ;
-
-: closed-quot ( quot -- quot )
- namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: C[ \ ] [ >quotation ] parse-literal \ closed-quot parsed ; parsing
\ No newline at end of file
+++ /dev/null
-Closures implemented via quotation rewriting
+++ /dev/null
-extensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces vars ;
-
-IN: self
-
-VAR: self
-
-: with-self ( quot obj -- ) [ >self call ] with-scope ;
-
-: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
+++ /dev/null
-
-USING: kernel words lexer parser sequences accessors self ;
-
-IN: self.slots
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-self-slot-reader ( slot -- )
- [ "->" append current-vocab create dup set-word ]
- [ ">>" append search [ self> ] swap suffix ] bi
- (( -- value )) define-declared ;
-
-: define-self-slot-writer ( slot -- )
- [ "->" prepend current-vocab create dup set-word ]
- [ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
- (( value -- )) define-declared ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-self-slot-accessors ( class -- )
- "slots" word-prop
- [ name>> ] map
- [ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing
\ No newline at end of file
! 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.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
parser accessors colors ;
IN: slides
H{
{ default-span-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 36 }
}
}
}
{ code-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ font-size 36 }
{ page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
}
}
{ snippet-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ font-size 36 }
{ foreground T{ rgba f 0.1 0.1 0.4 1 } }
}
{ list-style
H{ { table-gap { 10 20 } } }
}
- { bullet "\u0000b7" }
}
: $title ( string -- )
- [ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
+ [ H{ { font-name "sans-serif" } { font-size 48 } } format ] ($block) ;
: $divider ( -- )
[
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: kernel opengl opengl.demo-support opengl.gl
+USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
opengl.shaders opengl.framebuffers opengl.capabilities multiline
ui.gadgets accessors sequences ui.render ui math locals arrays
generalizations combinators ui.gadgets.worlds ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math math.vectors random
- springies springies.ui ;
-
-IN: springies.models.2snake
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.001 >time-slice
-gravity off
-
-1 19.0 328.0 0.0 0.0 1.0 1.0 mass
-2 36.0 328.0 0.0 0.0 1.0 1.0 mass
-3 54.0 328.0 0.0 0.0 1.0 1.0 mass
-4 72.0 328.0 0.0 0.0 1.0 1.0 mass
-5 90.0 328.0 0.0 0.0 1.0 1.0 mass
-6 108.0 328.0 0.0 0.0 1.0 1.0 mass
-7 126.0 328.0 0.0 0.0 1.0 1.0 mass
-8 144.0 328.0 0.0 0.0 1.0 1.0 mass
-9 162.0 328.0 0.0 0.0 1.0 1.0 mass
-10 180.0 328.0 0.0 0.0 1.0 1.0 mass
-11 198.0 328.0 0.0 0.0 1.0 1.0 mass
-12 216.0 328.0 0.0 0.0 1.0 1.0 mass
-13 234.0 328.0 0.0 0.0 1.0 1.0 mass
-14 252.0 328.0 0.0 0.0 1.0 1.0 mass
-15 270.0 328.0 0.0 0.0 1.0 1.0 mass
-16 288.0 328.0 0.0 0.0 1.0 1.0 mass
-17 306.0 328.0 0.0 0.0 1.0 1.0 mass
-18 324.0 328.0 0.0 0.0 1.0 1.0 mass
-19 342.0 328.0 0.0 0.0 1.0 1.0 mass
-20 360.0 328.0 0.0 0.0 1.0 1.0 mass
-21 378.0 328.0 0.0 0.0 1.0 1.0 mass
-22 396.0 328.0 0.0 0.0 1.0 1.0 mass
-23 414.0 328.0 0.0 0.0 1.0 1.0 mass
-24 432.0 328.0 0.0 0.0 1.0 1.0 mass
-25 450.0 328.0 0.0 0.0 1.0 1.0 mass
-26 468.0 328.0 0.0 0.0 1.0 1.0 mass
-27 504.0 328.0 0.0 0.0 1.0 1.0 mass
-28 486.0 328.0 0.0 0.0 1.0 1.0 mass
-29 522.0 328.0 0.0 0.0 1.0 1.0 mass
-30 540.0 328.0 0.0 0.0 1.0 1.0 mass
-31 558.0 328.0 0.0 0.0 1.0 1.0 mass
-32 576.0 328.0 0.0 0.0 1.0 1.0 mass
-33 594.0 328.0 0.0 0.0 1.0 1.0 mass
-34 612.0 328.0 0.0 0.0 1.0 1.0 mass
-35 630.0 328.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 19 20 200.0 1.500000 18.0 spng
-20 20 21 200.0 1.500000 18.0 spng
-21 21 22 200.0 1.500000 18.0 spng
-22 22 23 200.0 1.500000 18.0 spng
-23 23 24 200.0 1.500000 18.0 spng
-24 24 25 200.0 1.500000 18.0 spng
-25 25 26 200.0 1.500000 18.0 spng
-26 26 28 200.0 1.500000 18.0 spng
-27 28 27 200.0 1.500000 18.0 spng
-28 27 29 200.0 1.500000 18.0 spng
-29 29 30 200.0 1.500000 18.0 spng
-30 30 31 200.0 1.500000 18.0 spng
-31 31 32 200.0 1.500000 18.0 spng
-32 32 33 200.0 1.500000 18.0 spng
-33 33 34 200.0 1.500000 18.0 spng
-34 34 35 200.0 1.500000 18.0 spng
-35 1 3 200.0 1.500000 36.0 spng
-36 2 4 200.0 1.500000 36.0 spng
-37 3 5 200.0 1.500000 36.0 spng
-38 4 6 200.0 1.500000 36.0 spng
-39 5 7 200.0 1.500000 36.0 spng
-40 6 8 200.0 1.500000 36.0 spng
-41 7 9 200.0 1.500000 36.0 spng
-42 8 10 200.0 1.500000 36.0 spng
-43 9 11 200.0 1.500000 36.0 spng
-44 10 12 200.0 1.500000 36.0 spng
-45 11 13 200.0 1.500000 36.0 spng
-46 12 14 200.0 1.500000 36.0 spng
-47 13 15 200.0 1.500000 36.0 spng
-48 14 16 200.0 1.500000 36.0 spng
-49 15 17 200.0 1.500000 36.0 spng
-50 16 18 200.0 1.500000 36.0 spng
-51 17 19 200.0 1.500000 36.0 spng
-52 18 20 200.0 1.500000 36.0 spng
-53 19 21 200.0 1.500000 36.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 28 200.0 1.500000 36.0 spng
-60 26 27 200.0 1.500000 36.0 spng
-61 28 29 200.0 1.500000 36.0 spng
-62 27 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-
-nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ;
-
-USING: threads ui ;
-
-: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random springies springies.ui ;
-
-IN: springies.models.2x2snake
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.002 >time-slice
-gravity off
-
-1 147.0 324.0 0.0 0.0 1.0 1.0 mass
-2 164.0 324.0 0.0 0.0 1.0 1.0 mass
-3 182.0 324.0 0.0 0.0 1.0 1.0 mass
-4 200.0 324.0 0.0 0.0 1.0 1.0 mass
-5 218.0 324.0 0.0 0.0 1.0 1.0 mass
-6 236.0 324.0 0.0 0.0 1.0 1.0 mass
-7 254.0 324.0 0.0 0.0 1.0 1.0 mass
-8 272.0 324.0 0.0 0.0 1.0 1.0 mass
-9 290.0 324.0 0.0 0.0 1.0 1.0 mass
-10 308.0 324.0 0.0 0.0 1.0 1.0 mass
-11 326.0 324.0 0.0 0.0 1.0 1.0 mass
-12 344.0 324.0 0.0 0.0 1.0 1.0 mass
-13 362.0 324.0 0.0 0.0 1.0 1.0 mass
-14 380.0 324.0 0.0 0.0 1.0 1.0 mass
-15 398.0 324.0 0.0 0.0 1.0 1.0 mass
-16 416.0 324.0 0.0 0.0 1.0 1.0 mass
-17 434.0 324.0 0.0 0.0 1.0 1.0 mass
-18 452.0 324.0 0.0 0.0 1.0 1.0 mass
-19 470.0 324.0 0.0 0.0 1.0 1.0 mass
-20 147.0 298.0 0.0 0.0 1.0 1.0 mass
-21 164.0 298.0 0.0 0.0 1.0 1.0 mass
-22 182.0 298.0 0.0 0.0 1.0 1.0 mass
-23 200.0 298.0 0.0 0.0 1.0 1.0 mass
-24 218.0 298.0 0.0 0.0 1.0 1.0 mass
-25 236.0 298.0 0.0 0.0 1.0 1.0 mass
-26 254.0 298.0 0.0 0.0 1.0 1.0 mass
-27 272.0 298.0 0.0 0.0 1.0 1.0 mass
-28 290.0 298.0 0.0 0.0 1.0 1.0 mass
-29 308.0 298.0 0.0 0.0 1.0 1.0 mass
-30 326.0 298.0 0.0 0.0 1.0 1.0 mass
-31 344.0 298.0 0.0 0.0 1.0 1.0 mass
-32 362.0 298.0 0.0 0.0 1.0 1.0 mass
-33 380.0 298.0 0.0 0.0 1.0 1.0 mass
-34 398.0 298.0 0.0 0.0 1.0 1.0 mass
-35 416.0 298.0 0.0 0.0 1.0 1.0 mass
-36 434.0 298.0 0.0 0.0 1.0 1.0 mass
-37 452.0 298.0 0.0 0.0 1.0 1.0 mass
-38 470.0 298.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 1 3 200.0 1.500000 36.0 spng
-20 2 4 200.0 1.500000 36.0 spng
-21 3 5 200.0 1.500000 36.0 spng
-22 4 6 200.0 1.500000 36.0 spng
-23 5 7 200.0 1.500000 36.0 spng
-24 6 8 200.0 1.500000 36.0 spng
-25 7 9 200.0 1.500000 36.0 spng
-26 8 10 200.0 1.500000 36.0 spng
-27 9 11 200.0 1.500000 36.0 spng
-28 10 12 200.0 1.500000 36.0 spng
-29 11 13 200.0 1.500000 36.0 spng
-30 12 14 200.0 1.500000 36.0 spng
-31 13 15 200.0 1.500000 36.0 spng
-32 14 16 200.0 1.500000 36.0 spng
-33 15 17 200.0 1.500000 36.0 spng
-34 16 18 200.0 1.500000 36.0 spng
-35 17 19 200.0 1.500000 36.0 spng
-36 20 21 200.0 1.500000 18.0 spng
-37 22 21 200.0 1.500000 18.0 spng
-38 22 23 200.0 1.500000 18.0 spng
-39 23 24 200.0 1.500000 18.0 spng
-40 24 25 200.0 1.500000 18.0 spng
-41 25 26 200.0 1.500000 18.0 spng
-42 26 27 200.0 1.500000 18.0 spng
-43 27 28 200.0 1.500000 18.0 spng
-44 28 29 200.0 1.500000 18.0 spng
-45 29 30 200.0 1.500000 18.0 spng
-46 30 31 200.0 1.500000 18.0 spng
-47 31 32 200.0 1.500000 18.0 spng
-48 32 33 200.0 1.500000 18.0 spng
-49 33 34 200.0 1.500000 18.0 spng
-50 34 35 200.0 1.500000 18.0 spng
-51 35 36 200.0 1.500000 18.0 spng
-52 36 37 200.0 1.500000 18.0 spng
-53 37 38 200.0 1.500000 18.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 27 200.0 1.500000 36.0 spng
-60 26 28 200.0 1.500000 36.0 spng
-61 27 29 200.0 1.500000 36.0 spng
-62 28 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-68 34 36 200.0 1.500000 36.0 spng
-69 35 37 200.0 1.500000 36.0 spng
-70 36 38 200.0 1.500000 36.0 spng
-71 1 20 200.0 1.500000 26.0 spng
-72 2 21 200.0 1.500000 26.0 spng
-73 3 22 200.0 1.500000 26.0 spng
-74 4 23 200.0 1.500000 26.0 spng
-75 5 24 200.0 1.500000 26.0 spng
-76 25 6 200.0 1.500000 26.0 spng
-77 7 26 200.0 1.500000 26.0 spng
-78 27 8 200.0 1.500000 26.0 spng
-79 9 28 200.0 1.500000 26.0 spng
-80 29 10 200.0 1.500000 26.0 spng
-81 11 30 200.0 1.500000 26.0 spng
-82 31 12 200.0 1.500000 26.0 spng
-83 13 32 200.0 1.500000 26.0 spng
-84 33 14 200.0 1.500000 26.0 spng
-85 15 34 200.0 1.500000 26.0 spng
-86 35 16 200.0 1.500000 26.0 spng
-87 17 36 200.0 1.500000 26.0 spng
-88 37 18 200.0 1.500000 26.0 spng
-89 19 38 200.0 1.500000 26.0 spng
-90 1 21 200.0 1.500000 31.064449 spng
-91 2 20 200.0 1.500000 31.064449 spng
-92 2 22 200.0 1.500000 31.622777 spng
-93 3 21 200.0 1.500000 31.622777 spng
-94 3 23 200.0 1.500000 31.622777 spng
-95 4 22 200.0 1.500000 31.622777 spng
-96 4 24 200.0 1.500000 31.622777 spng
-97 5 23 200.0 1.500000 31.622777 spng
-98 5 25 200.0 1.500000 31.622777 spng
-99 6 24 200.0 1.500000 31.622777 spng
-100 6 26 200.0 1.500000 31.622777 spng
-101 7 25 200.0 1.500000 31.622777 spng
-102 7 27 200.0 1.500000 31.622777 spng
-103 8 26 200.0 1.500000 31.622777 spng
-104 8 28 200.0 1.500000 31.622777 spng
-105 9 27 200.0 1.500000 31.622777 spng
-106 9 29 200.0 1.500000 31.622777 spng
-107 10 28 200.0 1.500000 31.622777 spng
-108 10 30 200.0 1.500000 31.622777 spng
-109 11 29 200.0 1.500000 31.622777 spng
-110 11 31 200.0 1.500000 31.622777 spng
-111 12 30 200.0 1.500000 31.622777 spng
-112 12 32 200.0 1.500000 31.622777 spng
-113 13 31 200.0 1.500000 31.622777 spng
-114 13 33 200.0 1.500000 31.622777 spng
-115 14 32 200.0 1.500000 31.622777 spng
-116 14 34 200.0 1.500000 31.622777 spng
-117 15 33 200.0 1.500000 31.622777 spng
-118 15 35 200.0 1.500000 31.622777 spng
-119 16 34 200.0 1.500000 31.622777 spng
-120 16 36 200.0 1.500000 31.622777 spng
-121 17 35 200.0 1.500000 31.622777 spng
-122 17 37 200.0 1.500000 31.622777 spng
-123 18 36 200.0 1.500000 31.622777 spng
-124 18 38 200.0 1.500000 31.622777 spng
-125 19 37 200.0 1.500000 31.622777 spng
-126 1 22 200.0 1.500000 43.600459 spng
-127 3 20 200.0 1.500000 43.600459 spng
-128 2 23 200.0 1.500000 44.407207 spng
-129 4 21 200.0 1.500000 44.407207 spng
-130 3 24 200.0 1.500000 44.407207 spng
-131 5 22 200.0 1.500000 44.407207 spng
-132 4 25 200.0 1.500000 44.407207 spng
-133 6 23 200.0 1.500000 44.407207 spng
-134 5 26 200.0 1.500000 44.407207 spng
-135 7 24 200.0 1.500000 44.407207 spng
-136 6 27 200.0 1.500000 44.407207 spng
-137 8 25 200.0 1.500000 44.407207 spng
-138 7 28 200.0 1.500000 44.407207 spng
-139 9 26 200.0 1.500000 44.407207 spng
-140 8 29 200.0 1.500000 44.407207 spng
-141 10 27 200.0 1.500000 44.407207 spng
-142 9 30 200.0 1.500000 44.407207 spng
-143 11 28 200.0 1.500000 44.407207 spng
-144 10 31 200.0 1.500000 44.407207 spng
-145 12 29 200.0 1.500000 44.407207 spng
-146 11 32 200.0 1.500000 44.407207 spng
-147 13 30 200.0 1.500000 44.407207 spng
-148 12 33 200.0 1.500000 44.407207 spng
-149 14 31 200.0 1.500000 44.407207 spng
-150 13 34 200.0 1.500000 44.407207 spng
-151 15 33 200.0 1.500000 31.622777 spng
-152 32 15 200.0 1.500000 44.407207 spng
-153 14 35 200.0 1.500000 44.407207 spng
-154 16 33 200.0 1.500000 44.407207 spng
-155 15 36 200.0 1.500000 44.407207 spng
-156 34 17 200.0 1.500000 44.407207 spng
-157 16 37 200.0 1.500000 44.407207 spng
-158 18 35 200.0 1.500000 44.407207 spng
-159 17 38 200.0 1.500000 44.407207 spng
-160 19 36 200.0 1.500000 44.407207 spng
-
-! Send the half of the snake in a random direction
-
-nodes> 10 [ swap nth ] with map
-nodes> 10 [ 19 + swap nth ] with map append
-100 random -50 + 100 random 100 + { -1 1 } random * 2array
-[ swap set-node-vel ] curry
-each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-ui? t }
- { deploy-reflection 1 }
- { deploy-name "springies.models.2x2snake" }
- { deploy-c-types? f }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
- { deploy-math? t }
- { deploy-io 1 }
-}
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math ui random fry
- springies springies.ui ;
-
-IN: springies.models.3snake
-
-: random-range ( a b -- n ) 1+ over - random + ;
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.001 >time-slice
-gravity off
-
-1 19.0 328.0 0.0 0.0 1.0 1.0 mass
-2 36.0 328.0 0.0 0.0 1.0 1.0 mass
-3 54.0 328.0 0.0 0.0 1.0 1.0 mass
-4 72.0 328.0 0.0 0.0 1.0 1.0 mass
-5 90.0 328.0 0.0 0.0 1.0 1.0 mass
-6 108.0 328.0 0.0 0.0 1.0 1.0 mass
-7 126.0 328.0 0.0 0.0 1.0 1.0 mass
-8 144.0 328.0 0.0 0.0 1.0 1.0 mass
-9 162.0 328.0 0.0 0.0 1.0 1.0 mass
-10 180.0 328.0 0.0 0.0 1.0 1.0 mass
-11 198.0 328.0 0.0 0.0 1.0 1.0 mass
-12 216.0 328.0 0.0 0.0 1.0 1.0 mass
-13 234.0 328.0 0.0 0.0 1.0 1.0 mass
-14 252.0 328.0 0.0 0.0 1.0 1.0 mass
-15 270.0 328.0 0.0 0.0 1.0 1.0 mass
-16 288.0 328.0 0.0 0.0 1.0 1.0 mass
-17 306.0 328.0 0.0 0.0 1.0 1.0 mass
-18 324.0 328.0 0.0 0.0 1.0 1.0 mass
-19 342.0 328.0 0.0 0.0 1.0 1.0 mass
-20 360.0 328.0 0.0 0.0 1.0 1.0 mass
-21 378.0 328.0 0.0 0.0 1.0 1.0 mass
-22 396.0 328.0 0.0 0.0 1.0 1.0 mass
-23 414.0 328.0 0.0 0.0 1.0 1.0 mass
-24 432.0 328.0 0.0 0.0 1.0 1.0 mass
-25 450.0 328.0 0.0 0.0 1.0 1.0 mass
-26 468.0 328.0 0.0 0.0 1.0 1.0 mass
-27 504.0 328.0 0.0 0.0 1.0 1.0 mass
-28 486.0 328.0 0.0 0.0 1.0 1.0 mass
-29 522.0 328.0 0.0 0.0 1.0 1.0 mass
-30 540.0 328.0 0.0 0.0 1.0 1.0 mass
-31 558.0 328.0 0.0 0.0 1.0 1.0 mass
-32 576.0 328.0 0.0 0.0 1.0 1.0 mass
-33 594.0 328.0 0.0 0.0 1.0 1.0 mass
-34 612.0 328.0 0.0 0.0 1.0 1.0 mass
-35 626.0 328.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 19 20 200.0 1.500000 18.0 spng
-20 20 21 200.0 1.500000 18.0 spng
-21 21 22 200.0 1.500000 18.0 spng
-22 22 23 200.0 1.500000 18.0 spng
-23 23 24 200.0 1.500000 18.0 spng
-24 24 25 200.0 1.500000 18.0 spng
-25 25 26 200.0 1.500000 18.0 spng
-26 26 28 200.0 1.500000 18.0 spng
-27 28 27 200.0 1.500000 18.0 spng
-28 27 29 200.0 1.500000 18.0 spng
-29 29 30 200.0 1.500000 18.0 spng
-30 30 31 200.0 1.500000 18.0 spng
-31 31 32 200.0 1.500000 18.0 spng
-32 32 33 200.0 1.500000 18.0 spng
-33 33 34 200.0 1.500000 18.0 spng
-34 34 35 200.0 1.500000 18.0 spng
-35 1 3 200.0 1.500000 36.0 spng
-36 2 4 200.0 1.500000 36.0 spng
-37 3 5 200.0 1.500000 36.0 spng
-38 4 6 200.0 1.500000 36.0 spng
-39 5 7 200.0 1.500000 36.0 spng
-40 6 8 200.0 1.500000 36.0 spng
-41 7 9 200.0 1.500000 36.0 spng
-42 8 10 200.0 1.500000 36.0 spng
-43 9 11 200.0 1.500000 36.0 spng
-44 10 12 200.0 1.500000 36.0 spng
-45 11 13 200.0 1.500000 36.0 spng
-46 12 14 200.0 1.500000 36.0 spng
-47 13 15 200.0 1.500000 36.0 spng
-48 14 16 200.0 1.500000 36.0 spng
-49 15 17 200.0 1.500000 36.0 spng
-50 16 18 200.0 1.500000 36.0 spng
-51 17 19 200.0 1.500000 36.0 spng
-52 18 20 200.0 1.500000 36.0 spng
-53 19 21 200.0 1.500000 36.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 28 200.0 1.500000 36.0 spng
-60 26 27 200.0 1.500000 36.0 spng
-61 28 29 200.0 1.500000 36.0 spng
-62 27 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-68 1 4 200.0 1.500000 53.0 spng
-69 2 5 200.0 1.500000 54.0 spng
-70 3 6 200.0 1.500000 54.0 spng
-71 4 7 200.0 1.500000 54.0 spng
-72 5 8 200.0 1.500000 54.0 spng
-73 6 9 200.0 1.500000 54.0 spng
-74 7 10 200.0 1.500000 54.0 spng
-75 8 11 200.0 1.500000 54.0 spng
-76 9 12 200.0 1.500000 54.0 spng
-77 10 13 200.0 1.500000 54.0 spng
-78 11 14 200.0 1.500000 54.0 spng
-79 12 15 200.0 1.500000 54.0 spng
-80 13 16 200.0 1.500000 54.0 spng
-81 14 17 200.0 1.500000 54.0 spng
-82 15 18 200.0 1.500000 54.0 spng
-83 16 19 200.0 1.500000 54.0 spng
-84 17 20 200.0 1.500000 54.0 spng
-85 18 21 200.0 1.500000 54.0 spng
-86 19 22 200.0 1.500000 54.0 spng
-87 20 23 200.0 1.500000 54.0 spng
-88 21 24 200.0 1.500000 54.0 spng
-89 22 25 200.0 1.500000 54.0 spng
-90 23 26 200.0 1.500000 54.0 spng
-91 24 28 200.0 1.500000 54.0 spng
-92 25 27 200.0 1.500000 54.0 spng
-93 26 29 200.0 1.500000 54.0 spng
-94 28 30 200.0 1.500000 54.0 spng
-95 27 31 200.0 1.500000 54.0 spng
-96 29 32 200.0 1.500000 54.0 spng
-97 30 33 200.0 1.500000 54.0 spng
-98 31 34 200.0 1.500000 54.0 spng
-99 32 35 200.0 1.500000 50.0 spng
-
-10
-[
- -400 400 random-range -400 400 random-range 2array
- nodes> random
- set-node-vel
-]
-times
-
-;
-
-! : go* ( quot -- )
-! [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
-
-: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
-
-! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces sequences springies springies.ui ;
-
-IN: springies.models.ball
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.01 >time-slice
-gravity on
-
-1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass
-2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass
-3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass
-4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass
-5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass
-6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass
-7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass
-8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass
-9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass
-10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass
-11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass
-12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass
-13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass
-14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass
-15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass
-16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass
-17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass
-18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass
-19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass
-20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass
-21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass
-22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass
-23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass
-24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass
-25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass
-26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass
-27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass
-28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass
-29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass
-30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass
-31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass
-32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass
-33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass
-34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass
-35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass
-36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass
-37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass
-38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass
-39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass
-40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass
-41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass
-42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass
-43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass
-44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass
-45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass
-46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass
-47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass
-48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass
-1 1 2 150.0 2.0 14.0 spng
-2 2 3 150.0 2.0 14.0 spng
-3 3 4 150.0 2.0 14.0 spng
-4 4 5 150.0 2.0 14.0 spng
-5 5 6 150.0 2.0 14.0 spng
-6 6 7 150.0 2.0 14.0 spng
-7 7 8 150.0 2.0 14.0 spng
-8 8 9 150.0 2.0 14.0 spng
-9 9 10 150.0 2.0 14.0 spng
-10 10 11 150.0 2.0 14.0 spng
-11 11 12 150.0 2.0 14.0 spng
-12 12 1 150.0 2.0 14.0 spng
-13 13 14 150.0 2.0 28.0 spng
-14 14 15 150.0 2.0 28.0 spng
-15 15 16 150.0 2.0 28.0 spng
-16 16 17 150.0 2.0 28.0 spng
-17 17 18 150.0 2.0 28.0 spng
-18 18 19 150.0 2.0 28.0 spng
-19 19 20 150.0 2.0 28.0 spng
-20 20 21 150.0 2.0 28.0 spng
-21 21 22 150.0 2.0 28.0 spng
-22 22 23 150.0 2.0 28.0 spng
-23 23 24 150.0 2.0 28.0 spng
-24 24 13 150.0 2.0 28.0 spng
-25 25 26 150.0 2.0 44.0 spng
-26 26 27 150.0 2.0 43.0 spng
-27 27 28 150.0 2.0 44.0 spng
-28 28 29 150.0 2.0 44.0 spng
-29 29 30 150.0 2.0 43.0 spng
-30 30 31 150.0 2.0 44.0 spng
-31 31 32 150.0 2.0 43.0 spng
-32 32 33 150.0 2.0 43.0 spng
-33 33 34 150.0 2.0 44.0 spng
-34 34 35 150.0 2.0 44.0 spng
-35 35 36 150.0 2.0 43.0 spng
-36 36 25 150.0 2.0 44.0 spng
-37 37 38 150.0 2.0 58.0 spng
-38 38 39 150.0 2.0 59.0 spng
-39 39 40 150.0 2.0 58.0 spng
-40 40 41 150.0 2.0 58.0 spng
-41 41 42 150.0 2.0 59.0 spng
-42 42 43 150.0 2.0 58.0 spng
-43 43 44 150.0 2.0 58.0 spng
-44 44 45 150.0 2.0 59.0 spng
-45 45 46 150.0 2.0 58.0 spng
-46 46 47 150.0 2.0 58.0 spng
-47 47 48 150.0 2.0 59.0 spng
-48 48 37 150.0 2.0 58.0 spng
-49 1 13 150.0 2.0 29.0 spng
-50 2 14 150.0 2.0 28.0 spng
-51 3 15 150.0 2.0 28.0 spng
-52 4 16 150.0 2.0 29.0 spng
-53 5 17 150.0 2.0 28.0 spng
-54 6 18 150.0 2.0 28.0 spng
-55 7 19 150.0 2.0 29.0 spng
-56 8 20 150.0 2.0 28.0 spng
-57 9 21 150.0 2.0 28.0 spng
-58 10 22 150.0 2.0 29.0 spng
-59 11 23 150.0 2.0 28.0 spng
-60 12 24 150.0 2.0 28.0 spng
-61 13 25 150.0 2.0 29.0 spng
-62 14 26 150.0 2.0 28.0 spng
-63 15 27 150.0 2.0 28.0 spng
-64 16 28 150.0 2.0 29.0 spng
-65 17 29 150.0 2.0 28.0 spng
-66 18 30 150.0 2.0 28.0 spng
-67 19 31 150.0 2.0 29.0 spng
-68 20 32 150.0 2.0 28.0 spng
-69 21 33 150.0 2.0 28.0 spng
-70 22 34 150.0 2.0 29.0 spng
-71 23 35 150.0 2.0 28.0 spng
-72 24 36 150.0 2.0 28.0 spng
-73 25 37 150.0 2.0 29.0 spng
-74 26 38 150.0 2.0 28.0 spng
-75 27 39 150.0 2.0 28.0 spng
-76 28 40 150.0 2.0 29.0 spng
-77 29 41 150.0 2.0 28.0 spng
-78 30 42 150.0 2.0 28.0 spng
-79 31 43 150.0 2.0 29.0 spng
-80 32 44 150.0 2.0 28.0 spng
-81 33 45 150.0 2.0 28.0 spng
-82 34 46 150.0 2.0 29.0 spng
-83 35 47 150.0 2.0 28.0 spng
-84 36 48 150.0 2.0 28.0 spng
-85 1 14 150.0 2.0 35.0 spng
-86 2 15 150.0 2.0 35.0 spng
-87 3 16 150.0 2.0 34.0 spng
-88 4 17 150.0 2.0 35.0 spng
-89 5 18 150.0 2.0 35.0 spng
-90 6 19 150.0 2.0 34.0 spng
-91 7 20 150.0 2.0 35.0 spng
-92 8 21 150.0 2.0 35.0 spng
-93 9 22 150.0 2.0 34.0 spng
-94 10 23 150.0 2.0 35.0 spng
-95 11 24 150.0 2.0 35.0 spng
-96 12 13 150.0 2.0 34.0 spng
-97 13 26 150.0 2.0 46.0 spng
-98 14 27 150.0 2.0 45.0 spng
-99 15 28 150.0 2.0 45.0 spng
-100 16 29 150.0 2.0 46.0 spng
-101 17 30 150.0 2.0 45.0 spng
-102 18 31 150.0 2.0 45.0 spng
-103 19 32 150.0 2.0 45.0 spng
-104 20 33 150.0 2.0 45.0 spng
-105 21 34 150.0 2.0 45.0 spng
-106 22 35 150.0 2.0 46.0 spng
-107 23 36 150.0 2.0 45.0 spng
-108 24 25 150.0 2.0 45.0 spng
-109 25 38 150.0 2.0 58.0 spng
-110 26 39 150.0 2.0 58.0 spng
-111 27 40 150.0 2.0 58.0 spng
-112 28 41 150.0 2.0 58.0 spng
-113 29 42 150.0 2.0 58.0 spng
-114 30 43 150.0 2.0 58.0 spng
-115 31 44 150.0 2.0 58.0 spng
-116 32 45 150.0 2.0 58.0 spng
-117 33 46 150.0 2.0 58.0 spng
-118 34 47 150.0 2.0 58.0 spng
-119 35 48 150.0 2.0 58.0 spng
-120 36 37 150.0 2.0 58.0 spng
-121 1 24 150.0 2.0 35.0 spng
-122 2 13 150.0 2.0 34.0 spng
-123 3 14 150.0 2.0 35.0 spng
-124 4 15 150.0 2.0 35.0 spng
-125 5 16 150.0 2.0 34.0 spng
-126 6 17 150.0 2.0 35.0 spng
-127 7 18 150.0 2.0 35.0 spng
-128 8 19 150.0 2.0 34.0 spng
-129 9 20 150.0 2.0 35.0 spng
-130 10 21 150.0 2.0 35.0 spng
-131 11 22 150.0 2.0 34.0 spng
-132 12 23 150.0 2.0 35.0 spng
-133 13 36 150.0 2.0 46.0 spng
-134 14 25 150.0 2.0 45.0 spng
-135 15 26 150.0 2.0 45.0 spng
-136 16 27 150.0 2.0 46.0 spng
-137 17 28 150.0 2.0 45.0 spng
-138 18 29 150.0 2.0 45.0 spng
-139 19 30 150.0 2.0 46.0 spng
-140 20 31 150.0 2.0 45.0 spng
-141 21 32 150.0 2.0 45.0 spng
-142 22 33 150.0 2.0 46.0 spng
-143 23 34 150.0 2.0 45.0 spng
-144 24 35 150.0 2.0 45.0 spng
-145 25 48 150.0 2.0 58.0 spng
-146 26 37 150.0 2.0 58.0 spng
-147 27 38 150.0 2.0 58.0 spng
-148 28 39 150.0 2.0 58.0 spng
-149 29 40 150.0 2.0 58.0 spng
-150 30 41 150.0 2.0 58.0 spng
-151 31 42 150.0 2.0 58.0 spng
-152 32 43 150.0 2.0 58.0 spng
-153 33 44 150.0 2.0 58.0 spng
-154 34 45 150.0 2.0 58.0 spng
-155 35 46 150.0 2.0 58.0 spng
-156 36 47 150.0 2.0 58.0 spng
-157 10 4 150.0 2.0 52.331631 spng
-158 7 1 150.0 2.0 52.436772 spng
-159 12 6 150.0 2.0 54.680698 spng
-160 5 11 150.0 2.0 54.589379 spng
-161 9 3 150.0 2.0 54.451569 spng
-162 2 8 150.0 2.0 54.482231 spng
-163 45 11 150.0 2.0 101.408150 spng
-164 46 12 150.0 2.0 101.542452 spng
-165 47 1 150.0 2.0 101.963064 spng
-166 48 2 150.0 2.0 101.517329 spng
-167 37 3 150.0 2.0 101.603694 spng
-168 38 4 150.0 2.0 102.014031 spng
-169 39 5 150.0 2.0 101.547660 spng
-170 40 6 150.0 2.0 101.573762 spng
-171 41 7 150.0 2.0 101.897300 spng
-172 42 8 150.0 2.0 101.497982 spng
-173 43 9 150.0 2.0 101.870594 spng
-174 44 10 150.0 2.0 102.043753 spng
-175 45 11 150.0 2.0 101.408150 spng
-176 46 8 150.0 2.0 101.548938 spng
-177 47 10 150.0 2.0 90.645939 spng
-178 48 10 150.0 2.0 101.952119 spng
-179 37 11 150.0 2.0 101.552352 spng
-180 38 12 150.0 2.0 101.491447 spng
-181 39 1 150.0 2.0 101.971524 spng
-182 40 2 150.0 2.0 101.587400 spng
-183 41 3 150.0 2.0 101.519279 spng
-184 42 4 150.0 2.0 101.976181 spng
-185 43 5 150.0 2.0 101.714570 spng
-186 44 6 150.0 2.0 101.388747 spng
-187 45 7 150.0 2.0 101.773286 spng
-
-nodes> [ { 0 100 } swap set-node-vel ] each ;
-
-USING: threads ui ;
-
-: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math ui random
- springies springies.ui ;
-
-IN: springies.models.belt-tire
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.008 >time-slice
-gravity on
-
-1 274.078806900597328 346.307117178664043 0 0 1 0.5 mass
-2 284.142891110742823 329.83402842231834 0 0 1 0.5 mass
-3 295.307158356938658 355.695013578746227 0 0 1 0.5 mass
-4 300.698527801927128 337.003548930923216 0 0 1 0.5 mass
-5 318.093036910029696 359.203044347904552 0 0 1 0.5 mass
-6 318.542098798246286 339.592403450546044 0 0 1 0.5 mass
-7 340.949296214486822 356.831259237330983 0 0 1 0.5 mass
-8 336.494524828869885 337.754019325244656 0 0 1 0.5 mass
-9 362.534986907234952 348.770558940029559 0 0 1 0.5 mass
-10 353.491265306914897 331.642140359094469 0 0 1 0.5 mass
-11 381.368850422101502 335.37878701564847 0 0 1 0.5 mass
-12 368.085531061140216 321.055018811315335 0 0 1 0.5 mass
-13 396.117634938806759 317.519287773537314 0 0 1 0.5 mass
-14 379.675208211408915 307.277961968837246 0 0 1 0.5 mass
-15 405.655157991023771 296.391903048606025 0 0 1 0.5 mass
-16 387.124676448692242 290.862310093183567 0 0 1 0.5 mass
-17 409.337178964708642 273.594658653786666 0 0 1 0.5 mass
-18 389.76569804010461 273.012494879567555 0 0 1 0.5 mass
-19 407.11203230551871 250.712646124396059 0 0 1 0.5 mass
-20 387.966228461346304 255.061007930370067 0 0 1 0.5 mass
-21 399.188308328902735 229.098161823607285 0 0 1 0.5 mass
-22 381.896222954111181 238.073977723246998 0 0 1 0.5 mass
-23 385.883224011375262 210.148208473511374 0 0 1 0.5 mass
-24 371.614761646970464 223.279700317395225 0 0 1 0.5 mass
-25 367.955378160003875 195.334436550727929 0 0 1 0.5 mass
-26 357.817091674528911 211.717360072075536 0 0 1 0.5 mass
-27 346.743525482831387 185.884698478394085 0 0 1 0.5 mass
-28 341.291169697238729 204.55711005838188 0 0 1 0.5 mass
-29 323.935265230381788 182.330460182137188 0 0 1 0.5 mass
-30 323.466187791799882 201.937076877994031 0 0 1 0.5 mass
-31 301.04141769400843 184.703602685435726 0 0 1 0.5 mass
-32 305.532794735419941 203.763859300438838 0 0 1 0.5 mass
-33 279.442362700896183 192.851996602076866 0 0 1 0.5 mass
-34 288.551113492738239 209.893932668644339 0 0 1 0.5 mass
-35 260.65997798024199 206.334196608396638 0 0 1 0.5 mass
-36 273.960657978745814 220.516324161880476 0 0 1 0.5 mass
-37 246.029909853431349 224.197583023911335 0 0 1 0.5 mass
-38 262.719165304227545 234.58428660123181 0 0 1 0.5 mass
-39 236.458142984593252 245.235572499606377 0 0 1 0.5 mass
-40 254.870454491934908 250.81914136861181 0 0 1 0.5 mass
-41 232.703447579492519 268.042376651164432 0 0 1 0.5 mass
-42 252.226120754560156 268.679895159358864 0 0 1 0.5 mass
-43 234.96767702938331 291.007702051922024 0 0 1 0.5 mass
-44 254.040589506795527 286.621843971355872 0 0 1 0.5 mass
-45 242.759412026738119 312.577114225657738 0 0 1 0.5 mass
-46 260.111088599530603 303.593264087352964 0 0 1 0.5 mass
-47 256.101782779606651 331.52509923420655 0 0 1 0.5 mass
-48 270.373388641766439 318.366074596339615 0 0 1 0.5 mass
-49 320.448537383965288 270.292364746678743 0 0 10 0.5 mass
-1 1 4 200 2 28.284271247461902 spng
-2 4 5 200 2 28.284271247461902 spng
-3 5 8 200 2 28.284271247461902 spng
-4 8 9 200 2 28.284271247461902 spng
-5 9 12 200 2 28.284271247461902 spng
-6 12 13 200 2 28.284271247461902 spng
-7 13 16 200 2 28.284271247461902 spng
-8 16 17 200 2 28.284271247461902 spng
-9 17 20 200 2 28.284271247461902 spng
-10 20 21 200 2 28.284271247461902 spng
-11 21 24 200 2 28.284271247461902 spng
-12 24 25 200 2 28.284271247461902 spng
-13 25 28 200 2 28.284271247461902 spng
-14 28 29 200 2 28.284271247461902 spng
-15 29 32 200 2 28.284271247461902 spng
-16 32 33 200 2 28.284271247461902 spng
-17 33 36 200 2 28.284271247461902 spng
-18 36 37 200 2 28.284271247461902 spng
-19 37 40 200 2 28.284271247461902 spng
-20 40 41 200 2 28.284271247461902 spng
-21 41 44 200 2 28.284271247461902 spng
-22 44 45 200 2 28.284271247461902 spng
-23 45 48 200 2 28.284271247461902 spng
-24 3 6 200 2 28.284271247461902 spng
-25 7 10 200 2 28.284271247461902 spng
-26 11 14 200 2 28.284271247461902 spng
-27 15 18 200 2 28.284271247461902 spng
-28 19 22 200 2 28.284271247461902 spng
-29 23 26 200 2 28.284271247461902 spng
-30 27 30 200 2 28.284271247461902 spng
-31 31 34 200 2 28.284271247461902 spng
-32 35 38 200 2 28.284271247461902 spng
-33 39 44 200 2 44.7213595499957961 spng
-34 39 42 200 2 28.284271247461902 spng
-35 43 46 200 2 28.284271247461902 spng
-36 47 46 200 2 28.284271247461902 spng
-37 43 42 200 2 28.284271247461902 spng
-38 39 38 200 2 28.284271247461902 spng
-39 35 34 200 2 28.284271247461902 spng
-40 2 3 200 2 28.284271247461902 spng
-41 6 7 200 2 28.284271247461902 spng
-42 10 11 200 2 28.284271247461902 spng
-43 14 15 200 2 28.284271247461902 spng
-44 18 19 200 2 28.284271247461902 spng
-45 22 23 200 2 28.284271247461902 spng
-46 26 27 200 2 28.284271247461902 spng
-47 30 31 200 2 28.284271247461902 spng
-48 1 6 200 2 44.7213595499957961 spng
-49 3 8 200 2 44.7213595499957961 spng
-50 5 10 200 2 44.7213595499957961 spng
-51 7 12 200 2 44.7213595499957961 spng
-52 9 14 200 2 44.7213595499957961 spng
-53 11 16 200 2 44.7213595499957961 spng
-54 13 18 200 2 44.7213595499957961 spng
-55 15 20 200 2 44.7213595499957961 spng
-56 17 22 200 2 44.7213595499957961 spng
-57 19 24 200 2 44.7213595499957961 spng
-58 21 26 200 2 44.7213595499957961 spng
-59 23 28 200 2 44.7213595499957961 spng
-60 25 30 200 2 44.7213595499957961 spng
-61 27 32 200 2 44.7213595499957961 spng
-62 29 34 200 2 44.7213595499957961 spng
-63 31 36 200 2 44.7213595499957961 spng
-64 33 38 200 2 44.7213595499957961 spng
-65 35 40 200 2 44.7213595499957961 spng
-66 37 42 200 2 44.7213595499957961 spng
-67 41 46 200 2 44.7213595499957961 spng
-68 43 48 200 2 44.7213595499957961 spng
-69 2 5 200 2 44.7213595499957961 spng
-70 4 7 200 2 44.7213595499957961 spng
-71 6 9 200 2 44.7213595499957961 spng
-72 8 11 200 2 44.7213595499957961 spng
-73 10 13 200 2 44.7213595499957961 spng
-74 12 15 200 2 44.7213595499957961 spng
-75 14 17 200 2 44.7213595499957961 spng
-76 16 19 200 2 44.7213595499957961 spng
-77 18 21 200 2 44.7213595499957961 spng
-78 20 23 200 2 44.7213595499957961 spng
-79 22 25 200 2 44.7213595499957961 spng
-80 24 27 200 2 44.7213595499957961 spng
-81 26 29 200 2 44.7213595499957961 spng
-82 28 31 200 2 44.7213595499957961 spng
-83 30 33 200 2 44.7213595499957961 spng
-84 32 35 200 2 44.7213595499957961 spng
-85 34 37 200 2 44.7213595499957961 spng
-86 36 39 200 2 44.7213595499957961 spng
-87 38 41 200 2 44.7213595499957961 spng
-88 40 43 200 2 44.7213595499957961 spng
-89 42 45 200 2 44.7213595499957961 spng
-90 44 47 200 2 44.7213595499957961 spng
-91 1 8 200 2 63.2455532033675851 spng
-92 3 10 200 2 63.2455532033675851 spng
-93 5 12 200 2 63.2455532033675851 spng
-94 7 14 200 2 63.2455532033675851 spng
-95 9 16 200 2 63.2455532033675851 spng
-96 11 18 200 2 63.2455532033675851 spng
-97 13 20 200 2 63.2455532033675851 spng
-98 15 22 200 2 63.2455532033675851 spng
-99 17 24 200 2 63.2455532033675851 spng
-100 19 26 200 2 63.2455532033675851 spng
-101 21 28 200 2 63.2455532033675851 spng
-102 23 30 200 2 63.2455532033675851 spng
-103 25 32 200 2 63.2455532033675851 spng
-104 27 34 200 2 63.2455532033675851 spng
-105 29 36 200 2 63.2455532033675851 spng
-106 31 38 200 2 63.2455532033675851 spng
-107 33 40 200 2 63.2455532033675851 spng
-108 35 42 200 2 63.2455532033675851 spng
-109 37 44 200 2 63.2455532033675851 spng
-110 39 46 200 2 63.2455532033675851 spng
-111 48 41 200 2 63.2455532033675851 spng
-112 2 7 200 2 63.2455532033675851 spng
-113 4 9 200 2 63.2455532033675851 spng
-114 6 11 200 2 63.2455532033675851 spng
-115 8 13 200 2 63.2455532033675851 spng
-116 10 15 200 2 63.2455532033675851 spng
-117 12 17 200 2 63.2455532033675851 spng
-118 14 19 200 2 63.2455532033675851 spng
-119 16 21 200 2 63.2455532033675851 spng
-120 18 23 200 2 63.2455532033675851 spng
-121 20 25 200 2 63.2455532033675851 spng
-122 22 27 200 2 63.2455532033675851 spng
-123 24 29 200 2 63.2455532033675851 spng
-124 26 31 200 2 63.2455532033675851 spng
-125 28 33 200 2 63.2455532033675851 spng
-126 30 35 200 2 63.2455532033675851 spng
-127 32 37 200 2 63.2455532033675851 spng
-128 34 39 200 2 63.2455532033675851 spng
-129 36 41 200 2 63.2455532033675851 spng
-130 38 43 200 2 63.2455532033675851 spng
-131 40 45 200 2 63.2455532033675851 spng
-132 42 47 200 2 63.2455532033675851 spng
-133 1 3 200 2 20 spng
-134 3 5 200 2 20 spng
-135 5 7 200 2 20 spng
-136 7 9 200 2 20 spng
-137 9 11 200 2 20 spng
-138 11 13 200 2 20 spng
-139 13 15 200 2 20 spng
-140 15 17 200 2 20 spng
-141 17 19 200 2 20 spng
-142 19 21 200 2 20 spng
-143 21 23 200 2 20 spng
-144 23 25 200 2 20 spng
-145 25 27 200 2 20 spng
-146 27 29 200 2 20 spng
-147 29 31 200 2 20 spng
-148 31 33 200 2 20 spng
-149 33 35 200 2 20 spng
-150 35 37 200 2 20 spng
-151 37 39 200 2 20 spng
-152 39 41 200 2 20 spng
-153 41 43 200 2 20 spng
-154 43 45 200 2 20 spng
-155 45 47 200 2 20 spng
-156 2 4 200 2 20 spng
-157 4 6 200 2 20 spng
-158 6 8 200 2 20 spng
-159 8 10 200 2 20 spng
-160 10 12 200 2 20 spng
-161 12 14 200 2 20 spng
-162 14 16 200 2 20 spng
-163 16 18 200 2 20 spng
-164 18 20 200 2 20 spng
-165 20 22 200 2 20 spng
-166 22 24 200 2 20 spng
-167 24 26 200 2 20 spng
-168 26 28 200 2 20 spng
-169 28 30 200 2 20 spng
-170 30 32 200 2 20 spng
-171 32 34 200 2 20 spng
-172 34 36 200 2 20 spng
-173 36 38 200 2 20 spng
-174 38 40 200 2 20 spng
-175 40 42 200 2 20 spng
-176 42 44 200 2 20 spng
-177 44 46 200 2 20 spng
-178 46 48 200 2 20 spng
-179 1 2 200 2 20 spng
-180 3 4 200 2 20 spng
-181 5 6 200 2 20 spng
-182 7 8 200 2 20 spng
-183 9 10 200 2 20 spng
-184 11 12 200 2 20 spng
-185 13 14 200 2 20 spng
-186 15 16 200 2 20 spng
-187 17 18 200 2 20 spng
-188 19 20 200 2 20 spng
-189 21 22 200 2 20 spng
-190 23 24 200 2 20 spng
-191 25 26 200 2 20 spng
-192 27 28 200 2 20 spng
-193 29 30 200 2 20 spng
-194 31 32 200 2 20 spng
-195 33 34 200 2 20 spng
-196 35 36 200 2 20 spng
-197 37 38 200 2 20 spng
-198 39 40 200 2 20 spng
-199 41 42 200 2 20 spng
-200 43 44 200 2 20 spng
-201 45 46 200 2 20 spng
-202 47 48 200 2 20 spng
-203 47 2 200 2 28.284271247461902 spng
-204 1 48 200 2 28.284271247461902 spng
-205 1 46 200 2 44.7213595499957961 spng
-206 1 44 200 2 63.2455532033675851 spng
-207 47 4 200 2 44.7213595499957961 spng
-208 48 3 200 2 44.7213595499957961 spng
-209 47 6 200 2 63.2455532033675851 spng
-210 48 5 200 2 63.2455532033675851 spng
-211 46 3 200 2 63.2455532033675851 spng
-212 45 4 200 2 63.2455532033675851 spng
-213 47 1 200 2 20 spng
-214 48 2 200 2 20 spng
-215 18 49 300 3 69.2603782836911677 spng
-216 49 20 300 3 69.050706006528273 spng
-217 22 49 300 3 69.3541635375988079 spng
-218 49 24 300 3 69.5269731830747872 spng
-219 26 49 300 3 69.6347614342147381 spng
-220 49 28 300 3 68.9492567037527948 spng
-221 30 49 300 3 68.2641926635040477 spng
-222 49 32 300 3 68.0661443009665419 spng
-223 34 49 300 3 68.4470598345904051 spng
-224 49 36 300 3 68.1175454637056106 spng
-225 38 49 300 3 67.6756972627545252 spng
-226 49 40 300 3 68.6221538571910514 spng
-227 42 49 300 3 68.1835757349231386 spng
-228 49 44 300 3 68.249542123006222 spng
-229 46 49 300 3 68.8767014308902503 spng
-230 49 48 300 3 69.4262198308391305 spng
-231 2 49 300 3 69.8927750200262068 spng
-232 49 4 300 3 69.5701085237043486 spng
-233 6 49 300 3 69.1809222257119103 spng
-234 8 49 300 3 69.2314957226839027 spng
-235 49 10 300 3 69.7782200976780445 spng
-236 12 49 300 3 69.5269731830747872 spng
-237 49 14 300 3 69.8927750200262068 spng
-238 16 49 300 3 69.8927750200262068 spng
-
-
-nodes> 200 random -100 + 100 2array [ swap set-node-vel ] curry each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 2 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { "bundle-name" "Belt Tire.app" }
-}
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random springies springies.ui ;
-
-IN: springies.models.nifty
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.007 >time-slice
-gravity off
-
-1 148.581450999999987 350.573888000000011 0 -7.75 1 0.1 mass
-2 168.564277000000004 351.402524000000028 0 -7.75 1 0.1 mass
-3 188.54710399999999 352.231158999999991 0 -7.75 1 0.1 mass
-4 208.529931000000005 353.059794000000011 0 -7.75 1 0.1 mass
-5 228.512757999999991 353.888428999999974 0 -7.75 1 0.1 mass
-6 248.495584000000008 354.717063999999993 0 -7.75 1 0.1 mass
-7 149.410086000000007 330.591061000000025 0 -7.75 1 0.1 mass
-8 150.238720999999998 310.608234999999979 0 -7.75 1 0.1 mass
-9 151.06735599999999 290.625407999999993 0 -7.75 1 0.1 mass
-10 151.895991000000009 270.642581000000007 0 -7.75 1 0.1 mass
-11 152.724626000000001 250.65975499999999 0 -7.75 1 0.1 mass
-12 172.707452999999987 251.48839000000001 0 -7.749999 1 0.1 mass
-13 192.690280000000001 252.317025000000001 0 -7.75 1 0.1 mass
-14 212.67310599999999 253.145659999999992 0 -7.75 1 0.1 mass
-15 232.655933000000005 253.974295000000012 0 -7.75 1 0.1 mass
-16 252.638759999999991 254.802930000000003 0 -7.75 1 0.1 mass
-17 251.810124999999999 274.78575699999999 0 -7.75 1 0.1 mass
-18 250.98148900000001 294.768583999999976 0 -7.75 1 0.1 mass
-19 249.324218999999999 334.734237000000007 0 -7.75 1 0.1 mass
-20 250.152853999999991 314.751410000000021 0 -7.75 1 0.1 mass
-1 1 2 200 1.5 20 spng
-2 2 3 200 1.5 20 spng
-3 3 4 200 1.5 20 spng
-4 4 5 200 1.5 20 spng
-5 5 6 200 1.5 20 spng
-6 6 19 200 1.5 20 spng
-7 19 20 200 1.5 20 spng
-8 20 18 200 1.5 20 spng
-9 18 17 200 1.5 20 spng
-10 17 16 200 1.5 20 spng
-11 16 15 200 1.5 20 spng
-12 15 14 200 1.5 20 spng
-13 14 13 200 1.5 20 spng
-14 13 12 200 1.5 20 spng
-15 12 11 200 1.5 20 spng
-16 11 10 200 1.5 20 spng
-17 10 9 200 1.5 20 spng
-18 9 8 200 1.5 20 spng
-19 8 7 200 1.5 20 spng
-20 7 1 200 1.5 20 spng
-21 1 19 200 1.5 101.98039 spng
-22 19 14 200 1.5 89.4427189999999968 spng
-23 14 8 200 1.5 84.8528139999999951 spng
-24 8 5 200 1.5 89.4427189999999968 spng
-25 5 16 200 1.5 101.98039 spng
-26 16 10 200 1.5 101.98039 spng
-27 10 3 200 1.5 89.4427189999999968 spng
-28 3 18 200 1.5 84.8528139999999951 spng
-29 18 12 200 1.5 89.4427189999999968 spng
-30 12 1 200 1.5 101.98039 spng
-31 2 20 200 1.5 89.4427189999999968 spng
-32 20 13 200 1.5 84.8528139999999951 spng
-33 13 7 200 1.5 89.4427189999999968 spng
-34 7 6 200 1.5 101.98039 spng
-35 6 15 200 1.5 101.98039 spng
-36 15 9 200 1.5 89.4427189999999968 spng
-37 9 4 200 1.5 84.8528139999999951 spng
-38 4 17 200 1.5 89.4427189999999968 spng
-39 17 11 200 1.5 101.98039 spng
-40 11 2 200 1.5 101.98039 spng
-
-nodes> 200 random -100 + 200 random -100 + 2array [ swap set-node-vel ] curry
-each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random
- springies springies.ui ;
-
-IN: springies.models.urchin
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.007 >time-slice
-gravity on
-
-1 507.296953 392.174236 -11.451186 -71.267273 1.0 1.0 mass
-2 514.879820 372.128025 11.950035 -70.858717 1.0 1.0 mass
-3 536.571268 364.423706 18.394466 -41.159445 1.0 1.0 mass
-4 554.886966 369.953895 15.173664 -11.009243 1.0 1.0 mass
-5 572.432935 379.927626 8.228103 -1.120846 1.0 1.0 mass
-6 585.774508 392.380791 5.443281 -8.186599 1.0 1.0 mass
-7 584.650543 411.934530 -15.582843 -24.911756 1.0 1.0 mass
-8 569.409148 424.155713 -24.100159 -42.285960 1.0 1.0 mass
-9 553.751996 434.663690 -26.069217 -41.610454 1.0 1.0 mass
-10 536.684374 444.915694 -30.702349 -45.021926 1.0 1.0 mass
-11 516.677286 435.936238 -33.128410 -60.977340 1.0 1.0 mass
-12 514.170680 414.649472 -24.471518 -64.104425 1.0 1.0 mass
-13 602.101547 478.298945 1.612646 -53.040881 1.0 1.0 mass
-14 637.0 427.598266 0.0 0.0 1.0 1.0 mass
-15 608.000171 350.425575 31.812856 23.456940 1.0 1.0 mass
-16 484.367809 332.414622 42.575378 -91.238351 1.0 1.0 mass
-17 480.857379 475.215663 -24.240991 -53.909049 1.0 1.0 mass
-18 548.580015 492.173168 -34.565312 -52.436468 1.0 1.0 mass
-19 578.155338 487.173526 22.544495 -71.920721 1.0 1.0 mass
-20 630.992588 379.333707 16.662115 37.873709 1.0 1.0 mass
-21 591.256916 324.817423 63.036114 27.988433 1.0 1.0 mass
-22 539.051461 311.597938 159.501014 -27.955219 1.0 1.0 mass
-23 448.396171 396.882674 -15.045910 -138.652372 1.0 1.0 mass
-24 448.194414 419.993896 -27.625008 -84.936708 1.0 1.0 mass
-1 1 2 200.0 3.0 20.0 spng
-2 2 3 200.0 3.0 20.0 spng
-3 3 4 200.0 3.0 20.0 spng
-4 4 5 200.0 3.0 20.0 spng
-5 5 6 200.0 3.0 20.0 spng
-6 6 7 200.0 3.0 20.0 spng
-7 7 8 200.0 3.0 20.0 spng
-8 8 9 200.0 3.0 20.0 spng
-9 9 10 200.0 3.0 20.0 spng
-10 10 11 200.0 3.0 20.0 spng
-11 11 12 200.0 3.0 20.0 spng
-12 1 3 200.0 3.0 40.0 spng
-13 2 4 200.0 3.0 40.0 spng
-14 3 5 200.0 3.0 40.0 spng
-15 4 6 200.0 3.0 40.0 spng
-16 6 8 200.0 3.0 40.0 spng
-17 7 9 200.0 3.0 40.0 spng
-18 8 10 200.0 3.0 40.0 spng
-19 9 11 200.0 3.0 40.0 spng
-20 10 12 200.0 3.0 40.0 spng
-21 12 1 200.0 3.0 21.0 spng
-22 12 2 200.0 3.0 41.0 spng
-23 11 1 200.0 3.0 41.0 spng
-24 6 12 200.0 3.0 72.681733 spng
-25 5 11 200.0 3.0 81.191259 spng
-26 10 4 200.0 3.0 76.026311 spng
-27 3 9 200.0 3.0 72.615425 spng
-28 8 2 200.0 3.0 74.966659 spng
-29 1 7 200.0 3.0 80.280757 spng
-30 17 11 200.0 3.0 55.036352 spng
-31 10 18 200.0 3.0 49.819675 spng
-32 19 9 200.0 3.0 54.918121 spng
-33 8 13 200.0 3.0 62.201286 spng
-34 14 7 200.0 3.0 58.600341 spng
-35 6 20 200.0 3.0 46.400431 spng
-36 15 5 200.0 3.0 44.045431 spng
-37 4 21 200.0 3.0 57.454330 spng
-38 22 3 200.0 3.0 53.823787 spng
-39 2 16 200.0 3.0 51.039201 spng
-40 23 1 200.0 3.0 58.668561 spng
-41 12 24 200.0 3.0 64.404969 spng
-42 24 11 200.0 3.0 71.217975 spng
-43 17 12 200.0 3.0 65.0 spng
-44 11 18 200.0 3.0 60.745370 spng
-45 18 9 200.0 3.0 60.406953 spng
-46 9 13 200.0 3.0 67.779053 spng
-47 13 7 200.0 3.0 66.708320 spng
-48 7 20 200.0 3.0 55.659680 spng
-49 20 5 200.0 3.0 60.0 spng
-50 5 21 200.0 3.0 61.846584 spng
-51 21 3 200.0 3.0 64.031242 spng
-52 3 16 200.0 3.0 63.568860 spng
-53 16 1 200.0 3.0 59.774577 spng
-54 1 24 200.0 3.0 65.802736 spng
-55 17 10 200.0 3.0 64.845971 spng
-56 10 19 200.0 3.0 58.249464 spng
-57 19 8 200.0 3.0 67.268120 spng
-58 8 14 200.0 3.0 67.268120 spng
-59 14 6 200.0 3.0 64.629715 spng
-60 6 15 200.0 3.0 50.089919 spng
-61 15 4 200.0 3.0 56.320511 spng
-62 4 22 200.0 3.0 60.728906 spng
-63 22 2 200.0 3.0 61.032778 spng
-64 2 23 200.0 3.0 66.528190 spng
-65 23 12 200.0 3.0 72.277244 spng
-
-nodes>
- 75 random -75 + 0 2array [ over node-vel v+ swap set-node-vel ]
-curry each
-
-;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-
-USING: kernel combinators sequences arrays math math.vectors
- generalizations vars accessors math.physics.vel ;
-
-IN: springies
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ;
-
-: vector-projection ( a b -- vec )
- [ nip normalize ] [ scalar-projection ] 2bi v*n ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: nodes
-VAR: springs
-VAR: time-slice
-VAR: world-size
-
-: world-width ( -- width ) world-size> first ;
-
-: world-height ( -- height ) world-size> second ;
-
-VAR: gravity
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! node
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: node < vel mass elas force ;
-
-C: <node> node
-
-: node-vel ( node -- vel ) vel>> ;
-
-: set-node-vel ( vel node -- ) swap >>vel drop ;
-
-: pos-x ( node -- x ) pos>> first ;
-: pos-y ( node -- y ) pos>> second ;
-: vel-x ( node -- y ) vel>> first ;
-: vel-y ( node -- y ) vel>> second ;
-
-: >>pos-x ( node x -- node ) over pos>> set-first ;
-: >>pos-y ( node y -- node ) over pos>> set-second ;
-: >>vel-x ( node x -- node ) over vel>> set-first ;
-: >>vel-y ( node y -- node ) over vel>> set-second ;
-
-: apply-force ( node vec -- ) over force>> v+ >>force drop ;
-
-: reset-force ( node -- node ) 0 0 2array >>force ;
-
-: node-id ( id -- node ) 1- nodes> nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! spring
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: spring rest-length k damp node-a node-b ;
-
-C: <spring> spring
-
-: end-points ( spring -- b-pos a-pos )
- [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
-
-: spring-length ( spring -- length ) end-points v- norm ;
-
-: stretch-length ( spring -- length )
- [ spring-length ] [ rest-length>> ] bi - ;
-
-: dir ( spring -- vec ) end-points v- normalize ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Hooke
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! F = -kx
-!
-! k :: spring constant
-! x :: distance stretched beyond rest length
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
-
-: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
-
-: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
-
-: act-on-nodes-hooke ( spring -- )
- [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
- apply-force
- apply-force ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! damping
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! F = -bv
-!
-! b :: Damping constant
-! v :: Velocity
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : damping-force-a ( spring -- vec )
-! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ;
-
-! : damping-force-b ( spring -- vec )
-! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-velocity-a ( spring -- vel )
- [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
-
-: unit-vec-b->a ( spring -- vec )
- [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
-
-: relative-velocity-along-spring-a ( spring -- vel )
- [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
-
-: damping-force-a ( spring -- vec )
- [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-velocity-b ( spring -- vel )
- [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
-
-: unit-vec-a->b ( spring -- vec )
- [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
-
-: relative-velocity-along-spring-b ( spring -- vel )
- [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
-
-: damping-force-b ( spring -- vec )
- [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: act-on-nodes-damping ( spring -- )
- dup
- [ node-a>> ] [ damping-force-a ] bi apply-force
- [ node-b>> ] [ damping-force-b ] bi apply-force ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: below? ( node -- ? ) pos-y 0 < ;
-
-: above? ( node -- ? ) pos-y world-height >= ;
-
-: beyond-left? ( node -- ? ) pos-x 0 < ;
-
-: beyond-right? ( node -- ? ) pos-x world-width >= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounce-top ( node -- )
- world-height 1- >>pos-y
- dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
- drop ;
-
-: bounce-bottom ( node -- )
- 0 >>pos-y
- dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
- drop ;
-
-: bounce-left ( node -- )
- 0 >>pos-x
- dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
- drop ;
-
-: bounce-right ( node -- )
- world-width 1- >>pos-x
- dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: handle-bounce ( node -- )
- { { [ dup above? ] [ bounce-top ] }
- { [ dup below? ] [ bounce-bottom ] }
- { [ dup beyond-left? ] [ bounce-left ] }
- { [ dup beyond-right? ] [ bounce-right ] }
- { [ t ] [ drop ] } }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: act-on-nodes ( spring -- )
- dup
- act-on-nodes-hooke
- act-on-nodes-damping ;
-
-! : act-on-nodes ( spring -- ) act-on-nodes-hooke ;
-
-: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-gravity ( node -- ) { 0 -9.8 } apply-force ;
-
-: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! F = ma
-
-: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
-
-: new-vel ( node -- vel )
- [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
-
-: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
-
-: iterate-node ( node -- )
- dup new-pos >>pos
- dup new-vel >>vel
- reset-force
- handle-bounce ;
-
-: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Reading xspringies data files
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mass ( id x y x-vel y-vel mass elas -- )
- node new
- swap >>elas
- swap >>mass
- -rot 2array >>vel
- -rot 2array >>pos
- 0 0 2array >>force
- nodes> swap suffix >nodes
- drop ;
-
-: spng ( id id-a id-b k damp rest-length -- )
- spring new
- swap >>rest-length
- swap >>damp
- swap >>k
- swap node-id >>node-b
- swap node-id >>node-a
- springs> swap suffix >springs
- drop ;
\ No newline at end of file
+++ /dev/null
-Mass and spring simulation (inspired by xspringies)
+++ /dev/null
-simulation
-physics
-demos
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces threads sequences math math.vectors
- opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
- fry rewrite-closures vars springies accessors math.geometry.rect ;
-
-IN: springies.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
-
-: draw-spring ( spring -- )
- [ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
-
-: draw-nodes ( -- ) nodes> [ draw-node ] each ;
-
-: draw-springs ( -- ) springs> [ draw-spring ] each ;
-
-: set-projection ( -- )
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- 0 world-width 1- 0 world-height 1- -1 1 glOrtho
- GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
-
-! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-
-: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-VAR: loop
-
-: update-world-size ( -- ) slate> rect-dim >world-size ;
-
-: refresh-slate ( -- ) slate> relayout-1 ;
-
-DEFER: maybe-loop
-
-: run ( -- )
- update-world-size
- iterate-system
- refresh-slate
- yield
- maybe-loop ;
-
-: maybe-loop ( -- ) loop> [ run ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: springies-window* ( -- )
-
- C[ display ] <slate>
- { 800 600 } >>pdim
- C[ { 500 500 } >world-size loop on [ run ] in-thread ] >>graft
- C[ loop off ] >>ungraft
- [ >slate ] [ "Springies" open-window ] bi ;
-
-: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
+++ /dev/null
-
-USING: kernel lexer parser words quotations compiler.units ;
-
-IN: sto
-
-! Use 'sto' to bind a value on the stack to a word.
-!
-! Example:
-!
-! 10 sto A
-
-: sto
- \ 1quotation parsed
- scan
- current-vocab create
- dup set-word
- literalize parsed
- \ swap parsed
- [ define ] parsed
- \ with-compilation-unit parsed ; parsing
-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
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ;
+USING: accessors arrays combinators kernel math math.vectors
+namespaces opengl opengl.gl sequences tetris.board tetris.game
+tetris.piece ui.render tetris.tetromino ui.gadgets colors ;
IN: tetris.gl
#! OpenGL rendering for tetris
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
- clone 0.2 >>alpha gl-color draw-piece-blocks ;
+ >rgba-components drop 0.2 <rgba> gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
: 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
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays namespaces sequences math math.order
-math.vectors colors random ;
+math.vectors colors colors.constants random ;
IN: tetris.tetromino
TUPLE: tetromino states colour ;
{ 0 2 }
{ 0 3 }
}
- } cyan
+ } COLOR: cyan
] [
{
{ { 1 0 }
{ 0 1 } { 1 1 }
{ 1 2 }
}
- } purple
+ } COLOR: purple
] [
{ { { 0 0 } { 1 0 }
{ 0 1 } { 1 1 } }
- } yellow
+ } COLOR: yellow
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
{ 0 1 }
{ 0 2 } { 1 2 }
}
- } orange
+ } COLOR: orange
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
{ 0 1 }
{ 0 2 }
}
- } blue
+ } COLOR: blue
] [
{
{ { 1 0 } { 2 0 }
{ 0 1 } { 1 1 }
{ 1 2 }
}
- } green
+ } COLOR: green
] [
{
{
{ 0 1 } { 1 1 }
{ 0 2 }
}
- } red
+ } COLOR: red
]
-} [ call <tetromino> ] map tetrominoes set-global
+} [ first2 <tetromino> ] map tetrominoes set-global
: random-tetromino ( -- tetromino )
tetrominoes get random ;
+++ /dev/null
-
-USING: kernel accessors locals namespaces sequences threads
- math math.order math.vectors
- calendar
- colors opengl ui ui.gadgets ui.gestures ui.render
- circular
- processing.shapes ;
-
-IN: trails
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Example 33-15 from the Processing book
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Return the mouse location relative to the current gadget
-
-: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point-list ( n -- seq ) [ drop { 0 0 } ] map <circular> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
-
-: dot ( pos percent -- ) percent->radius circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <trails-gadget> < gadget paused points ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- ! Add a valid point if the mouse is in the gadget
- ! Otherwise, add an "invisible" point
-
- hand-gadget get GADGET =
- [ mouse GADGET points>> push-circular ]
- [ { -10 -10 } GADGET points>> push-circular ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-trails-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: <trails-gadget> pref-dim* ( <trails-gadget> -- dim ) drop { 500 500 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- [
- dup length
- dup [ / ] curry
- [ 1+ ] prepose
- ] dip compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <trails-gadget> draw-gadget* ( GADGET -- )
- origin get
- [
- T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
- T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
-
- black gl-clear
-
- GADGET points>> [ dot ] each-percent
- ]
- with-translation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: trails-gadget ( -- <trails-gadget> )
-
- <trails-gadget> new-gadget
-
- 300 point-list >>points
-
- t >>clipped?
-
- dup start-trails-thread ;
-
-: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: trails-window
\ No newline at end of file
+++ /dev/null
-
-USING: kernel combinators sequences opengl.gl
- ui.render ui.gadgets ui.gadgets.slate
- accessors ;
-
-IN: ui.gadgets.cartesian
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
-
-: init-cartesian ( cartesian -- cartesian )
- init-slate
- -10 >>x-min
- 10 >>x-max
- -10 >>y-min
- 10 >>y-max
- -1 >>z-min
- 1 >>z-max ;
-
-: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: cartesian establish-coordinate-system ( cartesian -- cartesian )
- dup
- {
- [ x-min>> ] [ x-max>> ]
- [ y-min>> ] [ y-max>> ]
- [ z-min>> ] [ z-max>> ]
- }
- cleave
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
-: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
-: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /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
-ui.gadgets.theme ;
+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 ;
selection-color >>color ; inline
: <list> ( hook presenter model -- gadget )
- list new-gadget
+ list new
{ 0 1 } >>orientation
1 >>fill
0 >>index
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 )
- init-gadget
- [ ] >>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 math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.product combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( n name model toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ _ _ add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ names>> length 1 - swap ]\r
- [ model>> ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: new-tabbed ( assoc class -- tabbed )\r
- new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
-: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
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 ;
<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">
(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))))
--- /dev/null
+
+USING: accessors arrays assocs calendar colors
+combinators.short-circuit help.markup help.syntax kernel locals
+math math.functions math.matrices math.order math.parser
+math.trig math.vectors opengl opengl.demo-support opengl.gl
+sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render ui.tools.workspace ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: L-system
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
+
+DEFER: default-L-parser-values
+
+: reset-turtle ( turtle -- turtle )
+ { 0 0 0 } clone >>pos
+ 3 identity-matrix >>ori
+ V{ } clone >>vertices
+ V{ } clone >>saved
+
+ default-L-parser-values ;
+
+: turtle ( -- turtle ) <turtle> new reset-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: step-turtle ( TURTLE LENGTH -- turtle )
+
+ TURTLE
+ TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: Rx ( ANGLE -- Rx )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { 1 0 0 }
+ { 0 A B }
+ { 0 C D } }
+
+ ] ] ;
+
+:: Ry ( ANGLE -- Ry )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin ]
+ C [ ANGLE sin neg ]
+ D [ ANGLE cos ] |
+
+ { { A 0 B }
+ { 0 1 0 }
+ { C 0 D } }
+
+ ] ] ;
+
+:: Rz ( ANGLE -- Rz )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { A B 0 }
+ { C D 0 }
+ { 0 0 1 } }
+
+ ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: apply-rotation ( TURTLE ROTATION -- turtle )
+
+ TURTLE TURTLE ori>> ROTATION m. >>ori ;
+
+: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
+: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
+: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
+: pitch-down ( turtle angle -- turtle ) rotate-x ;
+
+: turn-left ( turtle angle -- turtle ) rotate-y ;
+: turn-right ( turtle angle -- turtle ) neg rotate-y ;
+
+: roll-left ( turtle angle -- turtle ) neg rotate-z ;
+: roll-right ( turtle angle -- turtle ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( turtle -- 3array ) ori>> [ first ] map ;
+: Y ( turtle -- 3array ) ori>> [ second ] map ;
+: Z ( turtle -- 3array ) ori>> [ third ] map ;
+
+: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
+: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
+: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
+
+:: roll-until-horizontal ( TURTLE -- turtle )
+
+ TURTLE
+
+ V TURTLE Z cross normalize set-X
+
+ TURTLE Z TURTLE X cross normalize set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: strafe-up ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
+
+:: strafe-down ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
+
+:: strafe-left ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
+
+:: strafe-right ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
+
+: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
+
+: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
+
+: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
+
+: draw-forward ( turtle length -- turtle )
+ GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
+
+: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
+
+: sneak-forward ( turtle length -- turtle ) step-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scale-length ( turtle m -- turtle ) over length>> * >>length ;
+: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
+
+: scale-thickness ( turtle m -- turtle )
+ over thickness>> * 0.5 max set-thickness ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-table ( -- colors )
+ {
+ T{ rgba f 0 0 0 1 } ! black
+ T{ rgba f 0.5 0.5 0.5 1 } ! grey
+ T{ rgba f 1 0 0 1 } ! red
+ T{ rgba f 1 1 0 1 } ! yellow
+ T{ rgba f 0 1 0 1 } ! green
+ T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
+ T{ rgba f 0 0 1 1 } ! blue
+ T{ rgba f 0.63 0.13 0.94 1 } ! purple
+ T{ rgba f 0.00 0.50 0.00 1 } ! dark green
+ T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
+ T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
+ T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
+ T{ rgba f 0.50 0.00 0.00 1 } ! dark red
+ T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
+ T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
+ T{ rgba f 1 1 1 1 } ! white
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : material-color ( color -- )
+! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
+
+: material-color ( color -- )
+ GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
+
+: set-color ( turtle i -- turtle )
+ dup color-table nth dup gl-color material-color >>color ;
+
+: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
+
+: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-L-parser-values ( turtle -- turtle )
+ 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
+
+: L-parser-dialect ( -- commands )
+
+ {
+ { "+" [ dup angle>> turn-left ] }
+ { "-" [ dup angle>> turn-right ] }
+ { "&" [ dup angle>> pitch-down ] }
+ { "^" [ dup angle>> pitch-up ] }
+ { "<" [ dup angle>> roll-left ] }
+ { ">" [ dup angle>> roll-right ] }
+
+ { "|" [ 180.0 rotate-y ] }
+ { "%" [ 180.0 rotate-z ] }
+ { "$" [ roll-until-horizontal ] }
+
+ { "F" [ dup length>> draw-forward ] }
+ { "Z" [ dup length>> 2 / draw-forward ] }
+ { "f" [ dup length>> move-forward ] }
+ { "z" [ dup length>> 2 / move-forward ] }
+ { "g" [ dup length>> sneak-forward ] }
+ { "." [ polygon-vertex ] }
+
+ { "[" [ save-turtle ] }
+ { "]" [ restore-turtle ] }
+
+ { "{" [ start-polygon ] }
+ { "}" [ finish-polygon ] }
+
+ { "/" [ 1.1 scale-length ] } ! double quote command in lparser
+ { "'" [ 0.9 scale-length ] }
+ { ";" [ 1.1 scale-angle ] }
+ { ":" [ 0.9 scale-angle ] }
+ { "?" [ 1.4 scale-thickness ] }
+ { "!" [ 0.7 scale-thickness ] }
+
+ { "c" [ dup color>> 1 + color-table length mod set-color ] }
+
+ }
+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <L-system> < gadget
+ camera display-list pedestal paused
+ turtle-values
+ commands axiom rules string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-rotation-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: open-paren ( -- ch ) CHAR: ( ;
+: close-paren ( -- ch ) CHAR: ) ;
+
+: open-paren? ( obj -- ? ) open-paren = ;
+: close-paren? ( obj -- ? ) close-paren = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-instruction ( STRING -- next rest )
+
+ { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
+ [ STRING close-paren STRING index 1 + cut ]
+ [ STRING 1 cut ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string-loop ( STRING RULES ACCUM -- )
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ NEXT 1 head RULES at NEXT or ACCUM push-all
+
+ REST RULES ACCUM iterate-string-loop ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string ( STRING RULES -- string )
+
+ [let | ACCUM [ STRING length 10 * <sbuf> ] |
+
+ STRING RULES ACCUM iterate-string-loop
+
+ ACCUM >string ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: interpret-string ( STRING COMMANDS -- )
+
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ [let | COMMAND [ NEXT 1 head COMMANDS at ] |
+
+ COMMAND
+ [
+ NEXT length 1 =
+ [ COMMAND call ]
+ [
+ NEXT 2 tail 1 head* string>number
+ COMMAND 1 tail*
+ call
+ ]
+ if
+ ]
+ when ]
+
+ REST COMMANDS interpret-string ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-L-system-string ( L-SYSTEM -- )
+ L-SYSTEM string>> L-SYSTEM axiom>> or
+ L-SYSTEM rules>>
+ iterate-string
+ L-SYSTEM (>>string) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: do-camera-look-at ( CAMERA -- )
+
+ [let | EYE [ CAMERA pos>> ]
+ FOCUS [ CAMERA clone 1 step-turtle pos>> ]
+ UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
+ |
+
+ EYE FOCUS UP gl-look-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: generate-display-list ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ L-SYSTEM display-list>> GL_COMPILE glNewList
+
+ turtle
+ L-SYSTEM turtle-values>> [ ] or call
+ L-SYSTEM string>> L-SYSTEM axiom>> or
+ L-SYSTEM commands>>
+ interpret-string
+ drop
+
+ glEndList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> draw-gadget* ( L-SYSTEM -- )
+
+ black gl-clear
+
+ GL_FLAT glShadeModel
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ -1 1 -1 1 1.5 200 glFrustum
+
+ GL_MODELVIEW glMatrixMode
+
+ glLoadIdentity
+
+ L-SYSTEM camera>> do-camera-look-at
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+
+ ! draw axis
+ white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
+
+ ! rotate pedestal
+
+ L-SYSTEM pedestal>> 0 0 1 glRotated
+
+ L-SYSTEM display-list>> glCallList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> graft* ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ 1 glGenLists L-SYSTEM (>>display-list) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: with-camera ( L-SYSTEM QUOT -- )
+ L-SYSTEM camera>> QUOT call drop
+ L-SYSTEM relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<L-system>
+H{
+ { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
+ { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
+ { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
+ { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
+
+ { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
+ { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
+
+ { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
+ { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
+
+ { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
+ { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
+ { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
+ { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
+
+ { T{ key-down f f "r" } [ start-rotation-thread ] }
+
+ {
+ T{ key-down f f "x" }
+ [
+ dup iterate-L-system-string
+ dup generate-display-list
+ dup relayout-1
+ drop
+ ]
+ }
+
+ { T{ key-down f f "F1" } [ drop "L-system" help-window ] }
+
+}
+set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: L-system ( -- L-system )
+
+ <L-system> new-gadget
+
+ 0 >>pedestal
+
+ ! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
+
+ turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
+
+ dup start-rotation-thread
+
+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "L-system" "L-system"
+
+"Press 'x' to iterate the L-system." $nl
+
+"Camera control:"
+
+{ $table
+
+ { "a" "Forward" }
+ { "z" "Backward" }
+
+ { "LEFT" "Turn left" }
+ { "RIGHT" "Turn right" }
+ { "UP" "Pitch down" }
+ { "DOWN" "Pitch up" }
+
+ { "q" "Roll left" }
+ { "w" "Roll right" } } ;
+
+ABOUT: "L-system"
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-1
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-1 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ "c(12)FFAL" >>axiom
+
+ {
+ { "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
+ { "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
+ { "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
+
+ { "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-2
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-2 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 30 >>angle ] >>turtle-values
+
+ "c(12)FAL" >>axiom
+
+ {
+ { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
+
+ { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
+ { "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
+
+ { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
+
+ } >>rules ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-3
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-3 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 30 >>angle ] >>turtle-values
+
+ "c(12)FA" >>axiom
+
+ {
+ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
+ { "B" "[&t(.4)F$A]" }
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-4
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-4 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 18 >>angle ] >>turtle-values
+
+ "c(12)&(20)N" >>axiom
+
+ {
+ {
+ "N"
+ "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
+ }
+ { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
+ { "l" "g(.2)l" }
+ { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
+ { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
+ { "f" "_" }
+
+ { "A" "B" }
+ { "B" "C" }
+ { "C" "D" }
+ { "D" "E" }
+ { "E" "G" }
+ { "G" "H" }
+ { "H" "N" }
+
+ { "I" "FoO" }
+ { "O" "FoP" }
+ { "P" "FoQ" }
+ { "Q" "FoR" }
+ { "R" "FoS" }
+ { "S" "FoT" }
+ { "T" "FoU" }
+ { "U" "FoV" }
+ { "V" "FoW" }
+ { "W" "FoX" }
+ { "X" "_" }
+
+ { "o" "$t(-0.03)" }
+ { "r" "~(30)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-5-angular
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-5-angular ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ "&(90)+(90)a" >>axiom
+
+ {
+ { "a" "F[+(45)l][-(45)l]^;ca" }
+
+ { "l" "j" }
+ { "j" "h" }
+ { "h" "s" }
+ { "s" "d" }
+ { "d" "x" }
+ { "x" "a" }
+
+ { "F" "'(1.17)F'(.855)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-5
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-5 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ "a" >>axiom
+
+ {
+ { "a" "F[+(45)l][-(45)l]^;ca" }
+
+ { "l" "j" }
+ { "j" "h" }
+ { "h" "s" }
+ { "s" "d" }
+ { "d" "x" }
+ { "x" "a" }
+
+ { "F" "'(1.17)F'(.855)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-6
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-6 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ ! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
+ "FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
+ >>axiom
+
+ {
+ { "a" "F[cdx][cex]F!(.9)a" }
+ { "x" "a" }
+
+ { "d" "+d" }
+ { "e" "-e" }
+
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.airhorse
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: airhorse ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 10 >>angle ] >>turtle-values
+
+ "C" >>axiom
+
+ {
+ { "C" "LBW" }
+
+ { "B" "[[''aH]|[g]]" }
+ { "a" "Fs+;'a" }
+ { "g" "Ft+;'g" }
+ { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
+ { "t" "[c!!!!&[FF]^^FF]" }
+
+ { "L" "O" }
+ { "O" "P" }
+ { "P" "Q" }
+ { "Q" "R" }
+ { "R" "U" }
+ { "U" "X" }
+ { "X" "Y" }
+ { "Y" "V" }
+ { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
+ { "p" "h>(120)h>(120)h" }
+ { "h" "[+(40)!F'''p]" }
+
+ { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
+ { "d" "Z!&Z!&:'d" }
+ { "e" "Z!^Z!^:'e" }
+ { "i" "-:/i" }
+
+ { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
+ { "b" "Fl!+Fl+;'b" }
+ { "l" "[-cc{--z++z++z--|--z++z++z}]" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.tree-5
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tree-5 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ "c(4)FFS" >>axiom
+
+ {
+ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
+ { "R" "[Ba]" }
+ { "a" "$tF[Cx]Fb" }
+ { "b" "$tF[Dy]Fa" }
+ { "B" "&B" }
+ { "C" "+C" }
+ { "D" "-D" }
+
+ { "x" "a" }
+ { "y" "b" }
+
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel tools.test sequences vectors assocs.lib ;
-IN: assocs.lib.tests
-
-{ 1 1 } [ [ ?push ] histogram ] must-infer-as
-
-! substitute
-[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-
-[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-
-[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-
+++ /dev/null
-USING: arrays assocs kernel vectors sequences namespaces
- random math.parser math fry ;
-
-IN: assocs.lib
-
-: set-assoc-stack ( value key seq -- )
- dupd [ key? ] with find-last nip set-at ;
-
-: at-default ( key assoc -- value/key )
- dupd at [ nip ] when* ;
-
-: replace-at ( assoc value key -- assoc )
- [ dupd 1vector ] dip rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
- swap at* dup [ [ peek ] dip ] when ;
-
-: peek-at ( assoc key -- obj )
- peek-at* drop ;
-
-: >multi-assoc ( assoc -- new-assoc )
- [ 1vector ] assoc-map ;
-
-: multi-assoc-each ( assoc quot -- )
- [ with each ] curry assoc-each ; inline
-
-: insert ( value variable -- ) namespace push-at ;
-
-: generate-key ( assoc -- str )
- [ 32 random-bits >hex ] dip
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
-
-: histogram ( assoc quot -- assoc' )
- H{ } clone [
- swap [ change-at ] 2curry assoc-each
- ] keep ; inline
-
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
-: if-at ( obj assoc quot1 quot2 -- )
- [ ?at ] 2dip if ; inline
-
-: when-at ( obj assoc quot -- ) [ ] if-at ; inline
-
-: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
+++ /dev/null
-Non-core assoc words
+++ /dev/null
-collections
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.parser random arrays hashtables assocs sequences
+ grouping vars ;
+
+IN: automata
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! set-rule
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: rule VAR: rule-number
+
+: init-rule ( -- ) 8 <hashtable> >rule ;
+
+: rule-keys ( -- array )
+ { { 1 1 1 }
+ { 1 1 0 }
+ { 1 0 1 }
+ { 1 0 0 }
+ { 0 1 1 }
+ { 0 1 0 }
+ { 0 0 1 }
+ { 0 0 0 } } ;
+
+: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
+
+: set-rule ( n -- )
+ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! step-capped-line
+! step-wrapped-line
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pattern>state ( {_a_b_c_} -- state ) rule> at ;
+
+: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
+
+: wrap-line ( a-line-z -- za-line-za )
+ dup peek 1array swap dup first 1array append append ;
+
+: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
+
+: step-capped-line ( line -- new-line ) cap-line step-line ;
+: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: width height ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-line ( -- line ) width> [ drop 2 random ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: center-i ( -- i ) width> 2 / >fixnum ;
+
+: center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: interesting ( -- seq )
+ { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
+ 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
+
+: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
+
+: set-interesting ( -- ) interesting random set-rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: bitmap
+
+VAR: last-line
+
+: run-rule ( -- )
+ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-random ( -- ) random-line >last-line run-rule ;
+
+: start-center ( -- ) center-line >last-line run-rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: loop-flag
+
+! DEFER: loop
+
+! : (loop) ( -- ) run-rule 3000 sleep loop ;
+
+! : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
+
+! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
+
+! : stop-loop ( -- ) f >loop-flag ;
--- /dev/null
+Cellular Automata Explorer (one dimensional, two state)
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Cellular Automata" }
+}
--- /dev/null
+
+USING: kernel namespaces math quotations arrays hashtables sequences threads
+ opengl
+ opengl.gl
+ colors
+ ui
+ ui.gestures
+ ui.gadgets
+ ui.gadgets.slate
+ ui.gadgets.labels
+ ui.gadgets.buttons
+ ui.gadgets.frames
+ ui.gadgets.packs
+ ui.gadgets.grids
+ ui.gadgets.theme
+ ui.gadgets.handler
+ accessors
+ vars fry
+ rewrite-closures automata math.geometry.rect newfx ;
+
+IN: automata.ui
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
+
+: draw-line ( y line -- ) 0 swap [ [ 2dup ] dip draw-point 1+ ] each 2drop ;
+
+: (draw-bitmap) ( bitmap -- ) 0 swap [ [ dup ] dip draw-line 1+ ] each drop ;
+
+: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
+
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: slate
+
+! Call a 'model' quotation with the current 'view'.
+
+: with-view ( quot -- )
+ slate> rect-dim first >width
+ slate> rect-dim second >height
+ call
+ slate> relayout-1 ;
+
+! Create a quotation that is appropriate for buttons and gesture handler.
+
+: view-action ( quot -- quot ) '[ drop _ with-view ] closed-quot ;
+
+: view-button ( label quot -- button ) [ <label> ] dip view-action <bevel-button> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Helper word to make things less verbose
+
+: random-rule ( -- ) set-interesting start-center ;
+
+DEFER: automata-window
+
+: automata-window* ( -- )
+ init-rule
+ set-interesting
+
+ <frame>
+
+ <shelf>
+
+ "1 - Center" [ start-center ] view-button add-gadget
+ "2 - Random" [ start-random ] view-button add-gadget
+ "3 - Continue" [ run-rule ] view-button add-gadget
+ "5 - Random Rule" [ random-rule ] view-button add-gadget
+ "n - New" [ automata-window ] view-button add-gadget
+
+ @top grid-add
+
+ C[ display ] <slate>
+ { 400 400 } >>pdim
+ dup >slate
+
+ @center grid-add
+
+ <handler>
+
+ H{ }
+ T{ key-down f f "1" } [ start-center ] view-action is
+ T{ key-down f f "2" } [ start-random ] view-action is
+ T{ key-down f f "3" } [ run-rule ] view-action is
+ T{ key-down f f "5" } [ random-rule ] view-action is
+ T{ key-down f f "n" } [ automata-window ] view-action is
+
+ >>table
+
+ "Automata" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
+
+MAIN: automata-window
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel tools.test bake ;
-
-IN: bake.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
-
-[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
-
-[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
-
-[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
-
-[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
-
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
-[ { 1 2 3 4 5 6 7 8 9 } ]
-unit-test*
-
+++ /dev/null
-
-USING: kernel parser namespaces sequences quotations arrays vectors splitting
- strings words math generalizations
- macros combinators.conditional newfx ;
-
-IN: bake
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: ,
-SYMBOL: @
-
-: comma? ( obj -- ? ) , = ;
-: atsym? ( obj -- ? ) @ = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: [bake]
-
-: broil-element ( obj -- quot )
- {
- { [ comma? ] [ drop [ >r ] ] }
- { [ f = ] [ [ >r ] prefix-on ] }
- { [ integer? ] [ [ >r ] prefix-on ] }
- { [ string? ] [ [ >r ] prefix-on ] }
- { [ sequence? ] [ [bake] [ >r ] append ] }
- { [ word? ] [ literalize [ >r ] prefix-on ] }
- { [ drop t ] [ [ >r ] prefix-on ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constructor ( seq -- quot )
- {
- { [ array? ] [ length [ narray ] prefix-on ] }
-! { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
- { [ quotation? ] [ length [ narray >quotation ] prefix-on ] }
- { [ vector? ] [ length [ narray >vector ] prefix-on ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [broil] ( seq -- quot )
- [ reverse [ broil-element ] map concat ]
- [ length [ drop [ r> ] ] map concat ]
- [ constructor ]
- tri append append
- >quotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: saved-sequence
-
-: [connector] ( -- quot )
- saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
-
-: [starter] ( -- quot )
- saved-sequence get
- {
- { [ quotation? ] [ drop [ [ ] ] ] }
- { [ array? ] [ drop [ { } ] ] }
- { [ vector? ] [ drop [ V{ } ] ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [simmer] ( seq -- quot )
-
- dup saved-sequence set
-
- { @ } split reverse
- [ [ [bake] [connector] append [ >r ] append ] map concat ]
- [ length [ drop [ r> ] [connector] append ] map concat ]
- bi
-
- >r 1 invert-index pluck r> ! remove the last append/compose
-
- [starter] prepend
-
- append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: bake ( seq -- quot ) [bake] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
-: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
-: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: tools.test math prettyprint kernel io arrays vectors sequences
- generalizations bake bake.fry ;
-
-IN: bake.fry.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
-
-[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
-
-[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
-
-[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
-
-[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
-
-[ [ "a" write "b" print ] ]
-[ "a" "b" '[ , write , print ] ] unit-test
-
-[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
-
-[ 1/2 ] [
- 1 '[ , _ / ] 2 swap call
-] unit-test
-
-[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
- 1 '[ , _ _ 3array ]
- { "a" "b" "c" } { "A" "B" "C" } rot 2map
-] unit-test
-
-[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
- '[ 1 _ 2array ]
- { "a" "b" "c" } swap map
-] unit-test
-
-[ 1 2 ] [
- 1 2 '[ _ , ] call
-] unit-test
-
-[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
- 1 2 '[ , _ , 3array ]
- { "a" "b" "c" } swap map
-] unit-test
-
-: funny-dip '[ @ _ ] call ; inline
-
-[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
-
-[ { 1 2 3 } ] [
- 3 1 '[ , [ , + ] map ] call
-] unit-test
-
-[ { 1 { 2 { 3 } } } ] [
- 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
-] unit-test
-
-{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
-
-[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
-] unit-test
-
-[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
-] unit-test
-
-! [ 10 20 30 40 '[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
-
-[ 10 20 30 40 '[ , V{ , { , } } , ] ]
-[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
-unit-test*
-
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } '[ , { V{ @ } { , } } ] call ]
-[
- { 1 2 3 }
- { V{ 4 5 6 } { { 7 8 9 } } }
-]
-unit-test*
-
+++ /dev/null
-
-USING: kernel combinators arrays vectors quotations sequences splitting
- parser macros sequences.deep
- combinators.short-circuit combinators.conditional bake newfx ;
-
-IN: bake.fry
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: _
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: (shallow-fry)
-DEFER: shallow-fry
-
-: ((shallow-fry)) ( accum quot adder -- result )
- >r shallow-fry r>
- append swap dup empty?
- [ drop ]
- [ [ prepose ] curry append ]
- if ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (shallow-fry) ( accum quot -- result )
- dup empty?
- [ drop 1quotation ]
- [
- unclip
- {
- { \ , [ [ curry ] ((shallow-fry)) ] }
- { \ @ [ [ compose ] ((shallow-fry)) ] }
- [ swap >r suffix r> (shallow-fry) ]
- }
- case
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: deep-fry ( quot -- quot )
- { _ } split1-last dup
- [
- shallow-fry [ >r ] rot
- deep-fry [ [ dip ] curry r> compose ] 4array concat
- ]
- [ drop shallow-fry ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ;
-
-: fry-specifier? ( obj -- ? ) { , @ } member-of? ;
-
-: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ;
-
-: commas ( n -- seq ) , <repetition> ;
-
-: [fry] ( quot -- quot' )
- [
- {
- { [ callable? ] [ [ count-inputs commas ] [ [fry] ] bi append ] }
- { [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] }
- { [ drop t ] [ 1quotation ] }
- }
- 1cond
- ]
- map concat deep-fry ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: fry ( seq -- quot ) [fry] ;
-
-: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
+++ /dev/null
-Bake is similar to make but with additional features
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: bitfields
-
-HELP: BITFIELD:
-{ $syntax "BITFIELD: name slot:size... ;" }
-{ $values { "name" "name of bitfield" } { "slot" "names of slots" } { "size" "sizes of slots" } }
-{ $description "Creates a new bitfield specification, with the constructor <name> and slot accessors of the form name-slot. Slots' values can be changed by words of the form with-name-slot, with the stack effect " { $code "( newvalue bitfield -- newbitfield )" } ". The slots have the amount of space specified, in bits, after the colon. The constructor and setters do not check to make sure there is no overflow, and any inappropriately high value (except in the first field) will corrupt the bitfield. To check overflow, use " { $link POSTPONE: SAFE-BITFIELD: } " instead. Padding can be included by writing the binary number to be used as a pad in the middle of the bitfield specification. The first slot written will have the most significant digits. Note that bitfields do not form a class; they are merely integers. For efficiency across platforms, it is often the best to keep the total size at or below 29, allowing fixnums to be used on all platforms." }
-{ $see-also define-bitfield } ;
-
-HELP: define-bitfield
-{ $values { "classname" "a string" } { "slots" "slot specifications" } }
-{ $description "Defines a bitfield constructor and slot accessors and setters. The workings of these are described in more detail at " { $link POSTPONE: BITFIELD: } ". The slot specifications should be an assoc. Any key which looks like a binary number will be treated as padding." } ;
-
-HELP: SAFE-BITFIELD:
-{ $syntax "SAFE-BITFIELD: name slot:size... ;" }
-{ $values { "name" "name of bitfield" } { "slot" "name of slots" } { "size" "size in bits of slots" } }
-{ $description "Defines a bitfield in the same way as " { $link POSTPONE: BITFIELD: } " but the constructor and slot setters check for overflow." } ;
+++ /dev/null
-USING: tools.test bitfields kernel ;
-IN: bitfields.tests
-
-SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;
-
-[ 21 ] [ 21 852 3 <foo> foo-bar ] unit-test
-[ 852 ] [ 21 852 3 <foo> foo-baz ] unit-test
-[ 3 ] [ 21 852 3 <foo> foo-bing ] unit-test
-
-[ 23 ] [ 21 852 3 <foo> 23 swap with-foo-bar foo-bar ] unit-test
-[ 855 ] [ 21 852 3 <foo> 855 swap with-foo-baz foo-baz ] unit-test
-[ 1 ] [ 21 852 3 <foo> 1 swap with-foo-bing foo-bing ] unit-test
-
-[ 100 0 0 <foo> ] must-fail
-[ 0 5000 0 <foo> ] must-fail
-[ 0 0 10 <foo> ] must-fail
-
-[ 100 0 with-foo-bar ] must-fail
-[ 5000 0 with-foo-baz ] must-fail
-[ 10 0 with-foo-bing ] must-fail
-
-[ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 <foo> ] unit-test
+++ /dev/null
-USING: parser lexer kernel math sequences namespaces make assocs
-summary words splitting math.parser arrays sequences.next
-mirrors generalizations compiler.units ;
-IN: bitfields
-
-! Example:
-! BITFIELD: blah short:16 char:8 nothing:5 ;
-! defines <blah> blah-short blah-char blah-nothing.
-
-! An efficient bitfield has a sum of 29 bits or less
-! so it can fit in a fixnum.
-! No class is defined and there is no overflow checking.
-! The first field is the most significant.
-
-: >ranges ( slots/sizes -- slots/ranges )
- ! range is { start length }
- reverse 0 swap [
- swap >r tuck >r [ + ] keep r> 2array r> swap
- ] assoc-map nip reverse ;
-
-SYMBOL: safe-bitfields? ! default f; set at parsetime
-
-TUPLE: check< number bound ;
-M: check< summary drop "Number exceeds upper bound" ;
-
-: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< boa throw ] if ;
-
-: ?check ( length -- )
- safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
-
-: put-together ( lengths -- )
- ! messy because of bounds checking
- dup length 1- [ \ >r , ] times [ 0 swap ] % [
- ?check [ \ bitor , , [ shift r> ] % ] when*
- ] each-next \ bitor , ;
-
-: padding-name? ( string -- ? )
- [ "10" member? ] all? ;
-
-: pad ( i name -- )
- bin> , , \ -nrot , ;
-
-: add-padding ( names -- )
- <enum>
- [ dup padding-name? [ pad ] [ 2drop ] if ] assoc-each ;
-
-: [constructor] ( names lengths -- quot )
- [ swap add-padding put-together ] [ ] make ;
-
-: define-constructor ( classname slots -- )
- [ keys ] keep values [constructor]
- >r in get constructor-word dup save-location r>
- define ;
-
-: range>accessor ( range -- quot )
- [
- dup first neg , \ shift ,
- second 2^ 1- , \ bitand ,
- ] [ ] make ;
-
-: [accessors] ( lengths -- accessors )
- [ range>accessor ] map ;
-
-: clear-range ( range -- num )
- first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
-
-: range>setter ( range -- quot )
- [
- \ >r , dup second ?check \ r> ,
- dup clear-range ,
- [ bitand >r ] %
- first , [ shift r> bitor ] %
- ] [ ] make ;
-
-: [setters] ( lengths -- setters )
- [ range>setter ] map ;
-
-: parse-slots ( slotspecs -- slots )
- [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
-
-: define-slots ( prefix names quots -- )
- >r [ "-" glue create-in ] with map r>
- [ define ] 2each ;
-
-: define-accessors ( classname slots -- )
- dup values [accessors]
- >r keys r> define-slots ;
-
-: define-setters ( classname slots -- )
- >r "with-" prepend r>
- dup values [setters]
- >r keys r> define-slots ;
-
-: filter-pad ( slots -- slots )
- [ drop padding-name? not ] assoc-filter ;
-
-: define-bitfield ( classname slots -- )
- [
- [ define-constructor ] 2keep
- >ranges filter-pad [ define-setters ] 2keep define-accessors
- ] with-compilation-unit ;
-
-: parse-bitfield ( -- )
- scan ";" parse-tokens parse-slots define-bitfield ;
-
-: BITFIELD:
- parse-bitfield ; parsing
-
-: SAFE-BITFIELD:
- [ safe-bitfields? on parse-bitfield ] with-scope ; parsing
+++ /dev/null
-Simple system for specifying packed bitfields
+++ /dev/null
-extensions
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel
+ namespaces
+ arrays
+ accessors
+ strings
+ sequences
+ locals
+ threads
+ math
+ math.functions
+ math.trig
+ math.order
+ math.ranges
+ math.vectors
+ random
+ calendar
+ opengl.gl
+ opengl
+ ui
+ ui.gadgets
+ ui.gadgets.tracks
+ ui.gadgets.frames
+ ui.gadgets.grids
+ ui.render
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit
+ processing.shapes
+ flatland ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: boids
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: constrain ( n a b -- n ) rot min max ;
+
+: angle-between ( vec vec -- angle )
+ [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
+
+: relative-angle ( self other -- angle )
+ over vel>> -rot relative-position angle-between ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
+: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
+
+: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
+
+: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
+: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <boid> < <vel> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <behaviour>
+ { weight initial: 1.0 }
+ { view-angle initial: 180 }
+ { radius } ;
+
+TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
+TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
+TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
+
+ SELF OTHER
+ {
+ [ BEHAVIOUR radius>> in-radius? ]
+ [ BEHAVIOUR view-angle>> in-view? ]
+ [ eq? not ]
+ }
+ 2&& ;
+
+:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
+ OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: force* ( sequence <boid> <behaviour> -- force )
+
+:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
+
+:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
+
+:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
+
+METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
+METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
+METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
+
+:: force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF OTHERS BEHAVIOUR neighborhood
+ [ { 0 0 } ]
+ [ SELF BEHAVIOUR force* ]
+ if-empty ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-boids ( count -- boids )
+ [
+ drop
+ <boid> new
+ 2 [ drop 1000 random ] map >>pos
+ 2 [ drop -10 10 [a,b] random ] map >>vel
+ ]
+ map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-boid ( boid -- )
+ glPushMatrix
+ dup pos>> gl-translate-2d
+ vel>> first2 rect> arg rad>deg 0 0 1 glRotated
+ { { 0 5 } { 0 -5 } { 20 0 } } triangle
+ fill-mode
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
+
+M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
+M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( BOIDS-GADGET -- )
+
+ [let | SKY [ BOIDS-GADGET gadget->sky ]
+ BOIDS [ BOIDS-GADGET boids>> ]
+ TIME-SLICE [ BOIDS-GADGET time-slice>> ]
+ BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
+
+ BOIDS
+
+ [| SELF |
+
+ [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
+
+ ! F = m a. M is 1. So F = a.
+
+ [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
+
+ [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
+ VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
+
+ [let | POS [ POS SKY wrap ]
+ VEL [ VEL normalize* ] |
+
+ T{ <boid> f POS VEL } ] ] ] ]
+
+ ]
+
+ map
+
+ BOIDS-GADGET (>>boids) ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
+ origin get
+ [ BOIDS-GADGET boids>> [ draw-boid ] each ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-boids-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-behaviours ( -- seq )
+ { <cohesion> <alignment> <separation> } [ new ] map ;
+
+: boids-gadget ( -- gadget )
+ <boids-gadget> new-gadget
+ 100 random-boids >>boids
+ default-behaviours >>behaviours
+ 10 >>time-slice
+ t >>clipped? ;
+
+: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: math.parser
+ ui.gadgets.labels
+ ui.gadgets.buttons
+ ui.gadgets.packs ;
+
+: truncate-number ( n -- n ) 10 * round 10 / ;
+
+:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
+ [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
+ VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ! ( -- )
+ BEHAVIOUR weight>> truncate-number number>string
+ VALUE-LABEL
+ (>>string) ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+ { 1 0 } <track>
+ NAME-LABEL 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "+0.1"
+ [
+ drop
+ BEHAVIOUR [ 0.1 + ] change-weight drop
+ update-value-label
+ ]
+ <bevel-button> add-gadget
+
+ "-0.1"
+ [
+ drop
+ BEHAVIOUR weight>> 0.1 >
+ [
+ BEHAVIOUR [ 0.1 - ] change-weight drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button> add-gadget ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: make-population-control ( BOIDS-GADGET -- gadget )
+ [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ( -- )
+ BOIDS-GADGET boids>> length number>string
+ VALUE-LABEL
+ (>>string) ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+
+ { 1 0 } <track>
+ "Population: " <label> reverse-video-theme 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "Add 10"
+ [
+ drop
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 random-boids append
+ >>boids
+ drop
+ update-value-label
+ ]
+ <bevel-button>
+ add-gadget
+
+ "Sub 10"
+ [
+ drop
+ BOIDS-GADGET boids>> length 10 >
+ [
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 tail
+ >>boids
+ drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button>
+ add-gadget ] ] ( gadget -- gadget ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pause-toggle ( BOIDS-GADGET -- )
+ BOIDS-GADGET paused>>
+ [ BOIDS-GADGET start-boids-thread ]
+ [ BOIDS-GADGET t >>paused drop ]
+ if ;
+
+:: randomize-boids ( BOIDS-GADGET -- )
+ BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
+
+: boids-app ( -- )
+
+ [let | BOIDS-GADGET [ boids-gadget ] |
+
+ <frame>
+
+ <shelf>
+
+ 1 >>fill
+
+ "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
+
+ "Randomize"
+ [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
+
+ BOIDS-GADGET make-population-control add-gadget
+
+ "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
+ "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
+ "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
+
+ [ add-gadget ] tri@
+
+ @top grid-add
+
+ BOIDS-GADGET @center grid-add
+
+ "Boids" open-window
+
+ BOIDS-GADGET start-boids-thread ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boids-main ( -- ) [ boids-app ] with-ui ;
+
+MAIN: boids-main
\ No newline at end of file
--- /dev/null
+Artificial life program simulating simulating the flocking behaviour of birds
--- /dev/null
+
+USING: kernel syntax accessors sequences
+ arrays calendar
+ combinators.cleave combinators.short-circuit
+ locals math math.constants math.functions math.libm
+ math.order math.points math.vectors
+ namespaces random sequences threads ui ui.gadgets ui.gestures
+ math.ranges
+ colors
+ colors.gray
+ vars
+ multi-methods
+ multi-method-syntax
+ processing.shapes
+ frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! This is a Factor implementation of an art piece by Jared Tarbell:
+!
+! http://complexification.net/gallery/machines/bubblechamber/
+!
+! Jared's version is written in Processing (Java)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! processing
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x ( -- x ) mouse first ;
+: mouse-y ( -- y ) mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle
+ bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 rgba boa >>myc
+ 0 0 0 1 rgba boa >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
+
+DEFER: collision-theta
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: out-of-bounds? ( PARTICLE -- ? )
+ [let | X [ PARTICLE pos>> first ]
+ Y [ PARTICLE pos>> second ]
+ WIDTH [ PARTICLE bubble-chamber>> size>> first ]
+ HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
+
+ [let | LEFT [ WIDTH neg ]
+ RIGHT [ WIDTH 2 * ]
+ BOTTOM [ HEIGHT neg ]
+ TOP [ HEIGHT 2 * ] |
+
+ { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.axion
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <axion> < particle ;
+
+: axion ( -- <axion> ) <axion> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <axion> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
+! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
+
+: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y point ;
+: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <axion> -- )
+
+ T{ gray f 0.06 0.59 } \ stroke-color set
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.hadron
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <hadron> < particle ;
+
+: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <hadron> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ 0 1 0 1 rgba boa >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <hadron> -- )
+
+ T{ gray f 1 0.11 } \ stroke-color set dup pos>> 1 v-y point
+ T{ gray f 0 0.11 } \ stroke-color set dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ dup out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon.colors
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <muon> < particle ;
+
+: muon ( -- <muon> ) <muon> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <muon> -- )
+
+ dup center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ dup collision-theta -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <muon> -- )
+
+ [let | MUON [ ] |
+
+ [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
+
+ MUON
+
+ dup myc>> 0.16 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha \ stroke-color set
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.quark
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <quark> < particle ;
+
+: quark ( -- <quark> ) <quark> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <quark> -- )
+
+ dup center >>pos
+ dup collision-theta -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <quark> -- )
+
+ [let | QUARK [ ] |
+
+ [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
+
+ QUARK
+
+ dup myc>> 0.13 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <bubble-chamber> < <frame-buffer>
+ paused particles collision-theta size ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+! 0 2 pi * 0.001 <range> random >>collision-theta ;
+
+: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+ pi neg pi 0.001 <range> random >>collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
+
+M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-particle ( particle -- ) move ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
+
+ BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( <bubble-chamber> -- ) drop ;
+
+:: start-bubble-chamber-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- <bubble-chamber> )
+ <bubble-chamber> new-gadget
+ { 1000 1000 } >>size
+ randomize-collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber-window ( -- <bubble-chamber> )
+ bubble-chamber
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
+
+ PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
+
+ BUBBLE-CHAMBER BUBBLE-CHAMBER particles>> PARTICLE suffix >>particles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
+ mouse
+ BUBBLE-CHAMBER size>> 2 v/n
+ v-
+ first2
+ fatan2
+ BUBBLE-CHAMBER (>>collision-theta)
+ BUBBLE-CHAMBER ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse-pressed ( BUBBLE-CHAMBER -- )
+
+ BUBBLE-CHAMBER mouse->collision-theta drop
+
+ 11
+ [
+ BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <quark>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <muon>? ] filter random [ collide ] when*
+ ]
+ times ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-random-particle ( bubble-chamber -- bubble-chamber )
+ dup particles>> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: big-bang ( bubble-chamber -- bubble-chamber )
+ dup particles>> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one-of-each ( bubble-chamber -- bubble-chamber )
+ dup
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Some initial configurations
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ten-hadrons ( -- )
+ bubble-chamber-window
+ 10 [ drop hadron add-particle ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original ( -- )
+
+ bubble-chamber-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hadron-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ hadron add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quark-chamber ( -- )
+ bubble-chamber-window
+ 100 [ quark add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: small ( -- )
+ <bubble-chamber> new-gadget
+ { 200 200 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 42 [ muon add-particle ] times
+ 30 [ quark add-particle ] times
+ 21 [ hadron add-particle ] times
+ 7 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: medium ( -- )
+ <bubble-chamber> new-gadget
+ { 400 400 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 100 [ muon add-particle ] times
+ 81 [ quark add-particle ] times
+ 60 [ hadron add-particle ] times
+ 9 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: large ( -- )
+ <bubble-chamber> new-gadget
+ { 600 600 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 550 [ muon add-particle ] times
+ 339 [ quark add-particle ] times
+ 100 [ hadron add-particle ] times
+ 11 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Experimental
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: muon-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ muon add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang ( -- )
+ bubble-chamber
+ { 1000 1000 } >>size
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ big-bang
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang-variant ( -- )
+ bubble-chamber-window
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.hadron-chamber
+
+: main ( -- ) [ hadron-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.large
+
+: main ( -- ) [ large ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.medium
+
+: main ( -- ) [ medium ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.original
+
+: main ( -- ) [ original ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.quark-chamber
+
+: main ( -- ) [ quark-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.small
+
+: main ( -- ) [ small ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.ten-hadrons
+
+: main ( -- ) [ ten-hadrons ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+Sampo Vuori
--- /dev/null
+! Cairo "Hello World" demo
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+! http://cairographics.org/samples/text/
+
+
+USING: cairo.ffi math math.constants byte-arrays kernel ui
+ui.render combinators ui.gadgets opengl.gl accessors
+namespaces opengl ;
+
+IN: cairo-demo
+
+: make-image-array ( -- array )
+ 384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
+
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
+
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
+ origin get [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
+ image-array>> glDrawPixels
+ ] with-translation ;
+
+: create-surface ( gadget -- cairo_surface_t )
+ make-image-array [ swap (>>image-array) ] keep
+ convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
+
+ERROR: no-cairo-t ;
+
+<PRIVATE
+
+: draw-hello-world ( gadget -- )
+ cairo-t>> [ no-cairo-t ] unless*
+ {
+ [
+ "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ ]
+ [ 90.0 cairo_set_font_size ]
+ [ 10.0 135.0 cairo_move_to ]
+ [ "Hello" cairo_show_text ]
+ [ 70.0 165.0 cairo_move_to ]
+ [ "World" cairo_text_path ]
+ [ 0.5 0.5 1 cairo_set_source_rgb ]
+ [ cairo_fill_preserve ]
+ [ 0 0 0 cairo_set_source_rgb ]
+ [ 2.56 cairo_set_line_width ]
+ [ cairo_stroke ]
+ [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
+ [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_close_path ]
+ [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_fill ]
+ } cleave ;
+
+PRIVATE>
+
+M: cairo-demo-gadget graft* ( gadget -- )
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+
+M: cairo-demo-gadget ungraft* ( gadget -- )
+ cairo-t>> cairo_destroy ;
+
+: <cairo-demo-gadget> ( -- gadget )
+ cairo-demo-gadget new-gadget ;
+
+: run ( -- )
+ [
+ <cairo-demo-gadget> "Hello World from Factor!" open-window
+ ] with-ui ;
+
+MAIN: run
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math kernel byte-arrays cairo.ffi cairo
+io.backend ui.gadgets accessors opengl.gl arrays fry
+classes ui.render namespaces destructors libc ;
+IN: cairo.gadgets
+
+<PRIVATE
+: width>stride ( width -- stride ) 4 * ;
+
+: image-dims ( gadget -- width height stride )
+ dim>> first2 over width>stride ; inline
+: image-buffer ( width height stride -- alien )
+ * nip malloc ; inline
+PRIVATE>
+
+GENERIC: render-cairo* ( gadget -- )
+
+: render-cairo ( gadget -- alien )
+ [
+ image-dims
+ [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
+
+TUPLE: cairo-gadget < gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+ cairo-gadget new
+ swap >>dim ;
+
+M: cairo-gadget draw-gadget*
+ [
+ [ dim>> ] [ render-cairo &free ] bi
+ origin get first2 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+ glDrawPixels
+ ] with-destructors ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
--- /dev/null
+UI gadget for rendering graphics with Cairo
--- /dev/null
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.ffi locals math.constants math
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
+
+IN: cairo-samples
+
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
+ [let | xc [ 128.0 ]
+ yc [ 128.0 ]
+ radius [ 100.0 ]
+ angle1 [ pi 1/4 * ]
+ angle2 [ pi ] |
+ cr 10.0 cairo_set_line_width
+ cr xc yc radius angle1 angle2 cairo_arc
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6.0 cairo_set_line_width
+
+ cr xc yc 10.0 0 2 pi * cairo_arc
+ cr cairo_fill
+
+ cr xc yc radius angle1 angle1 cairo_arc
+ cr xc yc cairo_line_to
+ cr xc yc radius angle2 angle2 cairo_arc
+ cr xc yc cairo_line_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+ drop
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 0 0 256 256 cairo_rectangle
+ cr cairo_fill
+ cr 0 1 0 cairo_set_source_rgb
+ cr 0 0 cairo_move_to
+ cr 256 256 cairo_line_to
+ cr 256 0 cairo_move_to
+ cr 0 256 cairo_line_to
+ cr 10 cairo_set_line_width
+ cr cairo_stroke ;
+
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
+ [let* | png [ "resource:misc/icons/Factor_128x128.png"
+ normalize-path cairo_image_surface_create_from_png ]
+ w [ png cairo_image_surface_get_width ]
+ h [ png cairo_image_surface_get_height ] |
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 192.0 w / 192.0 h / cairo_scale
+ cr png 32 32 cairo_set_source_surface
+ cr cairo_paint
+ png cairo_surface_destroy
+ ] ;
+
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
+ [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
+ ndash [ 4 ] |
+ cr dashes ndash -50 cairo_set_dash
+ cr 10 cairo_set_line_width
+ cr 128.0 25.6 cairo_move_to
+ cr 230.4 230.4 cairo_line_to
+ cr -102.4 0 cairo_rel_line_to
+ cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
+ [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+ radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+ cairo_pattern_create_radial ] |
+ pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ cr 0 0 256 256 cairo_rectangle
+ cr pat cairo_set_source
+ cr cairo_fill
+ pat cairo_pattern_destroy
+
+ radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ cr radial cairo_set_source
+ cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+ cr cairo_fill
+ radial cairo_pattern_destroy
+ ] ;
+
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ cr 10 135 cairo_move_to
+ cr "Hello" cairo_show_text
+
+ cr 70 165 cairo_move_to
+ cr "factor" cairo_text_path
+ cr 0.5 0.5 1 cairo_set_source_rgb
+ cr cairo_fill_preserve
+ cr 0 0 0 cairo_set_source_rgb
+ cr 2.56 cairo_set_line_width
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 10 135 5.12 0 2 pi * cairo_arc
+ cr cairo_close_path
+ cr 70 165 5.12 0 2 pi * cairo_arc
+ cr cairo_fill ;
+
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ "cairo_text_extents_t" malloc-object
+ cr "日本語" pick cairo_text_extents
+ cr over
+ [ cairo_text_extents_t-width 2 / ]
+ [ cairo_text_extents_t-x_bearing ] bi +
+ 128 swap - pick
+ [ cairo_text_extents_t-height 2 / ]
+ [ cairo_text_extents_t-y_bearing ] bi +
+ 128 swap - cairo_move_to
+ free
+ cr "日本語" cairo_show_text
+
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6 cairo_set_line_width
+ cr 128 0 cairo_move_to
+ cr 0 256 cairo_rel_line_to
+ cr 0 128 cairo_move_to
+ cr 256 0 cairo_rel_line_to
+ cr cairo_stroke ;
+
+ USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
+ : samples ( -- )
+ {
+ arc-gadget clip-gadget clip-image-gadget dash-gadget
+ gradient-gadget text-gadget utf8-gadget
+ }
+ [ new-gadget { 256 256 } >>dim gadget. ] each ;
+
+ MAIN: samples
+++ /dev/null
-Adam Wendt
+++ /dev/null
-
-USING: kernel namespaces math.vectors opengl pos ori turtle self ;
-
-IN: opengl.camera
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: camera-eye ( -- point ) pos> ;
-
-: camera-focus ( -- point ) [ 1 step-turtle pos> ] save-self ;
-
-: camera-up ( -- dirvec )
-[ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ;
-
-: do-look-at ( camera -- )
-[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
--- /dev/null
+
+USING: kernel combinators sequences opengl.gl
+ ui.render ui.gadgets ui.gadgets.slate
+ accessors ;
+
+IN: ui.gadgets.cartesian
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
+
+: init-cartesian ( cartesian -- cartesian )
+ init-slate
+ -10 >>x-min
+ 10 >>x-max
+ -10 >>y-min
+ 10 >>y-max
+ -1 >>z-min
+ 1 >>z-max ;
+
+: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: cartesian establish-coordinate-system ( cartesian -- cartesian )
+ dup
+ {
+ [ x-min>> ] [ x-max>> ]
+ [ y-min>> ] [ y-max>> ]
+ [ z-min>> ] [ z-max>> ]
+ }
+ cleave
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
+: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
+: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types combinators namespaces make arrays
+ sequences splitting
+ math math.functions math.vectors math.trig
+ opengl.gl opengl.glu opengl ui ui.gadgets.slate
+ vars colors self self.slots
+ random-weighted colors.hsv cfdg.gl accessors
+ ui.gadgets.handler ui.gestures assocs ui.gadgets macros
+ specialized-arrays.double ;
+
+QUALIFIED: syntax
+
+IN: cfdg
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SELF-SLOTS: hsva
+
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! if (adjustment < 0)
+! base + base * adjustment
+
+! if (adjustment > 0)
+! base + (1 - base) * adjustment
+
+: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hue ( num -- ) hue-> + 360 mod ->hue ;
+
+: saturation ( num -- ) saturation-> swap adjust ->saturation ;
+: brightness ( num -- ) value-> swap adjust ->value ;
+: alpha ( num -- ) alpha-> swap adjust ->alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: h ( num -- ) hue ;
+: sat ( num -- ) saturation ;
+: b ( num -- ) brightness ;
+: a ( num -- ) alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: color-stack
+
+: init-color-stack ( -- ) V{ } clone >color-stack ;
+
+: push-color ( -- ) self> color-stack> push self> clone >self ;
+
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
+
+: double-nth* ( c-array indices -- seq )
+ swap byte-array>double-array [ nth ] curry map ;
+
+: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map supremum ;
+
+VAR: threshold
+
+: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! cos 2a sin 2a 0 0
+! sin 2a -cos 2a 0 0
+! 0 0 1 0
+! 0 0 0 1
+
+! column major order
+
+: gl-flip ( angle -- ) deg>rad dup dup dup
+ [ 2 * cos , 2 * sin , 0 , 0 ,
+ 2 * sin , 2 * cos neg , 0 , 0 ,
+ 0 , 0 , 1 , 0 ,
+ 0 , 0 , 0 , 1 , ]
+ double-array{ } make underlying>> glMultMatrixd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( -- )
+ self> gl-color
+ gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
+
+: triangle ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ 0 0.577 glVertex2d
+ 0.5 -0.289 glVertex2d
+ -0.5 -0.289 glVertex2d
+ glEnd ;
+
+: square ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ -0.5 0.5 glVertex2d
+ 0.5 0.5 glVertex2d
+ 0.5 -0.5 glVertex2d
+ -0.5 -0.5 glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size ( scale -- ) dup 1 glScaled ;
+
+: size* ( scale-x scale-y -- ) 1 glScaled ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+: x ( x -- ) 0 0 glTranslated ;
+
+: y ( y -- ) 0 swap 0 glTranslated ;
+
+: flip ( angle -- ) gl-flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: s ( scale -- ) size ;
+: s* ( scale-x scale-y -- ) size* ;
+: r ( angle -- ) rotate ;
+: f ( angle -- ) flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: do ( quot -- )
+ push-modelview-matrix
+ push-color
+ call
+ pop-modelview-matrix
+ pop-color ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive ( quot -- ) iterate? swap when ; inline
+
+: multi ( seq -- ) random-weighted* call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rules] ( seq -- quot )
+ [ unclip swap [ [ do ] curry ] map concat 2array ] map
+ [ call-random-weighted ] swap prefix
+ [ when ] swap prefix
+ [ iterate? ] swap append ;
+
+MACRO: rules ( seq -- quot ) [rules] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rule] ( seq -- quot )
+ [ [ do ] swap prefix ] map concat
+ [ when ] swap prefix
+ [ iterate? ] prepend ;
+
+MACRO: rule ( seq -- quot ) [rule] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: background
+
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
+
+: set-background ( -- )
+ set-initial-background
+ background> call
+ self> clear-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: rewrite-closures ;
+
+VAR: viewport ! { left width bottom height }
+
+VAR: start-shape
+
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: dlist
+
+! : build-model-dlist ( -- )
+! 1 glGenLists dlist set
+! dlist get GL_COMPILE_AND_EXECUTE glNewList
+! start-shape> call
+! glEndList ;
+
+: build-model-dlist ( -- )
+ 1 glGenLists dlist set
+ dlist get GL_COMPILE_AND_EXECUTE glNewList
+
+ set-initial-color
+
+ self> gl-color
+
+ start-shape> call
+
+ glEndList ;
+
+: display ( -- )
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ viewport> first dup viewport> second +
+ viewport> third dup viewport> fourth + gluOrtho2D
+
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+
+ set-background
+
+ GL_COLOR_BUFFER_BIT glClear
+
+ init-modelview-matrix-stack
+ init-color-stack
+
+ dlist get not
+ [ build-model-dlist ]
+ [ dlist get glCallList ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
+
+: cfdg-window* ( -- slate )
+ C[ display ] <slate>
+ { 500 500 } >>pdim
+ C[ delete-dlist ] >>ungraft
+ dup "CFDG" open-window ;
+
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: the-slate
+
+: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
+
+: <cfdg-gadget> ( -- slate )
+ C[ display ] <slate>
+ dup the-slate set
+ { 500 500 } >>pdim
+ C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
+ <handler>
+ H{ } clone
+ T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
+ T{ button-down } C[ drop rebuild ] swap pick set-at
+ >>table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: fry
+
+: cfdg-window. ( quot -- )
+ '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types namespaces sequences opengl.gl ;
+
+IN: cfdg.gl
+
+: get-modelview-matrix ( -- alien )
+ GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
+
+SYMBOL: modelview-matrix-stack
+
+: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
+
+: push-modelview-matrix ( -- )
+ get-modelview-matrix modelview-matrix-stack get push ;
+
+: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.aqua-star
+
+: tentacle ( -- )
+iterate? [
+ { { 1 [ circle
+ [ .23 y .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .17 y 2 r .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
+ call-random-weighted
+] when ;
+
+: anemone ( -- )
+iterate? [
+ tentacle
+ [ 10 x -11 r .995 s -.002 b anemone ] do
+] when ;
+
+: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -60 140 -120 140 } >viewport
+ 0.1 >threshold
+ [ anemone-begin ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.chiaroscuro
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: white
+
+: black ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
+ { 1 [ white black ] }
+ }
+ rules ;
+
+: white ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
+ { 1 [ black white ] }
+ }
+ rules ;
+
+: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -0.5 b ] >background
+ { -3 6 -2 6 } >viewport
+ 0.03 >threshold
+ [ chiaroscuro ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 2 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { "bundle-name" "cfdg.models.flower6.app" }
+}
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.flower6
+
+: petal6 ( -- )
+iterate? [
+ [ 1 0.001 s* square ] do
+ [ -0.5 x 0.01 s -1 b circle ] do
+ [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
+] when ;
+
+: flower6 ( -- )
+12 [ [ [ 30 r ] times petal6 ] do ] each
+12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -1 2 -1 2 } >viewport
+ 0.01 >threshold
+ [ flower6 ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.game1-turn6
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: f-triangles ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
+ [ 10 hue 0.9 sat 0.33 b triangle ]
+ [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
+ [ 0.8 s 5 r f-triangles ]
+ }
+ rule ;
+
+: f-squares ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
+ [ 220 hue 0.90 sat 0.33 b square ]
+ [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
+ [ 0.8 s 5 r f-squares ]
+ }
+ rule ;
+
+DEFER: start
+
+: spiral ( -- )
+ {
+ { 1 [ f-squares ]
+ [ 0.5 x 0.5 y 45 r f-triangles ]
+ [ 1 y 25 r 0.9 s spiral ] }
+
+ { 0.022 [ 90 flip 50 hue start ] }
+ }
+ rules ;
+
+: start ( -- )
+ [ spiral ] do
+ [ 120 r spiral ] do
+ [ 240 r spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ 66 hue 0.4 sat 0.5 b ] >background
+ { -5 10 -5 10 } >viewport
+ 0.001 >threshold
+ [ start ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.lesson
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shapes ( -- )
+[ square ] do
+[ 0.3 b circle ] do
+[ 0.5 b triangle ] do
+[ 0.7 b 60 r triangle ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-1 ( -- )
+[ 2 x 5 y 3 size square ] do
+[ 6 x 5 y 3 size circle ] do
+[ 4 x 2 y 3 size triangle ] do
+[ 1 y 3 size shapes ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: foursquare ( -- )
+[ 0 x 0 y 5 3 size* square ] do
+[ 0 x 5 y 2 4 size* square ] do
+[ 5 x 5 y 3 size square ] do
+[ 5 x 0 y 2 size square ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-2 ( -- )
+[ square ] do
+[ 3 x 7 y square ] do
+[ 5 x 7 y 30 r square ] do
+[ 3 x 5 y 0.75 size square ] do
+[ 5 x 5 y 0.5 b square ] do
+[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
+[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: spiral ( -- )
+iterate? [
+ [ 0.5 size circle ] do
+ [ 0.2 y -3 r 0.995 size spiral ] do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: tree
+
+: branch-left ( -- )
+{ { 1 [ 20 r tree ] }
+ { 1 [ 30 r tree ] }
+ { 1 [ 40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch-right ( -- )
+{ { 1 [ -20 r tree ] }
+ { 1 [ -30 r tree ] }
+ { 1 [ -40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch ( -- ) branch-left branch-right ;
+
+: tree ( -- )
+iterate? [
+ {
+ { 20 [ [ 0.25 size circle ] do
+ [ 0.1 y 0.97 size tree ] do ] }
+ { 1.5 [ branch ] }
+ } random-weighted* do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-4 ( -- )
+[ 1 x 0 y tree ] do
+[ 6 x 0 y tree ] do
+[ 1 x 4 y tree ] do
+[ 6 x 4 y tree ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: toc ( -- )
+[ 0 x 0 y chapter-1 ] do
+[ 10 x 0 y chapter-2 ] do
+[ 0 x -10 y chapter-3 ] do
+[ 10 x -10 y chapter-4 ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -5 25 -15 25 } >viewport
+ 0.03 >threshold
+ [ toc ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.rules08
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insct ( -- )
+ [ 1.5 5.5 size* -1 brightness triangle ] do
+ 10
+ [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
+ each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: line
+
+: ligne ( -- )
+ {
+ { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
+ { 0.5 [ ] }
+ }
+ rules ;
+
+: line ( -- ) { [ insct ligne ] } rule ;
+
+: sole ( -- )
+ {
+ { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
+ { 0.01 [ ] }
+ }
+ rules ;
+
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } viewport set
+ [ centre ] >start-shape
+ 0.0001 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.sierpinski
+
+: shape ( -- ) circle ;
+
+! : sierpinski ( -- )
+! iterate? [
+! shape
+! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
+! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
+! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
+! ] when ;
+
+: sierpinski ( -- )
+iterate? [
+ shape
+ [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
+ [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
+ [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
+] when ;
+
+: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -4 8 -4 8 } >viewport
+ 0.01 >threshold
+ [ top ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.snowflake
+
+: spike ( -- )
+iterate? [
+ { { 1 [ square
+ [ 0.95 y 0.97 s spike ] do ] }
+ { 0.03 [ square
+ [ 60 r spike ] do
+ [ -60 r spike ] do
+ [ 0.95 y 0.97 s spike ] do ] } }
+ call-random-weighted
+] when ;
+
+: snowflake ( -- )
+spike
+[ 60 r spike ] do
+[ 120 r spike ] do
+[ 180 r spike ] do
+[ 240 r spike ] do
+[ 300 r spike ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -40 80 -40 80 } >viewport
+ 0.1 >threshold
+ [ snowflake ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.spirales
+
+DEFER: line
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
+
+: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
+
+: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } >viewport
+ [ line ] >start-shape
+ 0.04 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Implementation of: http://contextfreeart.org
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences
-quotations math ;
-IN: combinators.lib
-
-HELP: generate
-{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
-{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
-{ $unchecked-example
- "! Generate a random 20-bit prime number congruent to 3 (mod 4)"
- "USING: combinators.lib math math.miller-rabin prettyprint ;"
- "[ 20 random-prime ] [ 4 mod 3 = ] generate ."
- "526367"
-} ;
-
-HELP: %chance
-{ $values { "quot" quotation } { "n" integer } }
-{ $description "Calls the quotation " { $snippet "n" } " percent of the time." }
-{ $unchecked-example
- "USING: io ;"
- "[ \"hello, world! maybe.\" print ] 50 %chance"
- ""
-} ;
+++ /dev/null
-USING: combinators.lib kernel math random sequences tools.test continuations
- arrays vectors ;
-IN: combinators.lib.tests
-
-[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
-[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
-
-[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
-[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
-
-[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
-[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
-
-[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
-[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-
-[ { "foo" "xbarx" } ]
-[
- { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
-] unit-test
-
-{ 1 1 } [
- [ even? ] [ drop 1 ] [ drop 2 ] ifte
-] must-infer-as
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
-! Doug Coleman, Eduardo Cavazos,
-! Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators fry namespaces make quotations hashtables
-sequences assocs arrays stack-checker effects math math.ranges
-generalizations macros continuations random locals accessors ;
-
-IN: combinators.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Currying cleave combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi, ( obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi ; inline
-: tri, ( obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri ; inline
-
-: bi*, ( obj obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi* ; inline
-: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri* ; inline
-
-: bi@, ( obj obj quot -- quot' quot' )
- [ curry ] curry bi@ ; inline
-: tri@, ( obj obj obj quot -- quot' quot' quot' )
- [ curry ] curry tri@ ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Generalized versions of core combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: quad ( x p q r s -- ) [ keep ] 3dip [ keep ] 2dip [ keep ] dip call ; inline
-
-: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
-
-: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
-
-: 2with ( param1 param2 obj quot -- obj curry )
- with with ; inline
-
-: 3with ( param1 param2 param3 obj quot -- obj curry )
- with with with ; inline
-
-: with* ( obj assoc quot -- assoc curry )
- swapd [ [ -rot ] dip call ] 2curry ; inline
-
-: 2with* ( obj1 obj2 assoc quot -- assoc curry )
- with* with* ; inline
-
-: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
- with* with* with* ; inline
-
-: assoc-each-with ( obj assoc quot -- )
- with* assoc-each ; inline
-
-: assoc-map-with ( obj assoc quot -- assoc )
- with* assoc-map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! ifte
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: preserving ( predicate -- quot )
- dup infer in>>
- dup 1+
- '[ _ _ nkeep _ nrot ] ;
-
-MACRO: ifte ( quot quot quot -- )
- '[ _ preserving _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! switch
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: switch ( quot -- )
- [ [ [ preserving ] curry ] dip ] assoc-map
- [ cond ] curry ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Conceptual implementation:
-
-! : pcall ( seq quots -- seq ) [ call ] 2map ;
-
-MACRO: parallel-call ( quots -- )
- [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
- '[ V{ } clone @ nip >array ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! map-call and friends
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (make-call-with) ( quots -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
-
-MACRO: map-call-with ( quots -- )
- [ (make-call-with) ] keep length [ narray ] curry compose ;
-
-: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append ;
-
-MACRO: map-call-with2 ( quots -- )
- [
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append
- ] keep length [ narray ] curry append ;
-
-MACRO: map-exec-with ( words -- )
- [ 1quotation ] map [ map-call-with ] curry ;
-
-MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ new ] curry swap [
- [ dip ] curry swap 1quotation [ keep ] curry compose
- ] { } assoc>map concat compose ;
-
-: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
- >r pick >r with r> r> swapd with ;
-
-MACRO: multikeep ( word out-indexes -- ... )
- [
- dup >r [ \ npick \ >r 3array % ] each
- %
- r> [ drop \ r> , ] each
- ] [ ] make ;
-
-: generate ( generator predicate -- obj )
- '[ dup @ dup [ nip ] unless ]
- swap do until ;
-
-MACRO: predicates ( seq -- quot/f )
- dup [ 1quotation [ drop ] prepend ] map
- [ [ [ dup ] prepend ] map ] dip zip [ drop f ] suffix
- [ cond ] curry ;
-
-: %chance ( quot n -- ) 100 random > swap when ; inline
--- /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: arrays assocs compiler.units
+ grouping help help.markup help.topics kernel lexer multiline
+ namespaces parser sequences splitting words
+ easy-help.expand-markup ;
+
+IN: easy-help
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: parse-text-block ( -- array )
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ expand-markup ] map
+ concat
+ [ dup "" = [ drop { $nl } ] [ ] if ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Text: parse-text-block parsed ; parsing
+
+: Block: scan-word 1array parse-text-block append parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Notes: { $notes } parse-text-block append parsed ; parsing
+: Description: { $description } parse-text-block append parsed ; parsing
+: Contract: { $contract } parse-text-block append parsed ; parsing
+: Checked-Example: { $example } parse-text-block append parsed ; parsing
+
+: Class-Description:
+ { $class-description } parse-text-block append parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Code:
+
+ { $code }
+ parse-text-block [ dup array? [ drop "" ] [ ] if ] map
+ append
+ parsed
+
+ ; parsing
+
+: Example:
+ { $heading "Example" }
+ { $code }
+ parse-text-block
+ [ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
+ append
+ 2array parsed ; parsing
+
+: Introduction:
+
+ { $heading "Introduction" }
+ parse-text-block
+ 2array parsed ; parsing
+
+: Summary:
+
+ { $heading "Summary" }
+ parse-text-block
+ 2array parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Values:
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ " " split1 [ " " first = ] trim-head 2array ] map
+ \ $values prefix
+ parsed
+
+ ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Word:
+
+ scan current-vocab create dup old-definitions get
+ [ delete-at ] with each dup set-word
+
+ bootstrap-word dup set-word
+ dup >link save-location
+ \ ; parse-until >array swap set-word-help ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: List:
+
+ { $list }
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ expand-markup ] map
+
+ append parsed
+
+ ; parsing
--- /dev/null
+
+USING: accessors arrays kernel lexer locals math namespaces parser
+ sequences splitting ;
+
+IN: easy-help.expand-markup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scan-one-array ( string -- array rest )
+ string-lines
+ lexer-factory get call
+ [
+ [
+ \ } parse-until >array
+ lexer get line-text>>
+ lexer get column>> tail
+ ]
+ with-lexer
+ ]
+ with-scope ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: expand-markup ( LINE -- lines )
+
+ LINE contains-markup?
+ [
+
+ [let | N [ "{ $" LINE start ] |
+
+ LINE N head
+
+ LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
+
+ [ 2array ] dip
+
+ expand-markup
+
+ append ]
+
+ ]
+ [ LINE 1array ]
+ if ;
+++ /dev/null
-! Simple IRC bot written in Factor.
-
-REQUIRES: apps/http-server ;
-
-USING: errors generic hashtables help html http io kernel math
-memory namespaces parser prettyprint sequences strings threads
-words inspector network ;
-IN: factorbot
-
-SYMBOL: irc-stream
-SYMBOL: nickname
-SYMBOL: speaker
-SYMBOL: receiver
-
-: irc-write ( s -- ) irc-stream get stream-write ;
-: irc-print ( s -- )
- irc-stream get stream-print
- irc-stream get stream-flush ;
-
-: nick ( nick -- )
- dup nickname set "NICK " irc-write irc-print ;
-
-: login ( nick -- )
- dup nick
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: connect ( server -- ) 6667 <inet> <client> irc-stream set ;
-
-: disconnect ( -- ) irc-stream get stream-close ;
-
-: join ( chan -- )
- "JOIN " irc-write irc-print ;
-
-GENERIC: handle-irc ( line -- )
-PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ;
-PREDICATE: string ping "PING" head? ;
-
-M: object handle-irc ( line -- )
- drop ;
-
-: parse-privmsg ( line -- text )
- " " split1 nip
- "PRIVMSG " ?head drop
- " " split1 swap receiver set
- ":" ?head drop ;
-
-M: privmsg handle-irc ( line -- )
- parse-privmsg
- " " split1 swap
- "factorbot-commands" lookup dup
- [ execute ] [ 2drop ] if ;
-
-M: ping handle-irc ( line -- )
- "PING " ?head drop "PONG " swap append irc-print ;
-
-: parse-irc ( line -- )
- ":" ?head [ "!" split1 swap speaker set ] when handle-irc ;
-
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
-
-: respond ( line -- )
- receiver get nickname get = speaker receiver ? get say ;
-
-: irc-loop ( -- )
- irc-stream get stream-readln
- [ dup print flush parse-irc irc-loop ] when* ;
-
-: factorbot
- "irc.freenode.net" connect
- "factorbot" login
- "#concatenative" join
- [ irc-loop ] [ irc-stream get stream-close ] cleanup ;
-
-: factorbot-loop [ factorbot ] try 30000 sleep factorbot-loop ;
-
-: multiline-respond ( string -- )
- string-lines [ respond ] each ;
-
-: object-href
- "http://factorcode.org" swap browser-link-href append ;
-
-: not-found ( str -- )
- "Sorry, I couldn't find anything for " swap append respond ;
-
-IN: factorbot-commands
-
-: see ( text -- )
- dup words-named dup empty? [
- drop
- not-found
- ] [
- nip [
- dup summary " -- "
- rot object-href 3append respond
- ] each
- ] if ;
-
-: memory ( text -- )
- drop [ room. ] with-string-writer multiline-respond ;
-
-: quit ( text -- )
- drop speaker get "slava" = [ disconnect ] when ;
-
-PROVIDE: apps/factorbot ;
-
-MAIN: apps/factorbot factorbot ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel combinators sequences math math.functions math.vectors mortar
- slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
-IN: factory.commands
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: up-till-frame ( window -- wm-frame )
-{ { [ dup <wm-frame> is? ]
- [ ] }
- { [ dup $dpy $default-root $id over $id = ]
- [ drop f ] }
- { [ t ]
- [ <- parent up-till-frame ] } } cond ;
-
-: pointer-window ( -- window ) dpy> <- pointer-window ;
-
-: pointer-frame ( -- wm-frame )
-pointer-window up-till-frame dup <wm-frame> is? [ ] [ drop f ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: maximize ( -- ) pointer-frame wm-frame-maximize drop ;
-
-: minimize ( -- ) pointer-frame <- unmap drop ;
-
-: maximize-vertical ( -- ) pointer-frame wm-frame-maximize-vertical drop ;
-
-: restore ( -- ) pointer-frame <- restore-state drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-
-: tile-master ( -- )
-
-wm-root>
- <- children
- [ <- mapped? ] filter
- [ check-window-table ] map
- reverse
-
-unclip
- { 0 0 } <-- move
- wm-root> <- size { 1/2 1 } v*
- [ floor ] map <-- resize
- <- adjust-child
-drop
-
-dup empty? [ drop ] [
-
-wm-root> <- width 2 / floor [ <-- set-width ] curry map
-wm-root> <- height over length / floor [ <-- set-height ] curry map
-
-wm-root> <- width 2 / floor [ <-- set-x ] curry map
-
-wm-root> <- height over length / over length [ * floor ] map-with
-[ <-- set-y <- adjust-child ] 2map
-
-drop
-
-] if ;
-
-! : tile-master ( -- )
-
-! wm-root>
-! <- children
-! [ <- mapped? ] filter
-! [ check-window-table ] map
-! reverse
-
-! { { [ dup empty? ] [ drop ] }
-! { [ dup length 1 = ] [ drop maximize ] }
-! { [ t ] [ tile-master* ] }
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel unix vars mortar mortar.sugar slot-accessors
- x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
- factory.commands factory.load ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Helper words
-
-: new-wm-menu ( -- menu ) <wm-menu> new* 1 <-- set-border-width ;
-
-: shrink-wrap ( menu -- ) dup <- calc-size <-- resize drop ;
-
-: set-menu-items ( items menu -- ) swap >>items shrink-wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: apps-menu
-
-apps-menu> not [ new-wm-menu >apps-menu ] when
-
-{ { "Emacs" [ "emacs &" system drop ] }
- { "KMail" [ "kmail &" system drop ] }
- { "Akregator" [ "akregator &" system drop ] }
- { "Amarok" [ "amarok &" system drop ] }
- { "K3b" [ "k3b &" system drop ] }
- { "xchat" [ "xchat &" system drop ] }
- { "Nautilus" [ "nautilus --no-desktop &" system drop ] }
- { "synaptic" [ "gksudo synaptic &" system drop ] }
- { "Volume control" [ "gnome-volume-control &" system drop ] }
- { "Azureus" [ "~/azureus/azureus &" system drop ] }
- { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
- { "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
- { "Stop Firefox" [ "pkill firefox &" system drop ] }
-} apps-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: emacs-menu
-
-emacs-menu> not [ new-wm-menu >emacs-menu ] when
-
-{ { "Start Emacs" [ "emacs &" system drop ] }
- { "Small" [ "emacsclient -e '(make-small-frame-command)' &" system drop ] }
- { "Large" [ "emacsclient -e '(make-frame-command)' &" system drop ] }
- { "Full" [ "emacsclient -e '(make-full-frame-command)' &" system drop ] }
- { "Gnus" [ "emacsclient -e '(gnus-other-frame)' &" system drop ] }
- { "Factor" [ "emacsclient -e '(run-factor-other-frame)' &" system drop ] }
-} emacs-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: mail-menu
-
-mail-menu> not [ new-wm-menu >mail-menu ] when
-
-{ { "Kmail" [ "kmail &" system drop ] }
- { "compose" [ "kmail --composer &" system drop ] }
- { "slava" [ "kmail slava@factorcode.org &" system drop ] }
- { "erg" [ "kmail doug.coleman@gmail.com &" system drop ] }
- { "doublec" [ "kmail chris.double@double.co.nz &" system drop ] }
- { "yuuki" [ "kmail matthew.willis@mac.com &" system drop ] }
-} mail-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factor-menu
-
-factor-menu> not [ new-wm-menu >factor-menu ] when
-
-{ { "Factor" [ "cd /scratch/repos/Factor ; ./factor &" system drop ] }
- { "Factor (tty)"
- [ "cd /scratch/repos/Factor ; xterm -e ./factor -run=listener &"
- system drop ] }
- { "Terminal : repos/Factor"
- [ "cd /scratch/repos/Factor ; xterm &" system drop ] }
- { "darcs whatsnew"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs whatsnew | less' &"
- system drop ] }
- { "darcs pull"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs pull http://factorcode.org/repos' &" system drop ] }
- { "darcs push"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs push dharmatech@onigirihouse.com:doc-root/repos' &" system drop ] }
-} factor-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factory-menu
-
-factory-menu> not [ new-wm-menu >factory-menu ] when
-
-{ { "Maximize" [ maximize ] }
- { "Maximize Vertical" [ maximize-vertical ] }
- { "Restore" [ restore ] }
- { "Hide" [ minimize ] }
- { "Tile Master" [ tile-master ] }
-}
-
-factory-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: root-menu
-
-{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
- { "Firefox" [ "firefox &" system drop ] }
- { "xclock" [ "xclock &" system drop ] }
- { "Apps >" [ apps-menu> <- popup ] }
- { "Factor >" [ factor-menu> <- popup ] }
- { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
- { "Emacs >" [ emacs-menu> <- popup ] }
- { "Mail >" [ mail-menu> <- popup ] }
- { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
- system drop ] }
- { "Edit menus" [ edit-factory-menus ] }
- { "Reload menus" [ load-factory-menus ] }
- { "Factory >" [ factory-menu> <- popup ] }
-} root-menu> set-menu-items
-
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel mortar x
- x.widgets.wm.root
- x.widgets.wm.workspace
- x.widgets.wm.unmapped-frames-menu
- factory.load
- tty-server ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-create-root-menu
-create-unmapped-frames-menu
-load-factory-menus
-6 setup-workspaces
-
-wm-root>
- no-modifiers "F12" [ root-menu> <- popup ] <---- set-key-action
- control-alt "LEFT" [ prev-workspace ] <---- set-key-action
- control-alt "RIGHT" [ next-workspace ] <---- set-key-action
- alt "TAB" [ circulate-focus ] <---- set-key-action
-drop
-
-9010 tty-server
+++ /dev/null
-
-USING: kernel parser io io.files namespaces sequences editors threads vars
- mortar mortar.sugar slot-accessors
- x
- x.widgets.wm.root
- x.widgets.wm.frame
- x.widgets.wm.menu
- factory.load
- factory.commands ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: manage-windows ( -- )
-dpy get $default-root <- children [ <- mapped? ] filter
-[ $id <wm-frame> new* drop ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: root-menu
-
-: create-root-menu ( -- ) <wm-menu> new* 1 <-- set-border-width >root-menu ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-factory ( display-string -- )
-<display> new* >dpy
-install-default-error-handler
-create-wm-root
-init-atoms
-manage-windows
-load-factory-rc ;
-
-: factory ( -- ) f start-factory stop ;
-
-MAIN: factory
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io.files parser editors sequences ;
-
-IN: factory.load
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: file-or ( file file -- file ) over exists? [ drop ] [ nip ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-rc ( -- path ) home "/.factory-rc" append ;
-
-: system-factory-rc ( -- path ) "extra/factory/factory-rc" resource-path ;
-
-: factory-rc ( -- path ) personal-factory-rc system-factory-rc file-or ;
-
-: load-factory-rc ( -- ) factory-rc run-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-menus ( -- path ) home "/.factory-menus" append ;
-
-: system-factory-menus ( -- path )
-"extra/factory/factory-menus" resource-path ;
-
-: factory-menus ( -- path )
-personal-factory-menus system-factory-menus file-or ;
-
-: load-factory-menus ( -- ) factory-menus run-file ;
-
-: edit-factory-menus ( -- ) factory-menus 0 edit-location ;
+++ /dev/null
-Window manager for the X Window System
+++ /dev/null
-applications
--- /dev/null
+
+USING: accessors arrays fry kernel math math.vectors sequences
+ math.intervals
+ multi-methods
+ combinators.short-circuit
+ combinators.cleave.enhanced
+ multi-method-syntax ;
+
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x ( sequence -- x ) first ;
+METHOD: y ( sequence -- y ) second ;
+
+METHOD: (x!) ( number sequence -- ) set-first ;
+METHOD: (y!) ( number sequence -- ) set-second ;
+
+METHOD: width ( sequence -- width ) first ;
+METHOD: height ( sequence -- height ) second ;
+
+: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
+: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
+
+METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
+METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
+
+! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
+! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
+
+! METHOD:: move-left-by ( SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance ( sequence sequence -- dist ) v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+METHOD: x ( <pos> -- x ) pos>> first ;
+METHOD: y ( <pos> -- y ) pos>> second ;
+
+METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
+METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
+
+METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
+METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
+
+METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
+METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
+
+METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
+METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
+
+METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
+
+METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with velocity. It inherits from <pos>. Hey, if
+! it's moving it has a position right? Unless it's some alternate universe...
+
+TUPLE: <vel> < <pos> vel ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+METHOD: width ( <rectangle> -- width ) dim>> first ;
+METHOD: height ( <rectangle> -- height ) dim>> second ;
+
+METHOD: left ( <rectangle> -- x ) x ;
+METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
+METHOD: bottom ( <rectangle> -- y ) y ;
+METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
+
+: bottom-left ( rectangle -- pos ) pos>> ;
+
+: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
+: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
+
+: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
+
+METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
+METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
+
+METHOD: horizontal-interval ( <rectangle> -- interval )
+ \\ left right bi [a,b] ;
+
+METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
+ \\ x horizontal-interval bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom top ;
+
+METHOD: left ( <extent> -- left ) left>> ;
+METHOD: right ( <extent> -- right ) right>> ;
+METHOD: bottom ( <extent> -- bottom ) bottom>> ;
+METHOD: top ( <extent> -- top ) top>> ;
+
+METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
+METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
+
+! METHOD: to-extent ( <rectangle> -- <extent> )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: to-the-left-of? ( sequence <rectangle> -- ? ) \\ x left bi* < ;
+METHOD: to-the-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( sequence <rectangle> -- ? ) \\ y top bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width ( rect -- width ) dim>> first ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left ( rect -- left ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: locals combinators ;
+
+:: wrap ( POINT RECT -- POINT )
+
+ {
+ { [ POINT RECT to-the-left-of? ] [ RECT right ] }
+ { [ POINT RECT to-the-right-of? ] [ RECT left ] }
+ { [ t ] [ POINT x ] }
+ }
+ cond
+
+ {
+ { [ POINT RECT below? ] [ RECT top ] }
+ { [ POINT RECT above? ] [ RECT bottom ] }
+ { [ t ] [ POINT y ] }
+ }
+ cond
+
+ 2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? ( <pos> <rectangle> -- ? )
+ {
+ [ left to-the-right-of? ]
+ [ right to-the-left-of? ]
+ [ bottom above? ]
+ [ top below? ]
+ }
+ 2&& ;
--- /dev/null
+
+USING: accessors alien.c-types combinators grouping kernel
+ locals math math.geometry.rect math.vectors opengl.gl sequences
+ ui.gadgets ui.render ;
+
+IN: frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <frame-buffer> < gadget pixels last-dim ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: update-frame-buffer ( <frame-buffer> -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: draw-pixels ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glDrawPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-pixels ( FRAME-BUFFER -- )
+
+ 0
+ 0
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glReadPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: copy-row ( OLD NEW -- )
+
+ [let | LEN [ OLD NEW min-length ] |
+
+ OLD LEN head-slice 0 NEW copy ] ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
+
+M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
+
+ {
+ {
+ [ FRAME-BUFFER last-dim>> f = ]
+ [
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+ ]
+ }
+ {
+ [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ [let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
+ OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+
+ [let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
+ NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
+ ]
+ }
+ { [ t ] [ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ FRAME-BUFFER draw-pixels
+
+ FRAME-BUFFER update-frame-buffer
+
+ glFlush
+
+ FRAME-BUFFER read-pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: alien.syntax ;
-IN: unix.linux.fs
-
-: MS_RDONLY 1 ; ! Mount read-only.
-: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
-: MS_NODEV 4 ; ! Disallow access to device special files.
-: MS_NOEXEC 8 ; ! Disallow program execution.
-: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
-: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
-: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
-: S_WRITE 128 ; ! Write on file/directory/symlink.
-: S_APPEND 256 ; ! Append-only file.
-: S_IMMUTABLE 512 ; ! Immutable file.
-: MS_NOATIME 1024 ; ! Do not update access times.
-: MS_NODIRATIME 2048 ; ! Do not update directory access times.
-: MS_BIND 4096 ; ! Bind directory at different place.
-
-FUNCTION: int mount
-( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
-
-! FUNCTION: int umount2 ( char* file, int flags ) ;
-
-FUNCTION: int umount ( char* file ) ;
+++ /dev/null
-unportable
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: assocs kernel gap-buffer.cursortree tools.test sequences trees
-arrays strings ;
-IN: gap-buffer.cursortree.tests
-
-[ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
-[ t ] [ "this is a test string" <cursortree> dup length <left-cursor> at-end? ] unit-test
-[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
-[ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
-[ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test
-[ 0 ] [ "this is a test string" <cursortree> dup dup 3 <left-cursor> remove-cursor cursors length ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test
-[ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel gap-buffer generic trees trees.avl math
-sequences quotations ;
-IN: gap-buffer.cursortree
-
-TUPLE: cursortree cursors ;
-
-: <cursortree> ( seq -- cursortree )
- <gb> cursortree new tuck set-delegate <avl>
- over set-cursortree-cursors ;
-
-GENERIC: cursortree-gb ( cursortree -- gb )
-M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
-GENERIC: set-cursortree-gb ( gb cursortree -- )
-M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
-
-TUPLE: cursor i tree ;
-TUPLE: left-cursor ;
-TUPLE: right-cursor ;
-
-: cursor-index ( cursor -- i ) cursor-i ;
-
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
-
-: remove-cursor ( cursortree cursor -- )
- tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
-
-: set-cursor-index ( index cursor -- )
- dup cursor-tree over remove-cursor tuck set-cursor-i
- dup cursor-tree cursortree-cursors swap add-cursor ;
-
-GENERIC: cursor-pos ( cursor -- n )
-GENERIC: set-cursor-pos ( n cursor -- )
-M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
-M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
-M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
-M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
-
-: <cursor> ( cursortree -- cursor )
- cursor new tuck set-cursor-tree ;
-
-: make-cursor ( cursortree pos cursor -- cursor )
- >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
-
-: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor new make-cursor ;
-
-: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor new make-cursor ;
-
-: cursors ( cursortree -- seq )
- cursortree-cursors values concat ;
-
-: cursor-positions ( cursortree -- seq )
- cursors [ cursor-pos ] map ;
-
-M: cursortree move-gap ( n cursortree -- )
- #! Get the position of each cursor before the move, then re-set the
- #! position afterwards. This will update any changed cursor indices.
- dup cursor-positions >r tuck cursortree-gb move-gap
- cursors r> swap [ set-cursor-pos ] 2each ;
-
-: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
-: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
-
-: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
-: at-end? ( cursor -- ? ) element@> length = ;
-
-: insert ( obj cursor -- ) element@> insert* ;
-
-: element< ( cursor -- elem ) element@< nth ;
-: element> ( cursor -- elem ) element@> nth ;
-
-: set-element< ( elem cursor -- ) element@< set-nth ;
-: set-element> ( elem cursor -- ) element@> set-nth ;
-
-GENERIC: fix-cursor ( cursortree cursor -- )
-
-M: left-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-start 1- r> set-cursor-index ;
-
-M: right-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-end r> set-cursor-index ;
-
-: fix-cursors ( old-gap-end cursortree -- )
- tuck cursortree-cursors at [ fix-cursor ] with each ;
-
-M: cursortree delete* ( pos cursortree -- )
- tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
-
-: delete< ( cursor -- ) element@< delete* ;
-: delete> ( cursor -- ) element@> delete* ;
-
+++ /dev/null
-Collection of 'cursors' representing locations in a gap buffer
+++ /dev/null
-USING: kernel sequences tools.test gap-buffer strings math ;
-
-! test copy-elements
-[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
-[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
-[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
-
-! test sequence protocol (like, length, nth, set-nth)
-[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
-
-! test move-gap-back-inside
-[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
-! test move-gap-forward-inside
-[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
-[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
-! test move-gap-back-around
-[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
-! test move-gap-forward-around
-[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
-[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
-
-! test changing buffer contents
-[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
-! test inserting multiple elements in different places. buffer should grow
-[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
-! test deleting elements. buffer should shrink
-[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
-! more testing of nth and set-nth
-[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
-
-! test stack/queue operations
-[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
-[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
-[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
-[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
-[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
-[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
-! for a good introduction see:
-! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
-USING: kernel arrays sequences sequences.private circular math
-math.order math.functions generic ;
-IN: gap-buffer
-
-! gap-start -- the first element of the gap
-! gap-end -- the first element after the gap
-! expand-factor -- should be > 1
-! min-size -- < 5 is not sensible
-
-TUPLE: gb
- gap-start
- gap-end
- expand-factor
- min-size ;
-
-GENERIC: gb-seq ( gb -- seq )
-GENERIC: set-gb-seq ( seq gb -- )
-M: gb gb-seq ( gb -- seq ) delegate ;
-M: gb set-gb-seq ( seq gb -- ) set-delegate ;
-
-: required-space ( n gb -- n )
- tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
-
-: <gb> ( seq -- gb )
- gb new
- 5 over set-gb-min-size
- 1.5 over set-gb-expand-factor
- [ >r length r> set-gb-gap-start ] 2keep
- [ swap length over required-space swap set-gb-gap-end ] 2keep
- [
- over length over required-space rot { } like resize-array <circular> swap set-gb-seq
- ] keep ;
-
-M: gb like ( seq gb -- seq ) drop <gb> ;
-
-: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
-
-: buffer-length ( gb -- n ) gb-seq length ;
-
-M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
-
-: valid-position? ( pos gb -- ? )
- #! one element past the end of the buffer is a valid position when we're inserting
- length -1 swap between? ;
-
-: valid-index? ( i gb -- ? )
- buffer-length -1 swap between? ;
-
-TUPLE: position-out-of-bounds position gap-buffer ;
-C: <position-out-of-bounds> position-out-of-bounds
-
-: position>index ( pos gb -- i )
- 2dup valid-position? [
- 2dup gb-gap-start >= [
- gap-length +
- ] [ drop ] if
- ] [
- <position-out-of-bounds> throw
- ] if ;
-
-TUPLE: index-out-of-bounds index gap-buffer ;
-C: <index-out-of-bounds> index-out-of-bounds
-
-: index>position ( i gb -- pos )
- 2dup valid-index? [
- 2dup gb-gap-end >= [
- gap-length -
- ] [ drop ] if
- ] [
- <index-out-of-bounds> throw
- ] if ;
-
-M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
-
-M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
-
-M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
-
-M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
-
-M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
-
-M: gb virtual-seq gb-seq ;
-
-INSTANCE: gb virtual-sequence
-
-! ------------- moving the gap -------------------------------
-
-: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
-
-: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
-
-: copy-elements-back ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
- ] [ 3drop drop ] if ;
-
-: copy-elements-forward ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
- ] [ 3drop drop ] if ;
-
-: copy-elements ( dst start end seq -- )
- pick pick > [
- >r dupd - r> swap copy-elements-forward
- ] [
- >r over - r> swap copy-elements-back
- ] if ;
-
-! the gap can be moved either forward or back. Moving the gap 'inside' means
-! moving elements across the gap. Moving the gap 'around' means changing the
-! start of the circular buffer to avoid moving as many elements.
-
-! We decide which method (inside or around) to pick based on the number of
-! elements that will need to be moved. We always try to move as few elements as
-! possible.
-
-: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
-
-: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
-
-: move-gap-back-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
-
-: move-gap-forward-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
-
-: move-gap-forward-inside ( i gb -- )
- [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
-
-: move-gap-back-inside ( i gb -- )
- [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
-
-: move-gap-forward-around ( i gb -- )
- 0 over move-gap-back-inside [
- dup buffer-length [
- swap gap-length - neg swap
- ] keep
- ] keep [
- gb-seq copy-elements
- ] keep dup gap-length swap gb-seq change-circular-start ;
-
-: move-gap-back-around ( i gb -- )
- dup buffer-length over move-gap-forward-inside [
- length swap -1
- ] keep [
- gb-seq copy-elements
- ] keep dup length swap gb-seq change-circular-start ;
-
-: move-gap-forward ( i gb -- )
- move-gap-forward-inside? [
- move-gap-forward-inside
- ] [
- move-gap-forward-around
- ] if ;
-
-: move-gap-back ( i gb -- )
- move-gap-back-inside? [
- move-gap-back-inside
- ] [
- move-gap-back-around
- ] if ;
-
-: (move-gap) ( i gb -- )
- move-gap? [
- move-gap-forward? [
- move-gap-forward
- ] [
- move-gap-back
- ] if
- ] [ 2drop ] if ;
-
-: fix-gap ( n gb -- )
- 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
-
-! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
-GENERIC: move-gap ( n gb -- )
-
-M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
-
-! ------------ resizing -------------------------------------
-
-: enough-room? ( n gb -- ? )
- #! is there enough room to add 'n' elements to gb?
- tuck length + swap buffer-length <= ;
-
-: set-new-gap-end ( array gb -- )
- [ buffer-length swap length swap - ] keep
- [ gb-gap-end + ] keep set-gb-gap-end ;
-
-: after-gap ( gb -- gb )
- dup gb-seq swap gb-gap-end tail ;
-
-: before-gap ( gb -- gb )
- dup gb-gap-start head ;
-
-: copy-after-gap ( array gb -- )
- #! copy everything after the gap in 'gb' into the end of 'array',
- #! and change 'gb's gap-end to reflect the gap-end in 'array'
- dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
-
-: copy-before-gap ( array gb -- )
- #! copy everything before the gap in 'gb' into the start of 'array'
- before-gap 0 rot copy ; ! gap start doesn't change
-
-: resize-buffer ( gb new-size -- )
- f <array> swap 2dup copy-before-gap 2dup copy-after-gap
- >r <circular> r> set-gb-seq ;
-
-: decrease-buffer-size ( gb -- )
- #! the gap is too big, so resize to something sensible
- dup length over required-space resize-buffer ;
-
-: increase-buffer-size ( n gb -- )
- #! increase the buffer to fit at least 'n' more elements
- tuck length + over required-space resize-buffer ;
-
-: gb-too-big? ( gb -- ? )
- dup buffer-length over gb-min-size > [
- dup length over buffer-length rot gb-expand-factor sq / <
- ] [ drop f ] if ;
-
-: ?decrease ( gb -- )
- dup gb-too-big? [
- decrease-buffer-size
- ] [ drop ] if ;
-
-: ensure-room ( n gb -- )
- #! ensure that ther will be enough room for 'n' more elements
- 2dup enough-room? [ 2drop ] [
- increase-buffer-size
- ] if ;
-
-! ------- editing operations ---------------
-
-GENERIC# insert* 2 ( seq position gb -- )
-
-: prepare-insert ( seq position gb -- seq gb )
- tuck move-gap over length over ensure-room ;
-
-: insert-elements ( seq gb -- )
- dup gb-gap-start swap gb-seq copy ;
-
-: increment-gap-start ( gb n -- )
- over gb-gap-start + swap set-gb-gap-start ;
-
-! generic dispatch identifies numbers as sequences before numbers...
-! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
-: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
-
-M: sequence insert* ( seq position gb -- )
- pick number? [
- number-insert
- ] [
- prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
- ] if ;
-
-: (delete*) ( gb -- )
- dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
-
-GENERIC: delete* ( pos gb -- )
-
-M: gb delete* ( position gb -- )
- tuck move-gap (delete*) ;
-
-! -------- stack/queue operations -----------
-
-: push-start ( obj gb -- ) 0 swap insert* ;
-
-: push-end ( obj gb -- ) [ length ] keep insert* ;
-
-: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
-
-: pop-start ( gb -- elem ) 0 swap pop-elem ;
-
-: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
-
-: rotate ( n gb -- )
- dup length 1 > [
- swap dup 0 > [
- [ dup [ pop-end ] keep push-start ]
- ] [
- neg [ dup [ pop-start ] keep push-end ]
- ] if times drop
- ] [ 2drop ] if ;
-
+++ /dev/null
-Gap buffer data structure
+++ /dev/null
-collections
-sequences
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: sequences mortar slot-accessors ;
-
-IN: geom.dim
-
-SYMBOL: <dim>
-
-<dim> { "dim" } accessors define-independent-class
-
-<dim> {
-
-"width" !( dim -- width ) [ $dim first ]
-
-"height" !( dim -- second ) [ $dim second ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays sequences math.vectors mortar slot-accessors ;
-
-IN: geom.pos
-
-SYMBOL: <pos>
-
-<pos> { "pos" } accessors define-independent-class
-
-<pos> {
-
-"x" !( pos -- x ) [ $pos first ]
-
-"y" !( pos -- y ) [ $pos second ]
-
-"set-x" !( pos x -- pos ) [ 0 pick $pos set-nth ]
-
-"set-y" !( pos y -- pos ) [ 1 pick $pos set-nth ]
-
-"distance" !( pos pos -- distance ) [ $pos swap $pos v- norm ]
-
-"move-by" !( pos offset -- pos ) [ over $pos v+ >>pos ]
-
-"move-by-x" !( pos x-offset -- pos ) [ 0 2array <-- move-by ]
-
-"move-by-y" !( pos y-offset -- pos ) [ 0 swap 2array <-- move-by ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math.vectors
- mortar slot-accessors geom.pos geom.dim ;
-
-IN: geom.rect
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: math
-
-: v+y ( pos y -- pos ) 0 swap 2array v+ ;
-
-: v-y ( pos y -- pos ) 0 swap 2array v- ;
-
-: v+x ( pos x -- pos ) 0 2array v+ ;
-
-: v-x ( pos x -- pos ) 0 2array v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <rect>
-
-<rect>
- <pos> class-slots <dim> class-slots append
- <pos> class-methods <dim> class-methods append { H{ } } append
- { H{ } }
-4array <rect> set-global
-
-! { 0 0 } { 0 0 } <rect> new
-
-<rect> {
-
-"top-left" !( rect -- point ) [ $pos ]
-
-"top-right" !( rect -- point ) [ dup $pos swap <- width 1- v+x ]
-
-"bottom-left" !( rect -- point ) [ dup $pos swap <- height 1- v+y ]
-
-"bottom-right" !( rect -- point ) [ dup $pos swap $dim { 1 1 } v- v+ ]
-
-} add-methods
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Golden Section" }
+}
--- /dev/null
+
+USING: kernel namespaces math math.constants math.functions math.order
+ arrays sequences
+ opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
+ ui.gadgets.cartesian colors accessors combinators.cleave
+ processing.shapes ;
+
+IN: golden-section
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! omega(i) = 2*pi*i*(phi-1)
+
+! x(i) = 0.5*i*cos(omega(i))
+! y(i) = 0.5*i*sin(omega(i))
+
+! radius(i) = 10*sin((pi*i)/720)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: omega ( i -- omega ) phi 1- * 2 * pi * ;
+
+: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
+: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
+
+: center ( i -- point ) { x y } 1arr ;
+
+: radius ( i -- radius ) pi * 720 / sin 10 * ;
+
+: color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ;
+
+: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;
+
+: draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ;
+
+: dot ( i -- ) color line-width draw ;
+
+: golden-section ( -- ) 720 [ dot ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <golden-section> ( -- gadget )
+ <cartesian>
+ { 600 600 } >>pdim
+ { -400 400 } x-range
+ { -400 400 } y-range
+ [ golden-section ] >>action ;
+
+: golden-section-window ( -- )
+ [ <golden-section> "Golden Section" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: golden-section-window
--- /dev/null
+Golden section demo
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Coyright (C) 2007 Adam Wendt
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup ;
-IN: id3
-
-ARTICLE: "id3-tags" "ID3 Tags"
-"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."
-{ $subsection id3v2 }
-{ $subsection read-tag }
-{ $subsection id3v2? }
-{ $subsection read-id3v2 } ;
-
-ABOUT: "id3-tags"
-
-HELP: id3v2
-{ $values { "filename" "a pathname string" } { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if file does not start with an ID3 tag." } ;
-
-HELP: read-tag
-{ $values { "stream" "a stream" } { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if stream does not start with an ID3 tag." } ;
-
-HELP: id3v2?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if the current input stream begins with an ID3 tag." } ;
-
-HELP: read-id3v2
-{ $values { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if the current input stream does not start with an ID3 tag." } ;
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: arrays combinators io io.binary io.files io.paths
-io.encodings.utf16 kernel math math.parser namespaces sequences
-splitting strings assocs unicode.categories io.encodings.binary ;
-
-IN: id3
-
-TUPLE: tag header frames ;
-C: <tag> tag
-
-TUPLE: header version revision flags size extended-header ;
-C: <header> header
-
-TUPLE: frame id size flags data ;
-C: <frame> frame
-
-TUPLE: extended-header size flags update crc restrictions ;
-C: <extended-header> extended-header
-
-: debug-stream ( msg -- )
-! global [ . flush ] bind ;
- drop ;
-
-: >hexstring ( str -- hex )
- >array [ >hex 2 CHAR: 0 pad-left ] map concat ;
-
-: good-frame-id? ( id -- ? )
- [ [ LETTER? ] keep digit? or ] all? ;
-
-! 4 byte syncsafe integer (28 effective bits)
-: >syncsafe ( seq -- int )
- 0 [ >r 7 shift r> bitor ] reduce ;
-
-: read-size ( -- size )
- 4 read >syncsafe ;
-
-: read-frame-id ( -- id )
- 4 read ;
-
-: read-frame-flags ( -- flags )
- 2 read ;
-
-: read-frame-size ( -- size )
- 4 read be> ;
-
-: text-frame? ( id -- ? )
- "T" head? ;
-
-: read-text ( size -- text )
- read1 swap 1 - read swap 1 = [ decode-utf16 ] [ ] if
- "\0" ?tail drop ; ! remove null terminator
-
-: read-popm ( size -- popm )
- read-text ;
-
-: read-frame-data ( id size -- data )
- swap
- {
- { [ dup text-frame? ] [ drop read-text ] }
- { [ "POPM" = ] [ read-popm ] }
- { [ t ] [ read ] }
- } cond ;
-
-: (read-frame) ( id -- frame )
- read-frame-size read-frame-flags 2over read-frame-data <frame> ;
-
-: read-frame ( -- frame/f )
- read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ;
-
-: (read-frames) ( vector -- frames )
- read-frame [ over push (read-frames) ] when* ;
-
-: read-frames ( -- frames )
- V{ } clone (read-frames) ;
-
-: read-eh-flags ( -- flags )
- read1 read le> ;
-
-: read-eh-data ( size -- data )
- 6 - read ;
-
-: read-crc ( flags -- crc )
- 5 bit? [ read1 read >syncsafe ] [ f ] if ;
-
-: tag-is-update? ( flags -- ? )
- 6 bit? dup [ read1 drop ] [ ] if ;
-
-: (read-tag-restrictions) ( -- restrictions )
- read1 dup read le> ;
-
-: read-tag-restrictions ( flags -- restrictions/f )
- 4 bit? [ (read-tag-restrictions) ] [ f ] if ;
-
-: (read-extended-header) ( -- extended-header )
- read-size read-eh-flags dup tag-is-update? over dup
- read-crc swap read-tag-restrictions <extended-header> ;
-
-: read-extended-header ( flags -- extended-header/f )
- 6 bit? [ (read-extended-header) ] [ f ] if ;
-
-: read-header ( version -- header )
- read1 read1 read-size over read-extended-header <header> ;
-
-: (read-id3v2) ( version -- tag )
- read-header read-frames <tag> ;
-
-: supported-version? ( version -- ? )
- { 3 4 } member? ;
-
-: read-id3v2 ( -- tag/f )
- read1 dup supported-version?
- [ (read-id3v2) ] [ drop f ] if ;
-
-: id3v2? ( -- ? )
- 3 read "ID3" sequence= ;
-
-: read-tag ( stream -- tag/f )
- id3v2? [ read-id3v2 ] [ f ] if ;
-
-: id3v2 ( filename -- tag/f )
- binary [ read-tag ] with-file-reader ;
-
-: file? ( path -- ? )
- stat 3drop not ;
-
-: files ( paths -- files )
- [ file? ] subset ;
-
-: mp3? ( path -- ? )
- ".mp3" tail? ;
-
-: mp3s ( paths -- mp3s )
- [ mp3? ] subset ;
-
-: id3? ( file -- ? )
- binary [ id3v2? ] with-file-reader ;
-
-: id3s ( files -- id3s )
- [ id3? ] subset ;
-
+++ /dev/null
-ID3 music file tag parser
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.if
-
-: IFNAMSIZ 16 ;
-: IF_NAMESIZE 16 ;
-: IFHWADDRLEN 6 ;
-
-! Standard interface flags (netdevice->flags)
-
-: IFF_UP HEX: 1 ; ! interface is up
-: IFF_BROADCAST HEX: 2 ; ! broadcast address valid
-: IFF_DEBUG HEX: 4 ; ! turn on debugging
-: IFF_LOOPBACK HEX: 8 ; ! is a loopback net
-: IFF_POINTOPOINT HEX: 10 ; ! interface is has p-p link
-: IFF_NOTRAILERS HEX: 20 ; ! avoid use of trailers
-: IFF_RUNNING HEX: 40 ; ! interface running and carrier ok
-: IFF_NOARP HEX: 80 ; ! no ARP protocol
-: IFF_PROMISC HEX: 100 ; ! receive all packets
-: IFF_ALLMULTI HEX: 200 ; ! receive all multicast packets
-
-: IFF_MASTER HEX: 400 ; ! master of a load balancer
-: IFF_SLAVE HEX: 800 ; ! slave of a load balancer
-
-: IFF_MULTICAST HEX: 1000 ; ! Supports multicast
-
-! #define IFF_VOLATILE
-! (IFF_LOOPBACK|IFF_POINTOPOINT|IFF_BROADCAST|IFF_MASTER|IFF_SLAVE|IFF_RUNNING)
-
-: IFF_PORTSEL HEX: 2000 ; ! can set media type
-: IFF_AUTOMEDIA HEX: 4000 ; ! auto media select active
-: IFF_DYNAMIC HEX: 8000 ; ! dialup device with changing addresses
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-STRUCT: struct-ifmap
- { "ulong" "mem-start" }
- { "ulong" "mem-end" }
- { "ushort" "base-addr" }
- { "uchar" "irq" }
- { "uchar" "dma" }
- { "uchar" "port" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Hmm... the generic sockaddr type isn't defined anywhere.
-! Put it here for now.
-
-TYPEDEF: ushort sa_family_t
-
-C-STRUCT: struct-sockaddr
- { "sa_family_t" "sa_family" }
- { { "char" 14 } "sa_data" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! C-UNION: union-ifr-ifrn { "char" IFNAMSIZ } ;
-
-C-UNION: union-ifr-ifrn { "char" 16 } ;
-
-C-UNION: union-ifr-ifru
- "struct-sockaddr"
-! "sockaddr"
- "short"
- "int"
- "struct-ifmap"
-! { "char" IFNAMSIZ }
- { "char" 16 }
- "caddr_t" ;
-
-C-STRUCT: struct-ifreq
- { "union-ifr-ifrn" "ifr-ifrn" }
- { "union-ifr-ifru" "ifr-ifru" } ;
-
-: ifr-name ( struct-ifreq -- value ) struct-ifreq-ifr-ifrn ;
-
-: ifr-hwaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-addr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-dstaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-broadaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-netmask ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-flags ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-UNION: union-ifc-ifcu "caddr_t" "struct-ifreq*" ;
-
-C-STRUCT: struct-ifconf
- { "int" "ifc-len" }
- { "union-ifc-ifcu" "ifc-ifcu" } ;
-
-: ifc-len ( struct-ifconf -- value ) struct-ifconf-ifc-len ;
-
-: ifc-buf ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ;
-: ifc-req ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien alien.c-types
- io.sockets
- unix
- unix.linux.sockios
- unix.linux.if ;
-
-IN: unix.linux.ifreq
-
-: set-if-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-flags ( name flags -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap <short> over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-dst-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-brd-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-netmask ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-metric ( name metric -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap <int> over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ;
\ No newline at end of file
+++ /dev/null
-unportable
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
+\r
+IN: irc.ui.commandparser\r
+\r
+: command ( string string -- string command )\r
+ [ "say" ] when-empty\r
+ dup "irc.ui.commands" lookup\r
+ [ nip ]\r
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
+\r
+: parse-message ( string -- )\r
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel sequences arrays irc.client\r
+ irc.messages irc.ui namespaces ;\r
+\r
+IN: irc.ui.commands\r
+\r
+: say ( string -- )\r
+ irc-tab get\r
+ [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
+ [ chat>> speak ] 2bi ;\r
+\r
+: me ( string -- ) ! Placeholder until I make /me look different\r
+ "ACTION " 1 prefix prepend 1 suffix say ;\r
+\r
+: join ( string -- )\r
+ irc-tab get window>> join-channel ;\r
+\r
+: query ( string -- )\r
+ irc-tab get window>> query-nick ;\r
+\r
+: whois ( string -- )\r
+ "WHOIS" swap { } clone swap <irc-client-message>\r
+ irc-tab get listener>> speak ;\r
+\r
+: quote ( string -- )\r
+ drop ; ! THIS WILL CHANGE\r
--- /dev/null
+! Default system ircui-rc file\r
+! Copy into .ircui-rc in your home directory and then change username and such\r
+! To find your home directory, type "home ." into a Factor listener\r
+\r
+USING: irc.client irc.ui ;\r
+\r
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
+server-open\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel io.files io.pathnames parser editors sequences ;\r
+\r
+IN: irc.ui.load\r
+\r
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
+\r
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
+\r
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
+\r
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
+\r
+: run-ircui ( -- ) ircui-rc run-file ;\r
--- /dev/null
+A simple IRC client
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel threads combinators concurrency.mailboxes\r
+ sequences strings hashtables splitting fry assocs hashtables colors\r
+ sorting unicode.collation math.order\r
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models continuations\r
+ irc.client irc.client.private irc.messages\r
+ irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
+\r
+RENAME: join sequences => sjoin\r
+\r
+IN: irc.ui\r
+\r
+SYMBOL: chat\r
+\r
+SYMBOL: client\r
+\r
+TUPLE: ui-window < tabbed client ;\r
+\r
+M: ui-window ungraft*\r
+ client>> terminate-irc ;\r
+\r
+TUPLE: irc-tab < frame chat client window ;\r
+\r
+: write-color ( str color -- )\r
+ foreground associate format ;\r
+CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
+CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
+CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
+\r
+: dot-or-parens ( string -- string )\r
+ [ "." ]\r
+ [ "(" prepend ")" append ] if-empty ;\r
+\r
+GENERIC: write-irc ( irc-message -- )\r
+\r
+M: ping write-irc\r
+ drop "* Ping" blue write-color ;\r
+\r
+M: privmsg write-irc\r
+ "<" dark-blue write-color\r
+ [ irc-message-sender write ] keep\r
+ "> " dark-blue write-color\r
+ trailing>> write ;\r
+\r
+M: notice write-irc\r
+ [ type>> dark-blue write-color ] keep\r
+ ": " dark-blue write-color\r
+ trailing>> write ;\r
+\r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+ now own-message boa ;\r
+\r
+M: own-message write-irc\r
+ "<" dark-blue write-color\r
+ [ nick>> bold font-style associate format ] keep\r
+ "> " dark-blue write-color\r
+ message>> write ;\r
+\r
+M: join write-irc\r
+ "* " dark-green write-color\r
+ irc-message-sender write\r
+ " has entered the channel." dark-green write-color ;\r
+\r
+M: part write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has left the channel" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: quit write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has left IRC" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: kick write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has kicked " dark-red write-color\r
+ [ who>> write ] keep\r
+ " from the channel" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: mode write-irc\r
+ "* " dark-blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " dark-blue write-color\r
+ [ mode>> write ] keep\r
+ " to " dark-blue write-color\r
+ parameter>> write ;\r
+\r
+M: nick write-irc\r
+ "* " dark-blue write-color\r
+ [ irc-message-sender write ] keep\r
+ " is now known as " blue write-color\r
+ trailing>> write ;\r
+\r
+M: unhandled write-irc\r
+ "UNHANDLED: " write\r
+ line>> dark-blue write-color ;\r
+\r
+M: irc-end write-irc\r
+ drop "* You have left IRC" dark-red write-color ;\r
+\r
+M: irc-disconnected write-irc\r
+ drop "* Disconnected" dark-red write-color ;\r
+\r
+M: irc-connected write-irc\r
+ drop "* Connected" dark-green write-color ;\r
+\r
+M: irc-chat-end write-irc\r
+ drop ;\r
+\r
+M: irc-message write-irc\r
+ "UNIMPLEMENTED" write\r
+ [ class pprint ] keep\r
+ ": " write\r
+ line>> dark-blue write-color ;\r
+\r
+GENERIC: time-happened ( message -- timestamp )\r
+\r
+M: irc-message time-happened timestamp>> ;\r
+\r
+M: object time-happened drop now ;\r
+\r
+: print-irc ( irc-message -- )\r
+ [ time-happened timestamp>hms write " " write ]\r
+ [ write-irc nl ] bi ;\r
+\r
+: send-message ( message -- )\r
+ [ print-irc ]\r
+ [ chat get speak ] bi ;\r
+\r
+GENERIC: handle-inbox ( tab message -- )\r
+\r
+: value-labels ( assoc val -- seq )\r
+ '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
+\r
+: add-gadget-color ( pack seq color -- pack )\r
+ '[ _ >>color add-gadget ] each ;\r
+\r
+M: object handle-inbox\r
+ nip print-irc ;\r
+\r
+: display ( stream tab -- )\r
+ '[ _ [ [ t ]\r
+ [ _ dup chat>> hear handle-inbox ]\r
+ while ] with-output-stream ] "ircv" spawn drop ;\r
+\r
+: <irc-pane> ( tab -- tab pane )\r
+ <scrolling-pane>\r
+ [ <pane-stream> swap display ] 2keep ;\r
+\r
+TUPLE: irc-editor < editor outstream tab ;\r
+\r
+: <irc-editor> ( tab pane -- tab editor )\r
+ irc-editor new-editor\r
+ swap <pane-stream> >>outstream ;\r
+\r
+: editor-send ( irc-editor -- )\r
+ { [ outstream>> ]\r
+ [ [ irc-tab? ] find-parent ]\r
+ [ editor-string ]\r
+ [ "" swap set-editor-string ] } cleave\r
+ '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
+\r
+irc-editor "general" f {\r
+ { T{ key-down f f "RET" } editor-send }\r
+ { T{ key-down f f "ENTER" } editor-send }\r
+} define-command-map\r
+\r
+: new-irc-tab ( chat ui-window class -- irc-tab )\r
+ new-frame\r
+ swap >>window\r
+ swap >>chat\r
+ <irc-pane> [ <scroller> @center grid-add ] keep\r
+ <irc-editor> <scroller> @bottom grid-add ;\r
+\r
+M: irc-tab graft*\r
+ [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
+\r
+M: irc-tab ungraft*\r
+ chat>> detach-chat ;\r
+\r
+TUPLE: irc-channel-tab < irc-tab userlist ;\r
+\r
+: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
+ irc-channel-tab new-irc-tab\r
+ <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
+\r
+: update-participants ( tab -- )\r
+ [ userlist>> [ clear-gadget ] keep ]\r
+ [ chat>> participants>> ] bi\r
+ [ +operator+ value-labels dark-green add-gadget-color ]\r
+ [ +voice+ value-labels blue add-gadget-color ]\r
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
+\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
+\r
+TUPLE: irc-server-tab < irc-tab ;\r
+\r
+: <irc-server-tab> ( chat -- irc-tab )\r
+ f irc-server-tab new-irc-tab ;\r
+\r
+: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
+ irc-tab new-irc-tab ;\r
+\r
+M: irc-tab pref-dim*\r
+ drop { 480 480 } ;\r
+\r
+: join-channel ( name ui-window -- )\r
+ [ dup <irc-channel-chat> ] dip\r
+ [ <irc-channel-tab> swap ] keep\r
+ add-page ;\r
+\r
+: query-nick ( nick ui-window -- )\r
+ [ dup <irc-nick-chat> ] dip\r
+ [ <irc-nick-tab> swap ] keep\r
+ add-page ;\r
+\r
+: irc-window ( ui-window -- )\r
+ [ ]\r
+ [ client>> profile>> server>> ] bi\r
+ open-window ;\r
+\r
+: ui-connect ( profile -- ui-window )\r
+ <irc-client>\r
+ { [ [ <irc-server-chat> ] dip attach-chat ]\r
+ [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
+ "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
+ [ >>client ]\r
+ [ connect-irc ] } cleave ;\r
+\r
+: server-open ( server port nick password channels -- )\r
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
+ [ over join-channel ] each drop ;\r
+\r
+: main-run ( -- ) run-ircui ;\r
+\r
+MAIN: main-run\r
+\r
+"irc.ui.commands" require\r
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-: units-per-full-roll ( -- n ) 50 ;
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint
-jamshred.player jamshred.tunnel kernel math math.constants
-math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays.float ;
-IN: jamshred.gl
-
-: min-vertices 6 ; inline
-: max-vertices 32 ; inline
-
-: n-vertices ( -- n ) 32 ; inline
-
-! render enough of the tunnel that it looks continuous
-: n-segments-ahead ( -- n ) 60 ; inline
-: n-segments-behind ( -- n ) 40 ; inline
-
-: wall-drawing-offset ( -- n )
- #! so that we can't see through the wall, we draw it a bit further away
- 0.15 ;
-
-: wall-drawing-radius ( segment -- r )
- radius>> wall-drawing-offset + ;
-
-: wall-up ( segment -- v )
- [ wall-drawing-radius ] [ up>> ] bi n*v ;
-
-: wall-left ( segment -- v )
- [ wall-drawing-radius ] [ left>> ] bi n*v ;
-
-: segment-vertex ( theta segment -- vertex )
- [
- [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
- ] [
- location>> v+
- ] bi ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-
-: draw-segment-vertex ( segment theta -- )
- over color>> gl-color segment-vertex-and-normal
- gl-normal gl-vertex ;
-
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians F{ 0.0 } append swap each
- ] do-state ;
-
-: draw-segments ( segments -- )
- 1 over length pick subseq swap [ draw-segment ] 2each ;
-
-: segments-to-render ( player -- segments )
- dup nearest-segment>> number>> dup n-segments-behind -
- swap n-segments-ahead + rot tunnel>> sub-tunnel ;
-
-: draw-tunnel ( player -- )
- segments-to-render draw-segments ;
-
-: init-graphics ( width height -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode glLoadIdentity
- dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
- GL_MODELVIEW glMatrixMode glLoadIdentity
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_FOG glEnable
- GL_FOG_DENSITY 0.09 glFogf
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
-
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
-IN: jamshred
-
-TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
-
-: <jamshred-gadget> ( jamshred -- gadget )
- jamshred-gadget new-gadget swap >>jamshred ;
-
-: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 600 ;
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ 10 milliseconds sleep yield jamshred-loop ] tri
- ] if ;
-
-: fullscreen ( gadget -- )
- find-world t swap set-fullscreen* ;
-
-: no-fullscreen ( gadget -- )
- find-world f swap set-fullscreen* ;
-
-: toggle-fullscreen ( world -- )
- [ fullscreen? not ] keep set-fullscreen* ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ jamshred-loop ] curry in-thread ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- jamshred>> t swap (>>quit) ;
-
-: jamshred-restart ( jamshred-gadget -- )
- <jamshred> >>jamshred drop ;
-
-: pix>radians ( n m -- theta )
- / pi 4 * * ; ! 2 / / pi 2 * * ;
-
-: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
- rect-dim first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- rect-dim second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- over jamshred>> >r
- [ first swap x>radians ] 2keep second swap y>radians
- r> mouse-moved ;
-
-: handle-mouse-motion ( jamshred-gadget -- )
- hand-loc get [
- over last-hand-loc>> [
- v- (handle-mouse-motion)
- ] [ 2drop ] if*
- ] 2keep >>last-hand-loc drop ;
-
-: handle-mouse-scroll ( jamshred-gadget -- )
- jamshred>> scroll-direction get
- [ first mouse-scroll-x ]
- [ second mouse-scroll-y ] 2bi ;
-
-: quit ( gadget -- )
- [ no-fullscreen ] [ close-window ] bi ;
-
-jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart ] }
- { T{ key-down f f " " } [ jamshred>> toggle-running ] }
- { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
- { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
- { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
- { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
- { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
- { T{ key-down f f "q" } [ quit ] }
- { T{ motion } [ handle-mouse-motion ] }
- { T{ mouse-scroll } [ handle-mouse-scroll ] }
-} set-gestures
-
-: jamshred-window ( -- gadget )
- [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
-
-MAIN: jamshred-window
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ;
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
-IN: jamshred.player
-
-TUPLE: player < oint
- { name string }
- { sounds sounds }
- tunnel
- nearest-segment
- { last-move integer }
- { speed float } ;
-
-! speeds are in GL units / second
-: default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 30.0 ;
-
-: <player> ( name sounds -- player )
- [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
- f f 0 default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- >r over r> left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-nearest-segment ( player -- )
- [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
- [ (>>nearest-segment) ] tri ;
-
-: update-time ( player -- seconds-passed )
- millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) millis swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
-
-: distance-to-move ( seconds-passed player -- distance )
- speed>> * ;
-
-: bounce ( d-left player -- d-left' player )
- {
- [ dup nearest-segment>> bounce-off-wall ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ ]
- } cleave ;
-
-:: (distance) ( heading player -- current next location heading )
- player nearest-segment>>
- player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
- player location>> heading ;
-
-: distance-to-heading-segment ( heading player -- distance )
- (distance) distance-to-next-segment ;
-
-: distance-to-heading-segment-area ( heading player -- distance )
- (distance) distance-to-next-segment-area ;
-
-: distance-to-collision ( player -- distance )
- dup nearest-segment>> (distance-to-collision) ;
-
-: almost-to-collision ( player -- distance )
- distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
-
-: distance-to-move-freely ( player -- distance )
- [ almost-to-collision ]
- [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- ! must make sure we are moving a significant distance, otherwise
- ! we can recurse endlessly due to floating-point imprecision.
- ! (at least I /think/ that's what causes it...)
- dup distance-to-move-freely dup 0.1 > [
- over forward>> move-player-on-heading ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.files kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
-IN: jamshred.tunnel.tests
-
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
- T{ segment f { 1 1 1 } f f f 1 }
- T{ oint f { 0 0 0.25 } }
- nearer-segment number>> ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
-
-[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
-
-: test-segment-oint ( -- oint )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
-
-: simple-collision-up ( -- oint segment )
- { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
-[ { 0.0 1.0 0.0 } ]
-[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators float-arrays kernel
-locals math math.constants math.matrices math.order math.ranges
-math.vectors math.quadratic random sequences vectors jamshred.oint ;
-IN: jamshred.tunnel
-
-: n-segments ( -- n ) 5000 ; inline
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
-
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
-
-: random-segment ( previous-segment -- segment )
- clone dup random-rotation-angle random-turn
- tunnel-segment-distance over go-forward
- random-color >>color dup segment-number++ ;
-
-: (random-segments) ( segments n -- segments )
- dup 0 > [
- >r dup peek random-segment over push r> 1- (random-segments)
- ] [ drop ] if ;
-
-: default-segment-radius ( -- r ) 1 ;
-
-: initial-segment ( -- segment )
- F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
-
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- number>> over >r
- [ nearest-segment-forward ] 3keep
- nearest-segment-backward r> nearer-segment ;
-
-: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
-
-: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
-
-: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
-
-: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
- { +gt+ [ next-segment ] }
- { +lt+ [ previous-segment ] }
- { +eq+ [ nip ] } ! current segment
- } case ;
-
-:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
-
-: vector-to-centre ( seg loc -- v )
- over location>> swap v- swap forward>> proj-perp ;
-
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
-
-: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
-
-: distant ( -- n ) 1000 ;
-
-: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
- dup real? [
- over real? [ max ] [ nip ] if
- ] [
- drop dup real? [ drop distant ] unless
- ] if ;
-
-:: collision-coefficient ( v w r -- c )
- v norm 0 = [
- distant
- ] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
- ] if ;
-
-: sideways-heading ( oint segment -- v )
- [ forward>> ] bi@ proj-perp ;
-
-: sideways-relative-location ( oint segment -- loc )
- [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-
-: (distance-to-collision) ( oint segment -- distance )
- [ sideways-heading ] [ sideways-relative-location ]
- [ nip radius>> ] 2tri collision-coefficient ;
-
-: collision-vector ( oint segment -- v )
- dupd (distance-to-collision) swap forward>> n*v ;
-
-: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
-
-: bounce-left ( segment oint -- )
- #! must be done after forward
- [ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
-
-: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-
-: bounce-off-wall ( oint segment -- )
- swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
+++ /dev/null
-James Cash
+++ /dev/null
-IN: lisp
-USING: help.markup help.syntax ;
-HELP: <LISP
-{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
-{ $see-also lisp-string>factor } ;
-
-HELP: lisp-string>factor
-{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
-{ $description "Turns a string of lisp into a factor quotation" } ;
-
-ARTICLE: "lisp" "Lisp in Factor"
-"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
-"It works in two main stages: "
-{ $list
- { "Parse (via " { $vocab-link "lisp.parser" } " the Lisp code into a "
- { $snippet "s-exp" } " tuple." }
- { "Transform the " { $snippet "s-exp" } " into a Factor quotation, via " { $link convert-form } }
-}
-
-{ $subsection "lisp.parser" } ;
-
-ABOUT: "lisp"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists
-quotations ;
-
-IN: lisp.test
-
-[
- define-lisp-builtins
-
- { 5 } [
- "(+ 2 3)" lisp-eval
- ] unit-test
-
- { 8.3 } [
- "(- 10.4 2.1)" lisp-eval
- ] unit-test
-
- { 3 } [
- "((lambda (x y) (+ x y)) 1 2)" lisp-eval
- ] unit-test
-
- { 42 } [
- "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
- ] unit-test
-
- { "b" } [
- "(cond (#f \"a\") (#t \"b\"))" lisp-eval
- ] unit-test
-
- { "b" } [
- "(cond ((< 1 2) \"b\") (#t \"a\"))" lisp-eval
- ] unit-test
-
- { +nil+ } [
- "(list)" lisp-eval
- ] unit-test
-
- { { 1 2 3 4 5 } } [
- "(list 1 2 3 4 5)" lisp-eval list>seq
- ] unit-test
-
- { { 1 2 { 3 { 4 } 5 } } } [
- "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
- ] unit-test
-
- { 5 } [
- "(begin (+ 1 4))" lisp-eval
- ] unit-test
-
- { 5 } [
- "(begin (+ 5 6) (+ 1 4))" lisp-eval
- ] unit-test
-
- { t } [
- T{ lisp-symbol f "if" } lisp-macro?
- ] unit-test
-
- { 1 } [
- "(if #t 1 2)" lisp-eval
- ] unit-test
-
- { 3 } [
- "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
- ] unit-test
-
- { { 5 4 3 } } [
- "((lambda (x &rest xs) (cons x xs)) 5 4 3)" lisp-eval cons>seq
- ] unit-test
-
- { { 5 } } [
- "((lambda (x &rest xs) (cons x xs)) 5)" lisp-eval cons>seq
- ] unit-test
-
- { { 1 2 3 4 } } [
- "((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq
- ] unit-test
-
- { 10 } [
- <LISP (begin (+ 1 2) (+ 9 1)) LISP>
- ] unit-test
-
- { 4 } [
- <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
- ] unit-test
-
- { { 3 3 4 } } [
- <LISP (defun foo (x y &rest z)
- (cons (+ x y) z))
- (foo 1 2 3 4)
- LISP> cons>seq
- ] unit-test
-
-] with-interactive-vocabs
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg sequences arrays strings
-namespaces combinators math locals locals.private locals.backend accessors
-vectors syntax lisp.parser assocs parser words
-quotations fry lists summary combinators.short-circuit continuations multiline ;
-IN: lisp
-
-DEFER: convert-form
-DEFER: funcall
-DEFER: lookup-var
-DEFER: lookup-macro
-DEFER: lisp-macro?
-DEFER: lisp-var?
-DEFER: define-lisp-macro
-
-! Functions to convert s-exps to quotations
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( cons -- quot )
- [ ] [ convert-form compose ] foldl ; inline
-
-: convert-cond ( cons -- quot )
- cdr [ 2car [ convert-form ] bi@ 2array ]
- { } lmap-as '[ _ cond ] ;
-
-: convert-general-form ( cons -- quot )
- uncons [ convert-body ] [ convert-form ] bi* '[ _ @ funcall ] ;
-
-! words for convert-lambda
-<PRIVATE
-: localize-body ( assoc body -- newbody )
- {
- { [ dup list? ] [ [ lisp-symbol? ] rot '[ [ name>> _ at ] [ ] bi or ] traverse ] }
- { [ dup lisp-symbol? ] [ name>> swap at ] }
- [ nip ]
- } cond ;
-
-: localize-lambda ( body vars -- newvars newbody )
- swap [ make-locals dup push-locals ] dip
- dupd [ localize-body convert-form ] with lmap>array
- >quotation swap pop-locals ;
-
-: split-lambda ( cons -- body-cons vars-seq )
- cdr uncons [ name>> ] lmap>array ; inline
-
-: rest-lambda ( body vars -- quot )
- "&rest" swap [ remove ] [ index ] 2bi
- [ localize-lambda <lambda> lambda-rewrite call ] dip
- swap '[ _ cut '[ @ _ seq>list ] call _ call call ] 1quotation ;
-
-: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
-PRIVATE>
-
-: convert-lambda ( cons -- quot )
- split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
-
-: convert-quoted ( cons -- quot )
- cadr 1quotation ;
-
-: convert-defmacro ( cons -- quot )
- cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
-
-: macro-expand ( cons -- quot )
- uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-
-: expand-macros ( cons -- cons )
- dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
-
-: convert-begin ( cons -- quot )
- cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
- [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
-
-: form-dispatch ( cons lisp-symbol -- quot )
- name>>
- { { "lambda" [ convert-lambda ] }
- { "defmacro" [ convert-defmacro ] }
- { "quote" [ convert-quoted ] }
- { "cond" [ convert-cond ] }
- { "begin" [ convert-begin ] }
- [ drop convert-general-form ]
- } case ;
-
-: convert-list-form ( cons -- quot )
- dup car
- {
- { [ dup lisp-symbol? ] [ form-dispatch ] }
- [ drop convert-general-form ]
- } cond ;
-
-: convert-form ( lisp-form -- quot )
- {
- { [ dup cons? ] [ convert-list-form ] }
- { [ dup lisp-var? ] [ lookup-var 1quotation ] }
- { [ dup lisp-symbol? ] [ '[ _ lookup-var ] ] }
- [ 1quotation ]
- } cond ;
-
-: lisp-string>factor ( str -- quot )
- lisp-expr expand-macros convert-form ;
-
-: lisp-eval ( str -- * )
- lisp-string>factor call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: lisp-env
-SYMBOL: macro-env
-
-ERROR: no-such-var variable-name ;
-M: no-such-var summary drop "No such variable" ;
-
-: init-env ( -- )
- H{ } clone lisp-env set
- H{ } clone macro-env set ;
-
-: lisp-define ( quot name -- )
- lisp-env get set-at ;
-
-: define-lisp-var ( lisp-symbol body -- )
- swap name>> lisp-define ;
-
-: lisp-get ( name -- word )
- lisp-env get at ;
-
-: lookup-var ( lisp-symbol -- quot )
- [ name>> ] [ lisp-var? ] bi [ lisp-get ] [ no-such-var ] if ;
-
-: lisp-var? ( lisp-symbol -- ? )
- dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
-
-: funcall ( quot sym -- * )
- [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
-
-: define-primitive ( name vocab word -- )
- swap lookup 1quotation '[ _ compose call ] swap lisp-define ;
-
-: lookup-macro ( lisp-symbol -- lambda )
- name>> macro-env get at ;
-
-: define-lisp-macro ( quot name -- )
- macro-env get set-at ;
-
-: lisp-macro? ( car -- ? )
- dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
-
-: define-lisp-builtins ( -- )
- init-env
-
- f "#f" lisp-define
- t "#t" lisp-define
-
- "+" "math" "+" define-primitive
- "-" "math" "-" define-primitive
- "<" "math" "<" define-primitive
- ">" "math" ">" define-primitive
-
- "cons" "lists" "cons" define-primitive
- "car" "lists" "car" define-primitive
- "cdr" "lists" "cdr" define-primitive
- "append" "lists" "lappend" define-primitive
- "nil" "lists" "nil" define-primitive
- "nil?" "lists" "nil?" define-primitive
-
- "set" "lisp" "define-lisp-var" define-primitive
-
- "(set 'list (lambda (&rest xs) xs))" lisp-eval
- "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
-
- <" (defmacro defun (name vars &rest body)
- (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
-
- "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
- ;
-
-: <LISP
- "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
+++ /dev/null
-James Cash
+++ /dev/null
-IN: lisp.parser
-USING: help.markup help.syntax ;
-
-ARTICLE: "lisp.parser" "Parsing strings of Lisp"
-"This vocab uses " { $vocab-link "peg.ebnf" } " to turn strings of Lisp into " { $snippet "s-exp" } "s, which are then used by"
-{ $vocab-link "lisp" } " to produce Factor quotations." ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test peg peg.ebnf lists ;
-
-IN: lisp.parser.tests
-
-{ 1234 } [
- "1234" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ -42 } [
- "-42" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ 37/52 } [
- "37/52" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ 123.98 } [
- "123.98" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "" } [
- "\"\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "aoeu" } [
- "\"aoeu\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "aoeu\"de" } [
- "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ T{ lisp-symbol f "foobar" } } [
- "foobar" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ T{ lisp-symbol f "+" } } [
- "+" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ +nil+ } [
- "()" lisp-expr
-] unit-test
-
-{ T{
- cons
- f
- T{ lisp-symbol f "foo" }
- T{
- cons
- f
- 1
- T{ cons f 2 T{ cons f "aoeu" +nil+ } }
- } } } [
- "(foo 1 2 \"aoeu\")" lisp-expr
-] unit-test
-
-{ T{ cons f
- 1
- T{ cons f
- T{ cons f 3 T{ cons f 4 +nil+ } }
- T{ cons f 2 +nil+ } }
- }
-} [
- "(1 (3 4) 2)" lisp-expr
-] unit-test
-
-{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
- "'(1 2 3)" lisp-expr cons>seq
-] unit-test
-
-{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
- "'foo" lisp-expr cons>seq
-] unit-test
-
-{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
- "(1 2 '(3 4) 5)" lisp-expr cons>seq
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser sequences arrays strings
-math fry accessors lists combinators.short-circuit ;
-
-IN: lisp.parser
-
-TUPLE: lisp-symbol name ;
-C: <lisp-symbol> lisp-symbol
-
-EBNF: lisp-expr
-_ = (" " | "\t" | "\n")*
-LPAREN = "("
-RPAREN = ")"
-dquote = '"'
-squote = "'"
-digit = [0-9]
-integer = ("-")? (digit)+ => [[ first2 append string>number ]]
-float = integer "." (digit)* => [[ first3 >string [ number>string ] 2dip 3append string>number ]]
-rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
-number = float
- | rational
- | integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
- | "<" | "#" | " =" | ">" | "?" | "^" | "_"
- | "~" | "+" | "-" | "." | "@"
-letters = [a-zA-Z] => [[ 1array >string ]]
-initials = letters | id-specials
-numbers = [0-9] => [[ 1array >string ]]
-subsequents = initials | numbers
-identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
-escaped = "\" . => [[ second ]]
-string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
-atom = number
- | identifier
- | string
-s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
-list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
-quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
-expr = list-item
-;EBNF
\ No newline at end of file
+++ /dev/null
-EBNF grammar for parsing Lisp
+++ /dev/null
-lisp
-parsing
+++ /dev/null
-A Lisp interpreter/compiler in Factor
+++ /dev/null
-lisp
-languages
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad\r
- namespaces prettyprint sbufs sequences tools.interpreter vars\r
- io.encodings.binary ;\r
-IN: mad.api\r
-\r
-VARS: buffer-start buffer-length output-callback-var ;\r
-\r
-: create-mad-callback-generic ( sequence parameters -- alien )\r
- swap >r >r "mad_flow" r> "cdecl" r> alien-callback ; inline\r
-\r
-: create-input-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" } create-mad-callback-generic ; inline\r
-\r
-: create-header-callback ( sequence -- alien )\r
- { "void*" "mad_header*" } create-mad-callback-generic ; inline\r
-\r
-: create-filter-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
-\r
-: create-output-callback ( sequence -- alien )\r
- { "void*" "mad_header*" "mad_pcm*" } create-mad-callback-generic ; inline\r
-\r
-: create-error-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
-\r
-: create-message-callback ( sequence -- alien )\r
- { "void*" "void*" "uint*" } create-mad-callback-generic ; inline\r
-\r
-: input ( buffer mad_stream -- mad_flow )\r
- "input" print flush\r
- nip ! mad_stream\r
- buffer-start get ! mad_stream start\r
- buffer-length get ! mad_stream start length\r
- dup 0 = ! mad-stream start length bool\r
- [ 3drop MAD_FLOW_STOP ] ! mad_flow\r
- [ mad_stream_buffer ! \r
- 0 buffer-length set ! \r
- MAD_FLOW_CONTINUE ] if ; ! mad_flow\r
-\r
-: input-callback ( -- callback )\r
- [ input ] create-input-callback ;\r
-\r
-: header-callback ( -- callback )\r
- [ "header" print flush drop drop MAD_FLOW_CONTINUE ] create-header-callback ;\r
-\r
-: filter-callback ( -- callback )\r
- [ "filter" print flush 3drop MAD_FLOW_CONTINUE ] create-filter-callback ;\r
-\r
-: write-sample ( sample -- )\r
- 4 >le write ;\r
-\r
-: output ( data header pcm -- mad_flow )\r
- "output" . flush\r
- -rot 2drop output-callback-var> call\r
- [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;\r
-\r
-: output-stdout ( pcm -- ? )\r
- [ mad_pcm-channels ] keep\r
- [ mad_pcm-length ] keep swap\r
- [\r
- [ mad_pcm-sample-right ] 2keep\r
- [ mad_pcm-sample-left ] 2keep\r
- drop -rot write-sample pick\r
- 2 = [ write-sample ] [ drop ] if\r
- ] each drop t ;\r
-\r
-: output-callback ( -- callback )\r
- [ output ] create-output-callback ;\r
-\r
-: error-callback ( -- callback )\r
- [ "error" print flush drop drop drop MAD_FLOW_CONTINUE ] create-error-callback ;\r
-\r
-: message-callback ( -- callback )\r
- [ "message" print flush drop drop drop MAD_FLOW_CONTINUE ] create-message-callback ;\r
-\r
-: mad-init ( decoder -- )\r
- 0 <alien> input-callback 0 <alien> 0 <alien> output-callback error-callback message-callback mad_decoder_init ;\r
-\r
-: make-decoder ( -- decoder )\r
- "mad_decoder" malloc-object ;\r
-\r
-: mad-run ( -- int )\r
- make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ;\r
-\r
-: init-vars ( alien length -- )\r
- buffer-length set buffer-start set ;\r
-\r
-: decode-mp3 ( filename -- results )\r
- [ malloc-file-contents ] keep file-length init-vars mad-run ;\r
-\r
-: mad-test ( -- results )\r
- [ output-stdout ] >output-callback-var\r
- "/home/adam/download/mp3/Misc/wutbf.mp3" decode-mp3 ;\r
+++ /dev/null
-Adam Wendt
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: temporary
-
-USING: kernel mad mad.api alien alien.c-types tools.test
-namespaces ;
-
-: setup-buffer ( -- )
- 0 <alien> buffer-start set 0 buffer-length set ;
-
-[ t ] [ 0 "mad_stream" malloc-object setup-buffer input MAD_FLOW_STOP = ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: alien alien.c-types alien.syntax combinators kernel math system ;
-IN: mad
-
-<< "mad" {
- { [ macosx? ] [ "libmad.0.dylib" ] }
- { [ unix? ] [ "libmad.so" ] }
- { [ windows? ] [ "mad.dll" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: mad
-
-TYPEDEF: int mad_fixed_t
-TYPEDEF: int mad_fixed64hi_t
-TYPEDEF: uint mad_fixed64lo_t
-
-TYPEDEF: int mad_flow
-TYPEDEF: int mad_decoder_mode
-TYPEDEF: int mad_error
-TYPEDEF: int mad_layer
-TYPEDEF: int mad_mode
-TYPEDEF: int mad_emphasis
-
-C-STRUCT: mad_timer_t
- { "long" "seconds" }
- { "ulong" "fraction" }
-;
-
-C-STRUCT: mad_bitptr
- { "uchar*" "byte" }
- { "short" "cache" }
- { "short" "left" }
-;
-
-C-STRUCT: mad_stream
- { "uchar*" "buffer" }
- { "uchar*" "buffend" }
- { "long" "skiplen" }
- { "int" "sync" }
- { "ulong" "freerate" }
- { "uchar*" "this_frame" }
- { "uchar*" "next_frame" }
- { "mad_bitptr" "ptr" }
- { "mad_bitptr" "anc_ptr" }
- { "uchar*" "main_data" }
- { "int" "md_len" }
- { "int" "options" }
- { "mad_error" "error" }
-;
-
-C-STRUCT: struct_async
- { "long" "pid" }
- { "int" "in" }
- { "int" "out" }
-;
-
-C-STRUCT: mad_header
- { "mad_layer" "layer" }
- { "mad_mode" "mode" }
- { "int" "mode_extension" }
- { "mad_emphasis" "emphasis" }
- { "ulong" "bitrate" }
- { "uint" "samplerate" }
- { "ushort" "crc_check" }
- { "ushort" "crc_target" }
- { "int" "flags" }
- { "int" "private_bits" }
- { "mad_timer_t" "duration" }
-;
-
-C-STRUCT: mad_frame
- { "mad_header" "header" }
- { "int" "options" }
- { { "mad_fixed_t" 2304 } "sbsample" }
- { "mad_fixed_t*" "overlap" }
-;
-
-C-STRUCT: mad_pcm
- { "uint" "samplerate" }
- { "ushort" "channels" }
- { "ushort" "length" }
- { { "mad_fixed_t" 2304 } "samples" }
-;
-
-: mad_pcm-sample-left ( pcm int -- sample )
- swap mad_pcm-samples int-nth ;
-: mad_pcm-sample-right ( pcm int -- sample )
- 1152 + swap mad_pcm-samples int-nth ;
-
-C-STRUCT: mad_synth
- { { "mad_fixed_t" 1024 } "filter" }
- { "uint" "phase" }
- { "mad_pcm" "pcm" }
-;
-
-C-STRUCT: struct_sync
- { "mad_stream" "stream" }
- { "mad_frame" "frame" }
- { "mad_synth" "synth" }
-;
-
-C-STRUCT: mad_decoder
- { "mad_decoder_mode" "mode" }
- { "int" "options" }
- { "struct_async" "async" }
- { "struct_sync*" "sync" }
- { "void*" "cb_data" }
- { "void*" "input_func" }
- { "void*" "header_func" }
- { "void*" "filter_func" }
- { "void*" "output_func" }
- { "void*" "error_func" }
- { "void*" "message_func" }
-;
-
-: MAD_F_FRACBITS ( -- number ) 28 ; inline
-: MAD_F_ONE HEX: 10000000 ;
-
-: MAD_DECODER_MODE_SYNC ( -- number ) HEX: 0 ; inline
-: MAD_DECODER_MODE_ASYNC ( -- number ) HEX: 1 ; inline
-
-: MAD_FLOW_CONTINUE ( -- number ) HEX: 0 ; inline
-: MAD_FLOW_STOP ( -- number ) HEX: 10 ; inline
-: MAD_FLOW_BREAK ( -- number ) HEX: 11 ; inline
-: MAD_FLOW_IGNORE ( -- number ) HEX: 20 ; inline
-
-: MAD_ERROR_NONE ( -- number ) HEX: 0 ; inline
-: MAD_ERROR_BUFLEN ( -- number ) HEX: 1 ; inline
-: MAD_ERROR_BUFPTR ( -- number ) HEX: 2 ; inline
-: MAD_ERROR_NOMEM ( -- number ) HEX: 31 ; inline
-: MAD_ERROR_LOSTSYNC ( -- number ) HEX: 101 ; inline
-: MAD_ERROR_BADLAYER ( -- number ) HEX: 102 ; inline
-: MAD_ERROR_BADBITRATE ( -- number ) HEX: 103 ; inline
-: MAD_ERROR_BADSAMPLERATE ( -- number ) HEX: 104 ; inline
-: MAD_ERROR_BADEMPHASIS ( -- number ) HEX: 105 ; inline
-: MAD_ERROR_BADCRC ( -- number ) HEX: 201 ; inline
-: MAD_ERROR_BADBITALLOC ( -- number ) HEX: 211 ; inline
-: MAD_ERROR_BADSCALEFACTOR ( -- number ) HEX: 221 ; inline
-: MAD_ERROR_BADMODE ( -- number ) HEX: 222 ; inline
-: MAD_ERROR_BADFRAMELEN ( -- number ) HEX: 231 ; inline
-: MAD_ERROR_BADBIGVALUES ( -- number ) HEX: 232 ; inline
-: MAD_ERROR_BADBLOCKTYPE ( -- number ) HEX: 233 ; inline
-: MAD_ERROR_BADSCFSI ( -- number ) HEX: 234 ; inline
-: MAD_ERROR_BADDATAPTR ( -- number ) HEX: 235 ; inline
-: MAD_ERROR_BADPART3LEN ( -- number ) HEX: 236 ; inline
-: MAD_ERROR_BADHUFFTABLE ( -- number ) HEX: 237 ; inline
-: MAD_ERROR_BADHUFFDATA ( -- number ) HEX: 238 ; inline
-: MAD_ERROR_BADSTEREO ( -- number ) HEX: 239 ; inline
-
-
-FUNCTION: void mad_decoder_init ( mad_decoder* decoder, void* data, void* input_func, void* header_func, void* filter_func, void* output_func, void* error_func, void* message_func ) ;
-FUNCTION: int mad_decoder_run ( mad_decoder* decoder, mad_decoder_mode mode ) ;
-FUNCTION: void mad_stream_buffer ( mad_stream* stream, uchar* start, ulong length ) ;
-
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-USING: alien.c-types io kernel libc mad mad.api math namespaces openal prettyprint sequences tools.interpreter vars ;\r
-IN: mad.player\r
-\r
-VARS: openal-buffer ;\r
-\r
-: get-format ( pcm -- format )\r
- mad_pcm-channels 2 =\r
- [ AL_FORMAT_STEREO16 ] [ AL_FORMAT_MONO16 ] if ;\r
-\r
-: no-error? ( -- ? )\r
- alGetError dup . flush AL_NO_ERROR = ;\r
-\r
-: round ( sample -- rounded )\r
- 1 MAD_F_FRACBITS 16 - shift + ;\r
-\r
-: clip ( sample -- clipped ) MAD_F_ONE 1- min MAD_F_ONE neg max ;\r
-\r
-: quantize ( sample -- quantized )\r
- MAD_F_FRACBITS 1+ 16 - neg shift ;\r
-\r
-: scale-sample ( sample -- scaled )\r
- round clip quantize ;\r
-\r
-: get-needed-size ( pcm -- size )\r
- [ mad_pcm-channels ] keep mad_pcm-length 2 * * ;\r
-\r
-: make-data ( pcm -- )\r
- [ mad_pcm-channels ] keep ! channels pcm\r
- [ mad_pcm-length ] keep swap ! channels pcm length\r
- [ ! channels pcm counter\r
- [ mad_pcm-sample-right ] 2keep ! channels right pcm counter\r
- [ mad_pcm-sample-left ] 2keep ! channels right left pcm counter\r
- drop -rot scale-sample , pick ! channels pcm right channels\r
- 2 = [ scale-sample , ] [ drop ] if ! channels pcm right\r
- ] each 2drop ;\r
-\r
-: array>alien ( alien array -- ) dup length [ pick set-int-nth ] 2each drop ;\r
- \r
-: fill-data ( pcm alien -- )\r
- swap [ make-data ] { } make array>alien ;\r
-\r
-: get-data ( pcm -- size alien )\r
- [ get-needed-size ] keep over\r
- malloc [ fill-data ] keep ;\r
-\r
-: output-openal ( pcm -- ? )\r
- openal-buffer> swap ! buffer pcm\r
- [ get-format ] keep ! buffer format pcm\r
- [ get-data ] keep ! buffer format size alien pcm\r
- mad_pcm-samplerate ! buffer format size alien samplerate\r
- swapd alBufferData no-error?\r
- ;\r
-\r
-: play-mp3 ( filename -- )\r
- gen-buffer >openal-buffer [ output-openal ] >output-callback-var decode-mp3 ;\r
+++ /dev/null
-libmad MP3 library binding
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
- splitting grouping math generalizations ;
-
-IN: mortar
-
-! class { name slots methods class-methods }
-
-: class-name ( class -- name ) dup symbol? [ get ] when first ;
-
-: class-slots ( class -- slots ) dup symbol? [ get ] when second ;
-
-: class-methods ( class -- methods ) dup symbol? [ get ] when third ;
-
-: class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
-
-: class? ( thing -- ? )
-dup array?
-[ dup length 4 = [ first symbol? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-method ( class name quot -- )
-rot get class-methods peek swapd set-at ;
-
-: add-class-method ( class name quot -- )
-rot get class-class-methods peek swapd set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! object { class values }
-
-: object-class ( object -- class ) first ;
-
-: object-values ( object -- values ) second ;
-
-: object? ( thing -- ? )
-dup array?
-[ dup length 2 = [ first class? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: is? ( object class -- ? ) swap object-class class-name = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new ( class -- object )
-get dup >r class-slots length narray r> swap 2array ;
-
-: new-empty ( class -- object )
-get dup >r class-slots length f <array> r> swap 2array ;
-
-! : new* ( class -- object ) new-empty <- init ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: slot-value ( object slot -- value )
-over object-class class-slots index swap object-values nth ;
-
-: set-slot-value ( object slot value -- object )
-swap pick object-class class-slots index pick object-values set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : send-message ( object message -- )
-! over object-class class-methods assoc-stack call ;
-
-: send-message ( object message -- )
-2dup swap object-class class-methods assoc-stack dup
-[ nip call ]
-! [ drop nip "message not understood: " write print flush ]
-[ drop "message not understood: " write print drop ]
-if ;
-
-: <- scan parsed \ send-message parsed ; parsing
-
-! : send-message* ( message n -- )
-! 1+ npick object-class class-methods assoc-stack call ;
-
-: send-message* ( message n -- )
-1+ npick dupd object-class class-methods assoc-stack dup
-[ nip call ]
-[ drop "message not understood: " write print flush ]
-if ;
-
-: <-- scan parsed 2 parsed \ send-message* parsed ; parsing
-
-: <--- scan parsed 3 parsed \ send-message* parsed ; parsing
-
-: <---- scan parsed 4 parsed \ send-message* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-to-class ( class message -- )
-over class-class-methods assoc-stack call ;
-
-: <<- scan parsed \ send-message-to-class parsed ; parsing
-
-: send-message-to-class* ( message n -- )
-1+ npick class-class-methods assoc-stack call ;
-
-: <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
-
-: <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-next ( object message -- )
-over object-class class-methods but-last assoc-stack call ;
-
-: <-~ scan parsed \ send-message-next parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : new* ( class -- object ) <<- create ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: slot-accessors
-
-IN: mortar
-
-! : generate-slot-getter ( name -- )
-! "$" over append "slot-accessors" create swap [ slot-value ] curry
-! define-compound ;
-
-: generate-slot-getter ( name -- )
-"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
-
-! : generate-slot-setter ( name -- )
-! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-! define-compound ;
-
-: generate-slot-setter ( name -- )
-">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-define ;
-
-: generate-slot-accessors ( name -- )
-dup
-generate-slot-getter
-generate-slot-setter ;
-
-: accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
-
-! : slots:
-! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
-
-: empty-method-table ( -- array ) H{ } clone 1array ;
-
-! : define-simple-class ( name parent slots -- )
-! >r >r <symbol>
-! r> dup class-slots r> append
-! swap dup class-methods empty-method-table append
-! swap class-class-methods empty-method-table append
-! 4array dup first set-global ;
-
-: define-simple-class ( name parent slots -- )
->r dup class-slots r> append
-swap dup class-methods empty-method-table append
-swap class-class-methods empty-method-table append
-4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-independent-class ( name slots -- )
-empty-method-table empty-method-table 4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: !( ")" parse-tokens drop ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: mortar ;
-
-IN: mortar.sugar
-
-: new* ( class -- object ) <<- create ;
\ No newline at end of file
+++ /dev/null
-extensions
--- /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
-Eduardo Cavazos
+++ /dev/null
-USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math generalizations locals mirrors
- macros ;
-
-IN: namespaces.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: save-namestack ( quot -- ) namestack slip set-namestack ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set* ( val var -- ) namestack* set-assoc-stack ;
-
-: make-object ( quot class -- object )
- new [ <mirror> swap bind ] keep ; inline
-
-: with-object ( object quot -- )
- [ <mirror> ] dip bind ; inline
+++ /dev/null
-Non-core namespace words
+++ /dev/null
-collections
+++ /dev/null
-
-USING: arrays sequences ;
-
-IN: obj.alist
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: alist < sequence [ pair? ] all? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences sets combinators.cleave
- obj obj.view obj.util obj.print ;
-
-IN: obj.examples.todo
-
-SYM: person types adjoin
-SYM: todo types adjoin
-
-SYM: owners properties adjoin
-SYM: eta properties adjoin
-SYM: notes properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: slava { type person } define-object
-SYM: doug { type person } define-object
-SYM: ed { type person } define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: compiler-bugs
- {
- type todo
- owners { slava }
- notes {
- "Investitage FEP on Terrorist"
- "Problem with cutler in VirtualBox?"
- }
- }
-define-object
-
-SYM: remove-old-accessors-from-core
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: move-db-and-web-framework-to-basis
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: remove-old-accessors-from-basis
- {
- type todo
- owners { doug ed }
- }
-define-object
-
-SYM: blas-on-bsd
- {
- type todo
- owners { slava doug }
- }
-define-object
-
-SYM: multi-methods-backend
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: update-core-for-multi-methods { type todo owners { slava } } define-object
-SYM: update-basis-for-multi-methods { type todo } define-object
-SYM: update-extra-for-multi-methods { type todo } define-object
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: todo-list ( -- )
- objects [ type -> todo = ] filter
- [ { [ self -> ] [ owners -> ] [ eta -> ] } 1arr ]
- map
- { "ITEM" "OWNERS" "ETA" } prefix
- print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel namespaces sequences assocs sequences.deep obj ;
-
-IN: obj.misc
-
-: related ( obj -- seq )
- objects dupd remove [ get values flatten member? ] with filter ;
-
+++ /dev/null
-
-USING: kernel words namespaces arrays vectors hashtables
- sequences assocs sets grouping
- combinators.conditional
- combinators.short-circuit
- obj.util obj.alist ;
-
-IN: obj
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: properties ( -- properties ) V{ } ;
-
-SYM: self properties adjoin
-SYM: type properties adjoin
-SYM: title properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: types ( -- types ) V{ } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >obj ( val -- obj ) [ symbol? ] [ get ] [ ] 1if ;
-
-: -> ( obj pro -- val ) swap >obj at ;
-
-PREDICATE: obj < alist { [ self -> ] [ type -> ] } 1&& ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: objects ( -- objects ) V{ } ;
-
-: define-object ( symbol table -- )
- 2 group >vector
- self rot 2array prefix
- dup dup self -> set-global
- self -> objects adjoin ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: ptr < symbol get obj? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: sets obj obj.util obj.view ;
-
-IN: obj.papers
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: title properties adjoin
-SYM: abstract properties adjoin
-SYM: authors properties adjoin
-SYM: file properties adjoin
-SYM: date properties adjoin
-SYM: participants properties adjoin
-SYM: description properties adjoin
-
-SYM: chapter properties adjoin
-SYM: section properties adjoin
-SYM: paragraph properties adjoin
-SYM: content properties adjoin
-
-SYM: subjects properties adjoin
-SYM: source properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: paper types adjoin
-SYM: person types adjoin
-SYM: event types adjoin
-
-SYM: excerpt types adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: bay-wei-chang { type person } define-object
-SYM: chuck-moore { type person } define-object
-SYM: craig-chambers { type person } define-object
-SYM: david-ungar { type person } define-object
-SYM: frank-g-halasz { type person } define-object
-SYM: gerald-jay-sussman { type person } define-object
-SYM: guy-lewis-steele-jr { type person } define-object
-SYM: randall-b-smith { type person } define-object
-SYM: randall-h-trigg { type person } define-object
-SYM: robert-adams { type person } define-object
-SYM: russell-noftsker { type person } define-object
-SYM: thomas-p-moran { type person } define-object
-SYM: urs-holzle { type person } define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: programming-as-an-experience
- {
- type paper
- title "Programming as an Experience: The Inspiration for Self"
- abstract "The Self system attempts to integrate intellectual and non-intellectual aspects of programming to create an overall experience. The language semantics, user interface, and implementation each help create this integrated experience. The language semantics embed the programmer in a uniform world of simple ob jects that can be modified without appealing to definitions of abstractions. In a similar way, the graphical interface puts the user into a uniform world of tangible objects that can be directly manipulated and changed without switching modes. The implementation strives to support the world-of-objects illusion by minimiz ing perceptible pauses and by providing true source-level semantics without sac rificing performance. As a side benefit, it encourages factoring. Although we see areas that fall short of the vision, on the whole, the language, interface, and im plementation conspire so that the Self programmer lives and acts in a consistent and malleable world of objects."
- authors { randall-b-smith david-ungar }
- date 1995
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: self-the-power-of-simplicity
- {
- type paper
- title "Self: The Power of Simplicity"
- abstract "Self is an object-oriented language for exploratory programming based on a small number of simple and concrete ideas: prototypes, slots, and behavior. Prototypes combine inheritance and instantiation to provide a framework that is simpler and more flexible than most object-oriented languages. Slots unite variables and procedures into a single construct. This permits the inheritance hierarchy to take over the function of lexical scoping in conventional languages. Finally, because Self does not distinguish state from behavior, it narrows the gaps between ordinary objects, procedures, and closures. Self's simplicity and expressiveness offer new insights into object-oriented computation."
- authors { randall-b-smith david-ungar }
- date 1987
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: parents-are-shared-parts
- {
- type paper
- title "Parents are Shared Parts: Inheritance and Encapsulation in Self"
- abstract "The design of inheritance and encapsulation in Self, an object-oriented language based on prototypes, results from understanding that inheritance allows parents to be shared parts of their children. The programmer resolves ambiguities arising from multiple inheritance by prioritizing an object's parents. Unifying unordered and ordered multiple inheritance supports differential programming of abstractions and methods, combination of unrelated abstractions, unequal combination of abstractions, and mixins. In Self, a private slot may be accessed if the sending method is a shared part of the receiver, allowing privileged communication between related objects. Thus, classless Self enjoys the benefits of class-based encapsulation."
- authors { craig-chambers david-ungar bay-wei-chang urs-holzle }
- date 1991
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: organizing-programs-without-classes
- {
- type paper
- title "Organizing Programs Without Classes"
- abstract "All organizational functions carried out by classes can be accomplished in a simple and natural way by object inheritance in classless languages, with no need for special mechanisms. A single model--dividing types into prototypes and traits--supports sharing of behavior and extending or replacing representations. A natural extension, dynamic object inheritance, can model behavioral modes. Object inheritance can also be used to provide structured name spaces for well-known objects. Classless languages can even express 'class-based' encapsulation. These stylized uses of object inheritance become instantly recognizable idioms, and extend the repertory of organizing principles to cover a wider range of programs."
- authors { david-ungar craig-chambers bay-wei-chang urs-holzle }
- date 1991
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: scheme-an-interpreter-for-extended-lambda-calculus
- {
- type paper
- title "Scheme: An Interpreter for Extended Lambda Calculus"
- abstract "Inspired by ACTORS [Greif and Hewitt] [Smith and Hewitt], we have implemented an interpreter for a LISP-like language, SCHEME, based on the lambda calculus [Church], but extended for side effects, multiprocessing, and process synchronization. The purpose of this implementation is tutorial. We wish to: (1) alleviate the confusion caused by Micro-PLANNER, CONNIVER, etc. by clarifying the embedding of non-recursive control structures in a recursive host language like LISP. (2) explain how to use these control structures, independent of such issues as pattern matching and data base manipulation. (3) have a simple concrete experimental domain for certain issues of programming semantics and style."
- authors { gerald-jay-sussman guy-lewis-steele-jr }
- date 1975
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: symbolics-is-founded
- {
- type event
- participants { russell-noftsker robert-adams }
- date 1980
- }
-define-object
-
-SYM: symbolics-funding-from-gi
- {
- type event
- description "Symbolics receives $500,000 from General Instruments"
- date 1982
- }
-define-object
-
-SYM: symbolics-files-for-bankruptcy
- {
- type event
- date "1993-01-28"
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: the-evolution-of-forth
- {
- type paper
- title "The Evolution of Forth"
- authors { chuck-moore "elizabeth-d-rather" "donald-r-colburn" }
- abstract
- "Forth is unique among programming languages in that its development and proliferation has been a grass-roots effort unsupported by any major corporate or academic sponsors. Originally conceived and developed by a single individual, its later development has progressed under two significant influences: professional programmers who developed tools to solve application problems and then commercialized them, and the interests of hobbyists concerned with free distribution of Forth. These influences have produced a language markedly different from traditional programming languages."
- date 1993
- }
-define-object
-
-SYM: first-complete-stand-alone-forth
- {
- type event
- participants { chuck-moore }
- date 1971
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: notecards-in-a-nutshell
- {
- type paper
- authors { frank-g-halasz thomas-p-moran randall-h-trigg }
- date 1987
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: the-evolution-of-forth-excerpt-2-1-1
- {
- type excerpt
- source the-evolution-of-forth
- chapter 2
- section 1
- paragraph 1
- content
- "Moore developed the first complete, stand-alone implementation of Forth in 1971 for the 11-meter radio telescope operated by the National Radio Astronomy Observatory (NRAO) at Kitt Peak, Arizona. This system ran on two early minicomputers (a 16 KB DDP-116 and a 32 KB H316) joined by a serial link. Both a multiprogrammed system and a multiprocessor system (in that both computers shared responsibility for controlling the telescope and its scientific instruments), it was responsible for pointing and tracking the telescope, collecting data and recording it on magnetic tape, and supporting an interactive graphics terminal on which an astronomer could analyze previously recorded data. The multiprogrammed nature of the system allowed all these functions to be performed concurrently, without timing conflicts or other interference."
- subjects { chuck-moore first-complete-stand-alone-forth }
- }
-define-object
-
+++ /dev/null
-
-USING: kernel arrays strings sequences assocs io io.styles prettyprint colors
- combinators.conditional ;
-
-IN: obj.print
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: write-wrapped ( string -- ) H{ { wrap-margin 500 } } [ write ] with-nesting ;
-
-! : print-elt ( val -- )
-! {
-! { [ string? ] [ write-wrapped ] }
-! { [ array? ] [ [ . ] each ] }
-! { [ drop t ] [ . ] }
-! }
-! 1cond ;
-
-USING: accessors vocabs help.markup ;
-
-: print-elt ( val -- )
- {
- { [ vocab? ] [ [ name>> ] [ ] bi write-object ] }
- { [ string? ] [ write-wrapped ] }
- { [ array? ] [ [ . ] each ] }
- { [ drop t ] [ . ] }
- }
- 1cond ;
-
-: print-grid ( grid -- )
- H{ { table-gap { 10 10 } } { table-border T{ rgba f 0 0 0 1 } } }
- [ [ [ [ [ print-elt ] with-cell ] each ] with-row ] each ] tabular-output ;
-
-: print-table ( assoc -- ) >alist print-grid ;
-
-: print-seq ( seq -- ) [ 1array ] map print-grid ;
-
+++ /dev/null
-
-USING: kernel parser words ;
-
-IN: obj.util
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: SYM: CREATE-WORD dup define-symbol parsed ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: kernel words namespaces arrays sequences prettyprint
- help.topics help.markup bake combinators.cleave
- obj obj.misc obj.print ;
-
-IN: obj.view
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: $tab ( seq -- ) first print-table ;
-: $obj ( seq -- ) first print-table ;
-: $seq ( seq -- ) first print-seq ;
-: $ptr ( seq -- ) first get print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: obj-type < symbol types member? ;
-
-M: obj-type article-title ( type -- title ) unparse ;
-
-M: obj-type article-content ( type -- content )
- objects [ type -> = ] with filter
- { $seq , } bake ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: ptr article-title ( ptr -- title ) [ title -> ] [ unparse ] bi or ;
-
-M: ptr article-content ( ptr -- content )
- {
- [ get { $obj , } bake ]
- [ drop { $heading "Related\n" } ]
- [ related { $seq , } bake ]
- }
- 1arr ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: obj-list < word \ objects = ;
-
-M: obj-list article-title ( objects -- title ) drop "Objects" ;
-
-! M: obj-list article-content ( objects -- title )
-! execute
-! [ [ type -> ] [ ] bi 2array ] map
-! { $tab , } bake ;
-
-M: obj-list article-content ( objects -- title )
- drop
- objects
- [ [ type -> ] [ ] bi 2array ] map
- { $tab , } bake ;
\ No newline at end of file
--- /dev/null
+IN: opengl.gadgets.tests
+USING: tools.test opengl.gadgets ;
+
+\ render* must-infer
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.functions math namespaces
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
+fry assocs
+destructors sequences ui.render colors ;
+IN: opengl.gadgets
+
+TUPLE: texture-gadget < gadget ;
+
+GENERIC: render* ( gadget -- texture dims )
+GENERIC: cache-key* ( gadget -- key )
+
+M: texture-gadget cache-key* ;
+
+SYMBOL: textures
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+ dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+refcounts init-cache
+
+: refcount-change ( gadget quot -- )
+ [ cache-key* refcounts get [ [ 0 ] unless* ] ] dip compose change-at ;
+
+TUPLE: cache-entry tex dims ;
+C: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+ dup render* <entry>
+ [ swap cache-key* textures get set-at ] keep ;
+
+: get-entry ( gadget -- {texture,dims} )
+ dup cache-key* textures get at
+ [ nip ] [ make-entry ] if* ;
+
+: get-dims ( gadget -- dims )
+ get-entry dims>> ;
+
+: get-texture ( gadget -- texture )
+ get-entry tex>> ;
+
+: release-texture ( gadget -- )
+ cache-key* textures get delete-at*
+ [ tex>> delete-texture ] [ drop ] if ;
+
+: clear-textures ( -- )
+ textures get values [ tex>> delete-texture ] each
+ H{ } clone textures set-global
+ H{ } clone refcounts set-global ;
+
+M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+M: texture-gadget ungraft* ( gadget -- )
+ dup [ 1- ] refcount-change
+ dup cache-key* refcounts get at
+ zero? [ release-texture ] [ drop ] if ;
+
+: 2^-ceil ( x -- y )
+ dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
+
+: 2^-bounds ( dim -- dim' )
+ [ 2^-ceil ] map ; foldable flushable
+
+:: (render-bytes) ( dims bytes format texture -- )
+ GL_ENABLE_BIT [
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D texture glBindTexture
+ GL_TEXTURE_2D
+ 0
+ GL_RGBA
+ dims 2^-bounds first2
+ 0
+ format
+ GL_UNSIGNED_BYTE
+ bytes
+ glTexImage2D
+ init-texture
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs ;
+
+: render-bytes ( dims bytes format -- texture )
+ gen-texture [ (render-bytes) ] keep ;
+
+: render-bytes* ( dims bytes format -- texture dims )
+ pick [ render-bytes ] dip ;
+
+:: four-corners ( dim -- )
+ [let* | w [ dim first ]
+ h [ dim second ]
+ dim' [ dim dup 2^-bounds [ /f ] 2map ]
+ w' [ dim' first ]
+ h' [ dim' second ] |
+ 0 0 glTexCoord2d 0 0 glVertex2d
+ 0 h' glTexCoord2d 0 h glVertex2d
+ w' h' glTexCoord2d w h glVertex2d
+ w' 0 glTexCoord2d w 0 glVertex2d
+ ] ;
+
+M: texture-gadget draw-gadget* ( gadget -- )
+ origin get [
+ GL_ENABLE_BIT [
+ white gl-color
+ 1.0 -1.0 glPixelZoom
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D over get-texture glBindTexture
+ GL_QUADS [
+ get-dims four-corners
+ ] do-state
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs
+ ] with-translation ;
+
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+IN: ori.tests
+USING: ori tools.test ;
+
+\ pitch-up must-infer
+\ pitch-down must-infer
+\ turn-left must-infer
+\ turn-right must-infer
+\ roll-left must-infer
+\ roll-right must-infer
--- /dev/null
+
+USING: kernel namespaces make accessors
+ math math.constants math.functions math.matrices math.vectors
+ sequences splitting grouping self math.trig ;
+
+IN: ori
+
+TUPLE: ori val ;
+
+C: <ori> ori
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ori> ( -- val ) self> val>> ;
+
+: >ori ( val -- ) self> (>>val) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! These rotation matrices are from
+! `Computer Graphics: Principles and Practice'
+
+: Rz ( angle -- Rx ) deg>rad
+[ dup cos , dup sin neg , 0 ,
+ dup sin , dup cos , 0 ,
+ 0 , 0 , 1 , ] 3 make-matrix nip ;
+
+: Ry ( angle -- Ry ) deg>rad
+[ dup cos , 0 , dup sin ,
+ 0 , 1 , 0 ,
+ dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
+
+: Rx ( angle -- Rz ) deg>rad
+[ 1 , 0 , 0 ,
+ 0 , dup cos , dup sin neg ,
+ 0 , dup sin , dup cos , ] 3 make-matrix nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-rotation ( rotation -- ) ori> swap m. >ori ;
+
+: rotate-x ( angle -- ) Rx apply-rotation ;
+: rotate-y ( angle -- ) Ry apply-rotation ;
+: rotate-z ( angle -- ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( angle -- ) neg rotate-x ;
+: pitch-down ( angle -- ) rotate-x ;
+
+: turn-left ( angle -- ) rotate-y ;
+: turn-right ( angle -- ) neg rotate-y ;
+
+: roll-left ( angle -- ) neg rotate-z ;
+: roll-right ( angle -- ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! roll-until-horizontal
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( -- 3array ) ori> [ first ] map ;
+: Y ( -- 3array ) ori> [ second ] map ;
+: Z ( -- 3array ) ori> [ third ] map ;
+
+: set-X ( seq -- ) ori> [ set-first ] 2each ;
+: set-Y ( seq -- ) ori> [ set-second ] 2each ;
+: set-Z ( seq -- ) ori> [ set-third ] 2each ;
+
+: roll-until-horizontal ( -- )
+V Z cross normalize set-X
+Z X cross normalize set-Y ;
+
--- /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
+
+USING: kernel accessors locals math math.intervals math.order
+ namespaces sequences threads
+ ui
+ ui.gadgets
+ ui.gestures
+ ui.render
+ calendar
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ combinators.cleave.enhanced
+ processing.shapes
+ flatland ;
+
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } && ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
+ ! by multi-methods
+
+TUPLE: <pong> < gadget paused field ball player computer ;
+
+: pong ( -- gadget )
+ <pong> new-gadget
+ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
+ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
+ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ [let | FIELD [ GADGET field>> ]
+ BALL [ GADGET ball>> ]
+ PLAYER [ GADGET player>> ]
+ COMPUTER [ GADGET computer>> ] |
+
+ [wlet | align-player-with-mouse [ ( -- )
+ PLAYER FIELD align-paddle-with-mouse ]
+
+ move-ball [ ( -- ) BALL 1 move-for ]
+
+ player-blocked-ball? [ ( -- ? )
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
+
+ computer-blocked-ball? [ ( -- ? )
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
+
+ bounce-off-wall? [ ( -- ? )
+ BALL FIELD in-between-horizontally? not ]
+
+ stop-game [ ( -- ) t GADGET (>>paused) ] |
+
+ BALL FIELD in-bounds?
+ [
+
+ align-player-with-mouse
+
+ move-ball
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+ ]
+ [ stop-game ]
+ if
+
+ ] ] ( gadget -- ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-pong-thread ( GADGET -- )
+ f GADGET (>>paused)
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
+
+MAIN: pong-window
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.functions math.vectors sequences self
+accessors ;
+
+IN: pos
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: pos val ;
+
+C: <pos> pos
+
+: pos> ( -- val ) self> val>> ;
+
+: >pos ( val -- ) self> (>>val) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
+
+: move-by ( point -- ) pos> v+ >pos ;
+
--- /dev/null
+
+USING: kernel namespaces arrays sequences grouping
+ alien.c-types
+ math math.vectors math.geometry.rect
+ opengl.gl opengl.glu opengl generalizations vars
+ combinators.cleave colors ;
+
+IN: processing.shapes
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: do-state ( mode quot -- ) swap glBegin call glEnd ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+T{ rgba f 0 0 0 1 } stroke-color set-global
+T{ rgba f 1 1 1 1 } fill-color set-global
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-mode ( -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-mode ( -- )
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
+
+: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
+: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
+: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line** ( x y x y -- )
+ stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
+
+: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
+
+: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
+
+: line ( seq -- ) lines ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangles ( seq -- )
+ [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
+
+: triangle ( seq -- ) triangles ;
+
+: triangle* ( a b c -- ) 3array triangles ;
+
+: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( seq -- )
+ [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rectangle ( loc dim -- )
+ <rect>
+ { top-left top-right bottom-right bottom-left }
+ 1arr
+ polygon ;
+
+: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
+
+: gl-scale-2d ( xy -- ) first2 1 glScaled ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-ellipse ( center dim -- )
+ glPushMatrix
+ [ gl-translate-2d ] [ gl-scale-2d ] bi*
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-get-line-width ( -- width )
+ GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
+
+: ellipse ( center dim -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( center size -- ) dup 2array ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+++ /dev/null
-Gavin Harrison
+++ /dev/null
-! Copyright (C) 2007 Gavin Harrison
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences arrays vectors namespaces math strings
- combinators continuations quotations io assocs ascii ;
-
-IN: prolog
-
-SYMBOL: pldb
-SYMBOL: plchoice
-
-: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
-
-: reset-choice ( -- ) V{ } clone plchoice set ;
-: remove-choice ( -- ) plchoice get pop drop ;
-: add-choice ( continuation -- )
- dup continuation? [ plchoice get push ] [ drop ] if ;
-: last-choice ( -- ) plchoice get pop continue ;
-
-: rules ( -- vector ) pldb get ;
-: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
-
-: var? ( pl-obj -- ? )
- dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
-: const? ( pl-obj -- ? ) var? not ;
-
-: check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
-: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
-: (double-bound) ( key value assoc -- ? )
- pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
-: single-bound? ( pat-d pat-f -- ? )
- H{ } clone [ (double-bound) ] curry 2all? ;
-: match-pattern ( pat fact -- ? )
- check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
-: good-result? ( pat fact -- pat fact ? )
- 2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
-
-: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
-
-: (lookup-rule) ( name num -- pat-f rules )
- dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
- [ dup rule [ ] callcc0 add-choice ] when
- dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
-
-: add-bindings ( pat-d pat-f binds -- binds )
- clone
- [ over var? over const? or
- [ 2drop ] [ rot dup >r set-at r> ] if
- ] 2reduce ;
-: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
-
-: replace-if-bound ( binds elt -- binds elt' )
- over 2dup key? [ at ] [ drop ] if ;
-: deep-replace ( binds seq -- binds seq' )
- [ dup var? [ replace-if-bound ]
- [ dup array? [ dupd deep-replace nip ] when ] if
- ] map ;
-
-: backtrace? ( result -- )
- dup "No." = [ remove-choice last-choice ]
- [ [ last-choice ] unless ] if ;
-
-: resolve-rule ( pat-d pat-f rule-body -- binds )
- >r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
- dup t = [ drop ] when ] each ;
-
-: rule>pattern ( rule -- pattern ) 1 swap nth ;
-: rule>body ( rule -- body ) 2 swap nth ;
-
-: binds>fact ( pat-d pat-f binds -- fact )
- [ 2dup key? [ at ] [ drop ] if ] curry map good-result?
- [ nip ] [ last-choice ] if ;
-
-: lookup-rule ( name pat -- fact )
- swap 0 (lookup-rule) dup "No." =
- [ nip ]
- [ dup rule>pattern swapd check-arity
- [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
- ] if ;
-
-: binding-resolve ( binds name pat -- binds )
- tuck lookup-rule dup backtrace? spin add-bindings ;
-
-: is ( binds val var -- binds ) rot [ set-at ] keep ;
+++ /dev/null
-Implementation of an embedded prolog for factor
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math.constants ;
-IN: random-tester.databank
-
-: databank ( -- array )
- {
- ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
- pi 1/0. -1/0. 0/0. [ ]
- f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
- C{ 2 2 } C{ 1/0. 1/0. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-USING: random-tester.databank random-tester.safe-words
-random-tester.random ;
-IN: random-tester
-
-SYMBOL: errored
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-ERROR: random-tester-error ;
-
-: setup-test ( #data #code -- data... quot )
- #! Variable stack effect
- >r [ databank random ] times r>
- ! 200 300 random-cond ;
- ! random-if ;
- [ drop \ safe-words get random ] map >quotation ;
-
-: test-compiler ! ( data... quot -- ... )
- errored off
- dup quot set
- datastack 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ errored on ] recover ;
-
-: do-test ! ( data... quot -- )
- .s flush test-compiler
- errored get [
- datastack after get 2dup = [
- 2drop
- ] [
- [ . ] each
- "--" print
- [ . ] each
- quot get .
- random-tester-error
- ] if
- ] unless clear ;
-
-: random-test1 ( #data #code -- )
- setup-test do-test ;
-
-: random-test2 ( -- )
- 3 2 setup-test do-test ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint random
-math.constants math.functions layouts random-tester.utils
-random-tester.safe-words quotations fry combinators ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
-: random-quot ( n -- quot )
- [ \ safe-words get random ] replicate >quotation ;
-
-: random-if ( n -- quot )
- [ random-quot ] [ random-quot ] bi
- '[ , , if ] ;
-
-: random-cond ( m n -- quot )
- [ '[ , [ random-quot ] [ random-quot ] bi 2array ] replicate ]
- [ random-quot ] bi suffix
- '[ , cond ] ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel namespaces sequences sets sorting vocabs ;
-USING: arrays assocs generic hashtables
-math math.intervals math.parser math.order math.functions
-refs shuffle vectors words ;
-IN: random-tester.safe-words
-
-: ?-words
- {
- /f
-
- bits>float bits>double
- float>bits double>bits
-
- >bignum >boolean >fixnum >float
-
- array? integer? complex? value-ref? ref? key-ref?
- interval? number?
- wrapper? tuple?
- [-1,1]? between? bignum? both? either? eq? equal? even? fixnum?
- float? fp-nan? hashtable? interval-contains? interval-subset?
- interval? key-ref? key? number? odd? pair? power-of-2?
- ratio? rational? real? zero? assoc? curry? vector? callstack?
-
- 2^ not
- ! arrays
- resize-array <array>
- ! assocs
- (assoc-stack)
- new-assoc
- assoc-like
- <hashtable>
- all-integers? (all-integers?) ! hangs?
- assoc-push-if
-
- (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
- } ;
-
-: bignum-words
- {
- next-power-of-2 (next-power-of-2)
- times
- hashcode hashcode*
- } ;
-
-: initialization-words
- {
- init-namespaces
- } ;
-
-: stack-words
- {
- dup
- drop 2drop 3drop
- roll -roll 2swap
-
- >r r>
- } ;
-
-: stateful-words
- {
- counter
- gensym
- } ;
-
-: foo-words
- {
- set-retainstack
- retainstack callstack
- datastack
- callstack>array
-
- curry 2curry 3curry compose 3compose
- (assoc-each)
- } ;
-
-: exit-words
- {
- call-clear die
- } ;
-
-: bad-words ( -- array )
- [
- ?-words %
- bignum-words %
- initialization-words %
- stack-words %
- stateful-words %
- exit-words %
- foo-words %
- ] { } make ;
-
-: safe-words ( -- array )
- {
- ! "accessors"
- "alists" "arrays" "assocs" "bit-arrays" "byte-arrays"
- ! "classes" "combinators" "compiler" "continuations"
- ! "core-foundation" "definitions" "documents"
- ! "float-arrays" "generic" "graphs" "growable"
- "hashtables" ! io.*
- "kernel" "math"
- "math.bitfields" "math.complex" "math.constants" "math.floats"
- "math.functions" "math.integers" "math.intervals" "math.libm"
- "math.parser" "math.order" "math.ratios" "math.vectors"
- ! "namespaces"
- "quotations" "sbufs"
- ! "queues" "strings" "sequences"
- "sets"
- "vectors"
- ! "words"
- } [ words ] map concat bad-words diff natural-sort ;
-
-safe-words \ safe-words set-global
-
-! foo dup (clone) = .
-! foo dup clone = .
-! f [ byte-array>bignum assoc-clone-like ] compile-1
-! 2 3.14 [ number= ] compile-1
-! 3.14 [ <vector> assoc? ] compile-1
-! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
-! : foo ( x -- y ) euler bitand ; { foo } compile 20 foo
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize namespaces quotations random sequences
-sequences.private shuffle ;
-IN: random-tester.utils
-
-: %chance ( n -- ? )
- 100 random > ;
-
-: 10% ( -- ? ) 10 %chance ;
-: 20% ( -- ? ) 20 %chance ;
-: 30% ( -- ? ) 30 %chance ;
-: 40% ( -- ? ) 40 %chance ;
-: 50% ( -- ? ) 50 %chance ;
-: 60% ( -- ? ) 60 %chance ;
-: 70% ( -- ? ) 70 %chance ;
-: 80% ( -- ? ) 80 %chance ;
-: 90% ( -- ? ) 90 %chance ;
-
-: call-if ( quot ? -- ) swap when ; inline
-
-: with-10% ( quot -- ) 10% call-if ; inline
-: with-20% ( quot -- ) 20% call-if ; inline
-: with-30% ( quot -- ) 30% call-if ; inline
-: with-40% ( quot -- ) 40% call-if ; inline
-: with-50% ( quot -- ) 50% call-if ; inline
-: with-60% ( quot -- ) 60% call-if ; inline
-: with-70% ( quot -- ) 70% call-if ; inline
-: with-80% ( quot -- ) 80% call-if ; inline
-: with-90% ( quot -- ) 90% call-if ; inline
-
-: random-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays quotations sequences assocs combinators
+ mirrors math math.vectors random macros fry ;
+
+IN: random-weighted
+
+: probabilities ( weights -- probabilities ) dup sum v/n ;
+
+: layers ( probabilities -- layers )
+dup length 1+ [ head ] with map rest [ sum ] map ;
+
+: random-weighted ( weights -- elt )
+probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
+
+: random-weighted* ( seq -- elt )
+dup [ second ] map swap [ first ] map random-weighted swap nth ;
+
+MACRO: call-random-weighted ( exp -- )
+ [ keys ] [ values <enum> >alist ] bi
+ '[ _ random-weighted _ case ] ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: namespaces threads
- unix.process unix.linux.if unix.linux.ifreq unix.linux.route
- raptor.cron ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Networking
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: configure-lo ( -- )
- "lo" "127.0.0.1" set-if-addr
- "lo" { IFF_UP } flags set-if-flags ;
-
-: configure-eth1 ( -- )
- "eth1" "192.168.1.10" set-if-addr
- "eth1" { IFF_UP IFF_MULTICAST } flags set-if-flags ;
-
-: configure-route ( -- )
- "0.0.0.0" "192.168.1.1" "0.0.0.0" { RTF_UP RTF_GATEWAY } flags route ;
-
-[
- configure-lo
- configure-eth1
- configure-route
-] networking-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Filesystems
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-"/dev/hda1" root-device set-global
-
-{ "/dev/hda5" } swap-devices set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! boot-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- start-wait-loop
-
- ! rcS.d
-
- "mountvirtfs" start-service
-
- ! "hostname.sh" start-service
- "narodnik" set-hostname
-
- "keymap.sh" start-service
- "linux-restricted-modules-common" start-service
- "udev" start-service
- "mountdevsubfs" start-service
- "module-init-tools" start-service
- "procps.sh" start-service
-
- ! "checkroot.sh" start-service
-
- activate-swap
- mount-root
-
- "mtab" start-service
- "checkfs.sh" start-service
- "mountall.sh" start-service
-
- start-networking
-! "loopback" start-service
-! "networking" start-service
-
- "hwclock.sh" start-service
- "displayconfig-hwprobe.py" start-service
- "screen" start-service
- "x11-common" start-service
- "bootmisc.sh" start-service
- "urandom" start-service
-
- ! rc2.d
-
- "vbesave" start-service
- "acpid" start-service
- "powernowd.early" start-service
- "sysklogd" start-service
- "klogd" start-service
- "dbus" start-service
- "apmd" start-service
- "hotkey-setup" start-service
- "laptop-mode" start-service
- "makedev" start-service
- "nvidia-kernel" start-service
- "postfix" start-service
- "powernowd" start-service
- "ntp-server" start-service
- "binfmt-support" start-service
- "acpi-support" start-service
- "rc.local" start-service
- "rmnologin" start-service
-
- schedule-cron-jobs
-
- [ [ "/dev/tty2" tty-listener ] forever ] in-thread
- [ [ "/dev/tty3" tty-listener ] forever ] in-thread
- [ [ "/dev/tty4" tty-listener ] forever ] in-thread
- [ [ "/dev/tty5" getty ] forever ] in-thread
- [ [ "/dev/tty6" getty ] forever ] in-thread
-
-] boot-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! reboot-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "acpi-support" stop-service
- "apmd" stop-service
- "dbus" stop-service
- "hotkey-setup" stop-service
- "laptop-mode" stop-service
- "makedev" stop-service
- "nvidia-kernel" stop-service
- "powernowd" stop-service
- "acpid" stop-service
- "hwclock.sh" stop-service
- "alsa-utils" stop-service
- "klogd" stop-service
- "binfmt-support" stop-service
- "sysklogd" stop-service
- "linux-restricted-modules-common" stop-service
- "sendsigs" stop-service
- "urandom" stop-service
- "umountnfs.sh" stop-service
- "networking" stop-service
- "umountfs" stop-service
- "umountroot" stop-service
- "reboot" stop-service
-] reboot-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! shutdown-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "acpi-support" stop-service
- "apmd" stop-service
- "dbus" stop-service
- "hotkey-setup" stop-service
- "laptop-mode" stop-service
- "makedev" stop-service
- "nvidia-kernel" stop-service
- "postfix" stop-service
- "powernowd" stop-service
- "acpid" stop-service
- "hwclock.sh" stop-service
- "alsa-utils" stop-service
- "klogd" stop-service
- "binfmt-support" stop-service
- "sysklogd" stop-service
- "linux-restricted-modules-common" stop-service
- "sendsigs" stop-service
- "urandom" stop-service
- "umountnfs.sh" stop-service
- "umountfs" stop-service
- "umountroot" stop-service
- "halt" stop-service
-] shutdown-hook set-global
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces threads sequences calendar
- combinators.lib debugger ;
-
-IN: raptor.cron
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: when minute hour day-of-month month day-of-week ;
-
-C: <when> when
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: slot-match? ( now-slot when-slot -- ? ) dup f = [ 2drop t ] [ member? ] if ;
-
-: minute-match? ( now when -- ? )
- [ timestamp-minute ] [ when-minute ] bi* slot-match? ;
-
-: hour-match? ( now when -- ? )
- [ timestamp-hour ] [ when-hour ] bi* slot-match? ;
-
-: day-of-month-match? ( now when -- ? )
- [ timestamp-day ] [ when-day-of-month ] bi* slot-match? ;
-
-: month-match? ( now when -- ? )
- [ timestamp-month ] [ when-month ] bi* slot-match? ;
-
-: day-of-week-match? ( now when -- ? )
- [ day-of-week ] [ when-day-of-week ] bi* slot-match? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: when=now? ( when -- ? )
- now swap
- { [ minute-match? ]
- [ hour-match? ]
- [ day-of-month-match? ]
- [ month-match? ]
- [ day-of-week-match? ] }
- <--&& ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recurring-job ( when quot -- )
- [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
-
-: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: cron-jobs-hourly
-SYMBOL: cron-jobs-daily
-SYMBOL: cron-jobs-weekly
-SYMBOL: cron-jobs-monthly
-
-: schedule-cron-jobs ( -- )
- { 17 } f f f f <when> [ cron-jobs-hourly get call ] schedule
- { 25 } { 6 } f f f <when> [ cron-jobs-daily get call ] schedule
- { 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly get call ] schedule
- { 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;
-
+++ /dev/null
-unportable
+++ /dev/null
-
-USING: kernel namespaces threads arrays sequences
- raptor raptor.cron ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "/etc/cron.daily/apt" fork-exec-arg
- "/etc/cron.daily/aptitude" fork-exec-arg
- "/etc/cron.daily/bsdmainutils" fork-exec-arg
- "/etc/cron.daily/find.notslocate" fork-exec-arg
- "/etc/cron.daily/logrotate" fork-exec-arg
- "/etc/cron.daily/man-db" fork-exec-arg
- "/etc/cron.daily/ntp-server" fork-exec-arg
- "/etc/cron.daily/slocate" fork-exec-arg
- "/etc/cron.daily/standard" fork-exec-arg
- "/etc/cron.daily/sysklogd" fork-exec-arg
- "/etc/cron.daily/tetex-bin" fork-exec-arg
-] cron-jobs-daily set-global
-
-[
- "/etc/cron.weekly/cvs" fork-exec-arg
- "/etc/cron.weekly/man-db" fork-exec-arg
- "/etc/cron.weekly/ntp-server" fork-exec-arg
- "/etc/cron.weekly/popularity-contest" fork-exec-arg
- "/etc/cron.weekly/sysklogd" fork-exec-arg
-] cron-jobs-weekly set-global
-
-[
- "/etc/cron.monthly/scrollkeeper" fork-exec-arg
- "/etc/cron.monthly/standard" fork-exec-arg
-] cron-jobs-monthly set-global
\ No newline at end of file
+++ /dev/null
-
-USING: kernel parser namespaces threads arrays sequences unix unix.process
- bake ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: boot-hook
-SYMBOL: reboot-hook
-SYMBOL: shutdown-hook
-SYMBOL: networking-hook
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reload-raptor-config ( -- )
- "/etc/raptor/config.factor" run-file
- "/etc/raptor/cronjobs.factor" run-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fork-exec-wait ( pathname args -- )
- fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
-
-: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
-
-: fork-exec-arg ( arg -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: forever ( quot -- ) [ call ] [ forever ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ;
-: stop-service ( name -- ) "/etc/init.d/" " stop" surround system drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
- listener io.encodings.utf8 ;
-
-: tty-listener ( tty -- )
- dup utf8 <file-reader> [
- swap utf8 <file-writer> [
- <duplex-stream> [
- listener
- ] with-stream
- ] with-disposal
- ] with-disposal ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: unix.linux.swap unix.linux.fs ;
-
-SYMBOL: root-device
-SYMBOL: swap-devices
-
-: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
-
-: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-networking ( -- ) networking-hook get call ;
-
-: set-hostname ( name -- ) `{ "/bin/hostname" , } fork-exec-args-wait ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boot ( -- ) boot-hook get call ;
-: reboot ( -- ) reboot-hook get call ;
-: shutdown ( -- ) shutdown-hook get call ;
-
-MAIN: boot
-
+++ /dev/null
-
-Raptor Linux
-
-*** Introduction ***
-
-Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
-
-This is unlikely to work on another version of Ubuntu, much less
-another Linux distribution.
-
-*** Features ***
-
- * /sbin/init is replaced with Factor
- * Virtual terminals managed by Factor
- * Listeners run on virtual terminals
- * Native support for static ip networking
- * Crontab replacement
-
-*** Install ***
-
- # mkdir -v /etc/raptor
-
- # cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
-
- ( scratchpad ) USE: raptor
- ( scratchpad ) reload-raptor-config
- ( scratchpad ) save
-
- # mv -v /sbin/{init,init.orig}
-
- # cp -v /scratch/factor/factor /sbin/init
-
- # cp -v /scratch/factor/factor.image /sbin/init.image
-
-*** Filesystems ***
-
- # emacs /etc/raptor/config.factor
-
-Edit the root-device and swap-devices variables.
-
-*** Static IP networking ***
-
-If you use a static IP in your network then Factor can take care of
-networking.
-
- # emacs /etc/raptor/config.factor
-
- (change the settings accordingly)
-
-The udev system has a hook to bring up ethernet interfaces when they
-are detected. Let's remove this hook since we'll be bringing up the
-interface. Actually, we'll move it, not delete it.
-
- # mv -v /etc/udev/rules.d/85-ifupdown.rules /root
-
-*** DHCP networking ***
-
-If you're using dhcp then we'll fall back on what Ubuntu offers. In
-your config.factor change the line :
-
- start-networking
-
-to
-
- "loopback" start-service
- "networking" start-service
-
-Add these to your reboot-hook and shutdown-hook :
-
- "loopback" stop-service
- "networking" stop-service
-
-*** Editing the hooks ***
-
-The items in boot-hook correspond to the things in '/etc/rcS.d' and
-'/etc/rc2.d'. Feel free to add and remove items from that hook. For
-example, I removed the printer services. I also removed other things
-that I didn't feel were necessary on my system.
-
-Look for the line with the call to 'set-hostname' and edit it appropriately.
-
-*** Grub ***
-
-Edit your '/boot/grub/menu.lst'. Basically, copy and paste your
-current good entry. My default entry is this:
-
-title Ubuntu, kernel 2.6.15-28-686
-root (hd0,0)
-kernel /boot/vmlinuz-2.6.15-28-686 root=/dev/hda1 ro quiet splash
-initrd /boot/initrd.img-2.6.15-28-686
-savedefault
-boot
-
-I pasted a copy above it and edited it to look like this:
-
-title Raptor, kernel 2.6.15-28-686
-root (hd0,0)
-kernel /boot/vmlinuz-2.6.15-28-686 root=/dev/hda1 ro quiet -run=ubuntu.dapper.boot
-initrd /boot/initrd.img-2.6.15-28-686
-savedefault
-boot
-
-* Note that I removed the 'splash' kernel option
-
-* Note the '-run=ubuntu.dapper.boot' option. Unfortunately, this isn't
- working yet...
-
-*** Boot ***
-
-Reboot or turn on your computer. Eventually, hopefully, you'll be at a
-Factor prompt. Boot your system:
-
- ( scratchpad ) boot
-
-You'll probably be prompted to select a vocab. Select 'raptor'.
-
-*** Now what ***
-
-The virtual consoles are allocated like so:
-
- 1 - Main listener console
- 2 - listener
- 3 - listener
- 4 - listener
- 5 - getty
- 6 - getty
-
-So you're next step might be to alt-f5, login, and run startx.
-
-*** Join the fun ***
-
-Take a loot at what happens during run levels S and 2. Implement a
-Factor version of something. Let me know about it.
-
+++ /dev/null
-unportable
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.route
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-STRUCT: struct-rtentry
- { "ulong" "rt_pad1" }
- { "struct-sockaddr" "rt_dst" }
- { "struct-sockaddr" "rt_gateway" }
- { "struct-sockaddr" "rt_genmask" }
- { "ushort" "rt_flags" }
- { "short" "rt_pad2" }
- { "ulong" "rt_pad3" }
- { "uchar" "rt_tos" }
- { "uchar" "rt_class" }
- { "short" "rt_pad4" }
- { "short" "rt_metric" }
- { "char*" "rt_dev" }
- { "ulong" "rt_mtu" }
- { "ulong" "rt_window" }
- { "ushort" "rt_irtt" } ;
-
-: RTF_UP HEX: 0001 ; ! Route usable.
-: RTF_GATEWAY HEX: 0002 ; ! Destination is a gateway.
-
-: RTF_HOST HEX: 0004 ; ! Host entry (net otherwise).
-: RTF_REINSTATE HEX: 0008 ; ! Reinstate route after timeout.
-: RTF_DYNAMIC HEX: 0010 ; ! Created dyn. (by redirect).
-: RTF_MODIFIED HEX: 0020 ; ! Modified dyn. (by redirect).
-: RTF_MTU HEX: 0040 ; ! Specific MTU for this route.
-: RTF_MSS RTF_MTU ; ! Compatibility.
-: RTF_WINDOW HEX: 0080 ; ! Per route window clamping.
-: RTF_IRTT HEX: 0100 ; ! Initial round trip time.
-: RTF_REJECT HEX: 0200 ; ! Reject route.
-: RTF_STATIC HEX: 0400 ; ! Manually injected route.
-: RTF_XRESOLVE HEX: 0800 ; ! External resolver.
-: RTF_NOFORWARD HEX: 1000 ; ! Forwarding inhibited.
-: RTF_THROW HEX: 2000 ; ! Go to next class.
-: RTF_NOPMTUDISC HEX: 4000 ; ! Do not send packets with DF.
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: kernel alien.c-types io.sockets
- unix unix.linux.sockios ;
-
-: route ( dst gateway genmask flags -- )
- >r >r >r >r
- "struct-rtentry" <c-object>
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_dst
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_gateway
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_genmask
- r> over set-struct-rtentry-rt_flags
- AF_INET SOCK_DGRAM 0 socket SIOCADDRT rot ioctl drop ;
+++ /dev/null
-unportable
+++ /dev/null
-Eduardo Cavazos
-Doug Coleman
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences\r
-quotations math ;\r
-IN: sequences.lib\r
-\r
-HELP: map-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }\r
-{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to map-withn for each element in the sequence."\r
-} \r
-{ $examples\r
- { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
-}\r
-{ $see-also each-withn } ;\r
-\r
-HELP: each-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }\r
-{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to each-withn for each element in the sequence."\r
-} \r
-{ $see-also map-withn } ;\r
-\r
-HELP: randomize\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Shuffle the elements in the sequence randomly, returning the new sequence." } ;\r
-\r
-HELP: enumerate\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Returns a new sequence where each element is an array of { index, value }" } ;\r
-\r
+++ /dev/null
-USING: arrays kernel sequences sequences.lib math math.functions math.ranges
- tools.test strings ;
-IN: sequences.lib.tests
-
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
-[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
-
-[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
-[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
-
-[ { 1 2 3 4 } ] [ { { 1 2 3 4 } { 1 2 3 } } longest ] unit-test
-[ { 1 2 3 4 } ] [ { { 1 2 3 } { 1 2 3 4 } } longest ] unit-test
-
-[ { 1 2 3 } ] [ { { 1 2 3 4 } { 1 2 3 } } shortest ] unit-test
-[ { 1 2 3 } ] [ { { 1 2 3 } { 1 2 3 4 } } shortest ] unit-test
-
-[ 3 ] [ 1 3 bigger ] unit-test
-[ 1 ] [ 1 3 smaller ] unit-test
-
-[ "abd" ] [ "abc" "abd" bigger ] unit-test
-[ "abc" ] [ "abc" "abd" smaller ] unit-test
-
-[ "abe" ] [ { "abc" "abd" "abe" } biggest ] unit-test
-[ "abc" ] [ { "abc" "abd" "abe" } smallest ] unit-test
-
-[ 1 3 ] [ { 1 2 3 } minmax ] unit-test
-[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
-[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
-
-[ { { 1 } { -1 5 } { 2 4 } } ]
-[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
-[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
-[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-
-[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
-[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
-
-[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
-[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
-[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ { { 0 1 } { 1 2 } { 2 3 } } ] [ { 1 2 3 } enumerate ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
-! Eduardo Cavazos, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel sequences math namespaces make
-assocs random sequences.private shuffle math.functions arrays
-math.parser math.private sorting strings ascii macros assocs.lib
-quotations hashtables math.order locals generalizations
-math.ranges random fry ;
-IN: sequences.lib
-
-: each-withn ( seq quot n -- ) nwith each ; inline
-
-: each-with ( seq quot -- ) with each ; inline
-
-: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
-
-: map-withn ( seq quot n -- newseq ) nwith map ; inline
-
-: map-with ( seq quot -- ) with map ; inline
-
-: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- [
- dup length
- dup [ / ] curry
- [ 1+ ] prepose
- ] dip compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
-
-: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer ( a b -- c ) [ length ] higher ;
-
-: shorter ( a b -- c ) [ length ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longest ( seq -- item ) [ longer ] reduce* ;
-
-: shortest ( seq -- item ) [ shorter ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bigger ( a b -- c ) [ ] higher ;
-
-: smaller ( a b -- c ) [ ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: biggest ( seq -- item ) [ bigger ] reduce* ;
-
-: smallest ( seq -- item ) [ smaller ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: minmax ( seq -- min max )
- #! find the min and max of a seq in one pass
- 1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ,, ( obj -- ) building get peek push ;
-: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
-
-: (monotonic-split) ( seq quot -- newseq )
- [
- [ dup unclip suffix ] dip
- v, [ pick ,, call [ v, ] unless ] curry 2each ,v
- ] { } make ;
-
-: monotonic-split ( seq quot -- newseq )
- over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
-
-ERROR: element-not-found ;
-: split-around ( seq quot -- before elem after )
- dupd find over [ element-not-found ] unless
- [ cut rest ] dip swap ; inline
-
-: map-until ( seq quot pred -- newseq )
- '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
-
-: take-while ( seq quot -- newseq )
- [ not ] compose
- [ find drop [ head-slice ] when* ] curry
- [ dup ] prepose keep like ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: translate-string ( n alphabet out-len -- seq )
- [ drop /mod ] with map nip ;
-
-: map-alphabet ( alphabet seq[seq] -- seq[seq] )
- [ [ swap nth ] with map ] with map ;
-
-: exact-number-strings ( n out-len -- seqs )
- [ ^ ] 2keep [ translate-string ] 2curry map ;
-
-: number-strings ( n max-length -- seqs )
- 1+ [ exact-number-strings ] with map concat ;
-PRIVATE>
-
-: exact-strings ( alphabet length -- seqs )
- [ dup length ] dip exact-number-strings map-alphabet ;
-
-: strings ( alphabet length -- seqs )
- [ dup length ] dip number-strings map-alphabet ;
-
-: switches ( seq1 seq -- subseq )
- ! seq1 is a sequence of ones and zeroes
- [ [ length ] keep [ nth 1 = ] curry filter ] dip
- [ nth ] curry { } map-as ;
-
-: power-set ( seq -- subsets )
- 2 over length exact-number-strings swap [ switches ] curry map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: (attempt-each-integer) ( i n quot -- result )
- [
- iterate-step roll
- [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
- ] [ 3drop f ] if-iterate? ; inline recursive
-PRIVATE>
-
-: attempt-each ( seq quot -- result )
- (each) iterate-prep (attempt-each-integer) ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: randomize ( seq -- seq' )
- dup length 1 (a,b] [ dup random pick exchange ] each ;
-
-: enumerate ( seq -- seq' ) <enum> >alist ;
+++ /dev/null
-Non-core sequence words
+++ /dev/null
-collections
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-IN: unix.linux.sockios
-
-! Imported from linux-headers-2.6.15-28-686 on Ubuntu 6.06
-
-! Routing table calls
-: SIOCADDRT HEX: 890B ; ! add routing table entry
-: SIOCDELRT HEX: 890C ; ! delete routing table entry
-: SIOCRTMSG HEX: 890D ; ! call to routing system
-
-! Socket configuration controls
-
-: SIOCGIFNAME HEX: 8910 ; ! get iface name
-: SIOCSIFLINK HEX: 8911 ; ! set iface channel
-: SIOCGIFCONF HEX: 8912 ; ! get iface list
-: SIOCGIFFLAGS HEX: 8913 ; ! get flags
-: SIOCSIFFLAGS HEX: 8914 ; ! set flags
-: SIOCGIFADDR HEX: 8915 ; ! get PA address
-: SIOCSIFADDR HEX: 8916 ; ! set PA address
-: SIOCGIFDSTADDR HEX: 8917 ; ! get remote PA address
-: SIOCSIFDSTADDR HEX: 8918 ; ! set remote PA address
-: SIOCGIFBRDADDR HEX: 8919 ; ! get broadcast PA address
-: SIOCSIFBRDADDR HEX: 891a ; ! set broadcast PA address
-: SIOCGIFNETMASK HEX: 891b ; ! get network PA mask
-: SIOCSIFNETMASK HEX: 891c ; ! set network PA mask
-: SIOCGIFMETRIC HEX: 891d ; ! get metric
-: SIOCSIFMETRIC HEX: 891e ; ! set metric
-: SIOCGIFMEM HEX: 891f ; ! get memory address (BSD)
-: SIOCSIFMEM HEX: 8920 ; ! set memory address (BSD)
-: SIOCGIFMTU HEX: 8921 ; ! get MTU size
-: SIOCSIFMTU HEX: 8922 ; ! set MTU size
-: SIOCSIFNAME HEX: 8923 ; ! set interface name
-: SIOCSIFHWADDR HEX: 8924 ; ! set hardware address
-: SIOCGIFENCAP HEX: 8925 ; ! get/set encapsulations
-: SIOCSIFENCAP HEX: 8926 ;
-: SIOCGIFHWADDR HEX: 8927 ; ! Get hardware address
-: SIOCGIFSLAVE HEX: 8929 ; ! Driver slaving support
-: SIOCSIFSLAVE HEX: 8930 ;
-: SIOCADDMULTI HEX: 8931 ; ! Multicast address lists
-: SIOCDELMULTI HEX: 8932 ;
-: SIOCGIFINDEX HEX: 8933 ; ! name -> if_index mapping
-: SIOGIFINDEX SIOCGIFINDEX ; ! misprint compatibility :-)
-: SIOCSIFPFLAGS HEX: 8934 ; ! set/get extended flags set
-: SIOCGIFPFLAGS HEX: 8935 ;
-: SIOCDIFADDR HEX: 8936 ; ! delete PA address
-: SIOCSIFHWBROADCAST HEX: 8937 ; ! set hardware broadcast addr
-: SIOCGIFCOUNT HEX: 8938 ; ! get number of devices
-
-: SIOCGIFBR HEX: 8940 ; ! Bridging support
-: SIOCSIFBR HEX: 8941 ; ! Set bridging options
-
-: SIOCGIFTXQLEN HEX: 8942 ; ! Get the tx queue length
-: SIOCSIFTXQLEN HEX: 8943 ; ! Set the tx queue length
-
-: SIOCGIFDIVERT HEX: 8944 ; ! Frame diversion support
-: SIOCSIFDIVERT HEX: 8945 ; ! Set frame diversion options
-
-: SIOCETHTOOL HEX: 8946 ; ! Ethtool interface
-
-: SIOCGMIIPHY HEX: 8947 ; ! Get address of MII PHY in use
-: SIOCGMIIREG HEX: 8948 ; ! Read MII PHY register.
-: SIOCSMIIREG HEX: 8949 ; ! Write MII PHY register.
-
-: SIOCWANDEV HEX: 894A ; ! get/set netdev parameters
+++ /dev/null
-unportable
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences math math.vectors random
+ springies springies.ui ;
+
+IN: springies.models.2snake
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.001 >time-slice
+gravity off
+
+1 19.0 328.0 0.0 0.0 1.0 1.0 mass
+2 36.0 328.0 0.0 0.0 1.0 1.0 mass
+3 54.0 328.0 0.0 0.0 1.0 1.0 mass
+4 72.0 328.0 0.0 0.0 1.0 1.0 mass
+5 90.0 328.0 0.0 0.0 1.0 1.0 mass
+6 108.0 328.0 0.0 0.0 1.0 1.0 mass
+7 126.0 328.0 0.0 0.0 1.0 1.0 mass
+8 144.0 328.0 0.0 0.0 1.0 1.0 mass
+9 162.0 328.0 0.0 0.0 1.0 1.0 mass
+10 180.0 328.0 0.0 0.0 1.0 1.0 mass
+11 198.0 328.0 0.0 0.0 1.0 1.0 mass
+12 216.0 328.0 0.0 0.0 1.0 1.0 mass
+13 234.0 328.0 0.0 0.0 1.0 1.0 mass
+14 252.0 328.0 0.0 0.0 1.0 1.0 mass
+15 270.0 328.0 0.0 0.0 1.0 1.0 mass
+16 288.0 328.0 0.0 0.0 1.0 1.0 mass
+17 306.0 328.0 0.0 0.0 1.0 1.0 mass
+18 324.0 328.0 0.0 0.0 1.0 1.0 mass
+19 342.0 328.0 0.0 0.0 1.0 1.0 mass
+20 360.0 328.0 0.0 0.0 1.0 1.0 mass
+21 378.0 328.0 0.0 0.0 1.0 1.0 mass
+22 396.0 328.0 0.0 0.0 1.0 1.0 mass
+23 414.0 328.0 0.0 0.0 1.0 1.0 mass
+24 432.0 328.0 0.0 0.0 1.0 1.0 mass
+25 450.0 328.0 0.0 0.0 1.0 1.0 mass
+26 468.0 328.0 0.0 0.0 1.0 1.0 mass
+27 504.0 328.0 0.0 0.0 1.0 1.0 mass
+28 486.0 328.0 0.0 0.0 1.0 1.0 mass
+29 522.0 328.0 0.0 0.0 1.0 1.0 mass
+30 540.0 328.0 0.0 0.0 1.0 1.0 mass
+31 558.0 328.0 0.0 0.0 1.0 1.0 mass
+32 576.0 328.0 0.0 0.0 1.0 1.0 mass
+33 594.0 328.0 0.0 0.0 1.0 1.0 mass
+34 612.0 328.0 0.0 0.0 1.0 1.0 mass
+35 630.0 328.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 19 20 200.0 1.500000 18.0 spng
+20 20 21 200.0 1.500000 18.0 spng
+21 21 22 200.0 1.500000 18.0 spng
+22 22 23 200.0 1.500000 18.0 spng
+23 23 24 200.0 1.500000 18.0 spng
+24 24 25 200.0 1.500000 18.0 spng
+25 25 26 200.0 1.500000 18.0 spng
+26 26 28 200.0 1.500000 18.0 spng
+27 28 27 200.0 1.500000 18.0 spng
+28 27 29 200.0 1.500000 18.0 spng
+29 29 30 200.0 1.500000 18.0 spng
+30 30 31 200.0 1.500000 18.0 spng
+31 31 32 200.0 1.500000 18.0 spng
+32 32 33 200.0 1.500000 18.0 spng
+33 33 34 200.0 1.500000 18.0 spng
+34 34 35 200.0 1.500000 18.0 spng
+35 1 3 200.0 1.500000 36.0 spng
+36 2 4 200.0 1.500000 36.0 spng
+37 3 5 200.0 1.500000 36.0 spng
+38 4 6 200.0 1.500000 36.0 spng
+39 5 7 200.0 1.500000 36.0 spng
+40 6 8 200.0 1.500000 36.0 spng
+41 7 9 200.0 1.500000 36.0 spng
+42 8 10 200.0 1.500000 36.0 spng
+43 9 11 200.0 1.500000 36.0 spng
+44 10 12 200.0 1.500000 36.0 spng
+45 11 13 200.0 1.500000 36.0 spng
+46 12 14 200.0 1.500000 36.0 spng
+47 13 15 200.0 1.500000 36.0 spng
+48 14 16 200.0 1.500000 36.0 spng
+49 15 17 200.0 1.500000 36.0 spng
+50 16 18 200.0 1.500000 36.0 spng
+51 17 19 200.0 1.500000 36.0 spng
+52 18 20 200.0 1.500000 36.0 spng
+53 19 21 200.0 1.500000 36.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 28 200.0 1.500000 36.0 spng
+60 26 27 200.0 1.500000 36.0 spng
+61 28 29 200.0 1.500000 36.0 spng
+62 27 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+
+nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ;
+
+USING: threads ui ;
+
+: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random springies springies.ui ;
+
+IN: springies.models.2x2snake
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.002 >time-slice
+gravity off
+
+1 147.0 324.0 0.0 0.0 1.0 1.0 mass
+2 164.0 324.0 0.0 0.0 1.0 1.0 mass
+3 182.0 324.0 0.0 0.0 1.0 1.0 mass
+4 200.0 324.0 0.0 0.0 1.0 1.0 mass
+5 218.0 324.0 0.0 0.0 1.0 1.0 mass
+6 236.0 324.0 0.0 0.0 1.0 1.0 mass
+7 254.0 324.0 0.0 0.0 1.0 1.0 mass
+8 272.0 324.0 0.0 0.0 1.0 1.0 mass
+9 290.0 324.0 0.0 0.0 1.0 1.0 mass
+10 308.0 324.0 0.0 0.0 1.0 1.0 mass
+11 326.0 324.0 0.0 0.0 1.0 1.0 mass
+12 344.0 324.0 0.0 0.0 1.0 1.0 mass
+13 362.0 324.0 0.0 0.0 1.0 1.0 mass
+14 380.0 324.0 0.0 0.0 1.0 1.0 mass
+15 398.0 324.0 0.0 0.0 1.0 1.0 mass
+16 416.0 324.0 0.0 0.0 1.0 1.0 mass
+17 434.0 324.0 0.0 0.0 1.0 1.0 mass
+18 452.0 324.0 0.0 0.0 1.0 1.0 mass
+19 470.0 324.0 0.0 0.0 1.0 1.0 mass
+20 147.0 298.0 0.0 0.0 1.0 1.0 mass
+21 164.0 298.0 0.0 0.0 1.0 1.0 mass
+22 182.0 298.0 0.0 0.0 1.0 1.0 mass
+23 200.0 298.0 0.0 0.0 1.0 1.0 mass
+24 218.0 298.0 0.0 0.0 1.0 1.0 mass
+25 236.0 298.0 0.0 0.0 1.0 1.0 mass
+26 254.0 298.0 0.0 0.0 1.0 1.0 mass
+27 272.0 298.0 0.0 0.0 1.0 1.0 mass
+28 290.0 298.0 0.0 0.0 1.0 1.0 mass
+29 308.0 298.0 0.0 0.0 1.0 1.0 mass
+30 326.0 298.0 0.0 0.0 1.0 1.0 mass
+31 344.0 298.0 0.0 0.0 1.0 1.0 mass
+32 362.0 298.0 0.0 0.0 1.0 1.0 mass
+33 380.0 298.0 0.0 0.0 1.0 1.0 mass
+34 398.0 298.0 0.0 0.0 1.0 1.0 mass
+35 416.0 298.0 0.0 0.0 1.0 1.0 mass
+36 434.0 298.0 0.0 0.0 1.0 1.0 mass
+37 452.0 298.0 0.0 0.0 1.0 1.0 mass
+38 470.0 298.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 1 3 200.0 1.500000 36.0 spng
+20 2 4 200.0 1.500000 36.0 spng
+21 3 5 200.0 1.500000 36.0 spng
+22 4 6 200.0 1.500000 36.0 spng
+23 5 7 200.0 1.500000 36.0 spng
+24 6 8 200.0 1.500000 36.0 spng
+25 7 9 200.0 1.500000 36.0 spng
+26 8 10 200.0 1.500000 36.0 spng
+27 9 11 200.0 1.500000 36.0 spng
+28 10 12 200.0 1.500000 36.0 spng
+29 11 13 200.0 1.500000 36.0 spng
+30 12 14 200.0 1.500000 36.0 spng
+31 13 15 200.0 1.500000 36.0 spng
+32 14 16 200.0 1.500000 36.0 spng
+33 15 17 200.0 1.500000 36.0 spng
+34 16 18 200.0 1.500000 36.0 spng
+35 17 19 200.0 1.500000 36.0 spng
+36 20 21 200.0 1.500000 18.0 spng
+37 22 21 200.0 1.500000 18.0 spng
+38 22 23 200.0 1.500000 18.0 spng
+39 23 24 200.0 1.500000 18.0 spng
+40 24 25 200.0 1.500000 18.0 spng
+41 25 26 200.0 1.500000 18.0 spng
+42 26 27 200.0 1.500000 18.0 spng
+43 27 28 200.0 1.500000 18.0 spng
+44 28 29 200.0 1.500000 18.0 spng
+45 29 30 200.0 1.500000 18.0 spng
+46 30 31 200.0 1.500000 18.0 spng
+47 31 32 200.0 1.500000 18.0 spng
+48 32 33 200.0 1.500000 18.0 spng
+49 33 34 200.0 1.500000 18.0 spng
+50 34 35 200.0 1.500000 18.0 spng
+51 35 36 200.0 1.500000 18.0 spng
+52 36 37 200.0 1.500000 18.0 spng
+53 37 38 200.0 1.500000 18.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 27 200.0 1.500000 36.0 spng
+60 26 28 200.0 1.500000 36.0 spng
+61 27 29 200.0 1.500000 36.0 spng
+62 28 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+68 34 36 200.0 1.500000 36.0 spng
+69 35 37 200.0 1.500000 36.0 spng
+70 36 38 200.0 1.500000 36.0 spng
+71 1 20 200.0 1.500000 26.0 spng
+72 2 21 200.0 1.500000 26.0 spng
+73 3 22 200.0 1.500000 26.0 spng
+74 4 23 200.0 1.500000 26.0 spng
+75 5 24 200.0 1.500000 26.0 spng
+76 25 6 200.0 1.500000 26.0 spng
+77 7 26 200.0 1.500000 26.0 spng
+78 27 8 200.0 1.500000 26.0 spng
+79 9 28 200.0 1.500000 26.0 spng
+80 29 10 200.0 1.500000 26.0 spng
+81 11 30 200.0 1.500000 26.0 spng
+82 31 12 200.0 1.500000 26.0 spng
+83 13 32 200.0 1.500000 26.0 spng
+84 33 14 200.0 1.500000 26.0 spng
+85 15 34 200.0 1.500000 26.0 spng
+86 35 16 200.0 1.500000 26.0 spng
+87 17 36 200.0 1.500000 26.0 spng
+88 37 18 200.0 1.500000 26.0 spng
+89 19 38 200.0 1.500000 26.0 spng
+90 1 21 200.0 1.500000 31.064449 spng
+91 2 20 200.0 1.500000 31.064449 spng
+92 2 22 200.0 1.500000 31.622777 spng
+93 3 21 200.0 1.500000 31.622777 spng
+94 3 23 200.0 1.500000 31.622777 spng
+95 4 22 200.0 1.500000 31.622777 spng
+96 4 24 200.0 1.500000 31.622777 spng
+97 5 23 200.0 1.500000 31.622777 spng
+98 5 25 200.0 1.500000 31.622777 spng
+99 6 24 200.0 1.500000 31.622777 spng
+100 6 26 200.0 1.500000 31.622777 spng
+101 7 25 200.0 1.500000 31.622777 spng
+102 7 27 200.0 1.500000 31.622777 spng
+103 8 26 200.0 1.500000 31.622777 spng
+104 8 28 200.0 1.500000 31.622777 spng
+105 9 27 200.0 1.500000 31.622777 spng
+106 9 29 200.0 1.500000 31.622777 spng
+107 10 28 200.0 1.500000 31.622777 spng
+108 10 30 200.0 1.500000 31.622777 spng
+109 11 29 200.0 1.500000 31.622777 spng
+110 11 31 200.0 1.500000 31.622777 spng
+111 12 30 200.0 1.500000 31.622777 spng
+112 12 32 200.0 1.500000 31.622777 spng
+113 13 31 200.0 1.500000 31.622777 spng
+114 13 33 200.0 1.500000 31.622777 spng
+115 14 32 200.0 1.500000 31.622777 spng
+116 14 34 200.0 1.500000 31.622777 spng
+117 15 33 200.0 1.500000 31.622777 spng
+118 15 35 200.0 1.500000 31.622777 spng
+119 16 34 200.0 1.500000 31.622777 spng
+120 16 36 200.0 1.500000 31.622777 spng
+121 17 35 200.0 1.500000 31.622777 spng
+122 17 37 200.0 1.500000 31.622777 spng
+123 18 36 200.0 1.500000 31.622777 spng
+124 18 38 200.0 1.500000 31.622777 spng
+125 19 37 200.0 1.500000 31.622777 spng
+126 1 22 200.0 1.500000 43.600459 spng
+127 3 20 200.0 1.500000 43.600459 spng
+128 2 23 200.0 1.500000 44.407207 spng
+129 4 21 200.0 1.500000 44.407207 spng
+130 3 24 200.0 1.500000 44.407207 spng
+131 5 22 200.0 1.500000 44.407207 spng
+132 4 25 200.0 1.500000 44.407207 spng
+133 6 23 200.0 1.500000 44.407207 spng
+134 5 26 200.0 1.500000 44.407207 spng
+135 7 24 200.0 1.500000 44.407207 spng
+136 6 27 200.0 1.500000 44.407207 spng
+137 8 25 200.0 1.500000 44.407207 spng
+138 7 28 200.0 1.500000 44.407207 spng
+139 9 26 200.0 1.500000 44.407207 spng
+140 8 29 200.0 1.500000 44.407207 spng
+141 10 27 200.0 1.500000 44.407207 spng
+142 9 30 200.0 1.500000 44.407207 spng
+143 11 28 200.0 1.500000 44.407207 spng
+144 10 31 200.0 1.500000 44.407207 spng
+145 12 29 200.0 1.500000 44.407207 spng
+146 11 32 200.0 1.500000 44.407207 spng
+147 13 30 200.0 1.500000 44.407207 spng
+148 12 33 200.0 1.500000 44.407207 spng
+149 14 31 200.0 1.500000 44.407207 spng
+150 13 34 200.0 1.500000 44.407207 spng
+151 15 33 200.0 1.500000 31.622777 spng
+152 32 15 200.0 1.500000 44.407207 spng
+153 14 35 200.0 1.500000 44.407207 spng
+154 16 33 200.0 1.500000 44.407207 spng
+155 15 36 200.0 1.500000 44.407207 spng
+156 34 17 200.0 1.500000 44.407207 spng
+157 16 37 200.0 1.500000 44.407207 spng
+158 18 35 200.0 1.500000 44.407207 spng
+159 17 38 200.0 1.500000 44.407207 spng
+160 19 36 200.0 1.500000 44.407207 spng
+
+! Send the half of the snake in a random direction
+
+nodes> 10 [ swap nth ] with map
+nodes> 10 [ 19 + swap nth ] with map append
+100 random -50 + 100 random 100 + { -1 1 } random * 2array
+[ swap set-node-vel ] curry
+each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-name "springies.models.2x2snake" }
+ { deploy-c-types? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-io 1 }
+}
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math ui random fry
+ springies springies.ui ;
+
+IN: springies.models.3snake
+
+: random-range ( a b -- n ) 1+ over - random + ;
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.001 >time-slice
+gravity off
+
+1 19.0 328.0 0.0 0.0 1.0 1.0 mass
+2 36.0 328.0 0.0 0.0 1.0 1.0 mass
+3 54.0 328.0 0.0 0.0 1.0 1.0 mass
+4 72.0 328.0 0.0 0.0 1.0 1.0 mass
+5 90.0 328.0 0.0 0.0 1.0 1.0 mass
+6 108.0 328.0 0.0 0.0 1.0 1.0 mass
+7 126.0 328.0 0.0 0.0 1.0 1.0 mass
+8 144.0 328.0 0.0 0.0 1.0 1.0 mass
+9 162.0 328.0 0.0 0.0 1.0 1.0 mass
+10 180.0 328.0 0.0 0.0 1.0 1.0 mass
+11 198.0 328.0 0.0 0.0 1.0 1.0 mass
+12 216.0 328.0 0.0 0.0 1.0 1.0 mass
+13 234.0 328.0 0.0 0.0 1.0 1.0 mass
+14 252.0 328.0 0.0 0.0 1.0 1.0 mass
+15 270.0 328.0 0.0 0.0 1.0 1.0 mass
+16 288.0 328.0 0.0 0.0 1.0 1.0 mass
+17 306.0 328.0 0.0 0.0 1.0 1.0 mass
+18 324.0 328.0 0.0 0.0 1.0 1.0 mass
+19 342.0 328.0 0.0 0.0 1.0 1.0 mass
+20 360.0 328.0 0.0 0.0 1.0 1.0 mass
+21 378.0 328.0 0.0 0.0 1.0 1.0 mass
+22 396.0 328.0 0.0 0.0 1.0 1.0 mass
+23 414.0 328.0 0.0 0.0 1.0 1.0 mass
+24 432.0 328.0 0.0 0.0 1.0 1.0 mass
+25 450.0 328.0 0.0 0.0 1.0 1.0 mass
+26 468.0 328.0 0.0 0.0 1.0 1.0 mass
+27 504.0 328.0 0.0 0.0 1.0 1.0 mass
+28 486.0 328.0 0.0 0.0 1.0 1.0 mass
+29 522.0 328.0 0.0 0.0 1.0 1.0 mass
+30 540.0 328.0 0.0 0.0 1.0 1.0 mass
+31 558.0 328.0 0.0 0.0 1.0 1.0 mass
+32 576.0 328.0 0.0 0.0 1.0 1.0 mass
+33 594.0 328.0 0.0 0.0 1.0 1.0 mass
+34 612.0 328.0 0.0 0.0 1.0 1.0 mass
+35 626.0 328.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 19 20 200.0 1.500000 18.0 spng
+20 20 21 200.0 1.500000 18.0 spng
+21 21 22 200.0 1.500000 18.0 spng
+22 22 23 200.0 1.500000 18.0 spng
+23 23 24 200.0 1.500000 18.0 spng
+24 24 25 200.0 1.500000 18.0 spng
+25 25 26 200.0 1.500000 18.0 spng
+26 26 28 200.0 1.500000 18.0 spng
+27 28 27 200.0 1.500000 18.0 spng
+28 27 29 200.0 1.500000 18.0 spng
+29 29 30 200.0 1.500000 18.0 spng
+30 30 31 200.0 1.500000 18.0 spng
+31 31 32 200.0 1.500000 18.0 spng
+32 32 33 200.0 1.500000 18.0 spng
+33 33 34 200.0 1.500000 18.0 spng
+34 34 35 200.0 1.500000 18.0 spng
+35 1 3 200.0 1.500000 36.0 spng
+36 2 4 200.0 1.500000 36.0 spng
+37 3 5 200.0 1.500000 36.0 spng
+38 4 6 200.0 1.500000 36.0 spng
+39 5 7 200.0 1.500000 36.0 spng
+40 6 8 200.0 1.500000 36.0 spng
+41 7 9 200.0 1.500000 36.0 spng
+42 8 10 200.0 1.500000 36.0 spng
+43 9 11 200.0 1.500000 36.0 spng
+44 10 12 200.0 1.500000 36.0 spng
+45 11 13 200.0 1.500000 36.0 spng
+46 12 14 200.0 1.500000 36.0 spng
+47 13 15 200.0 1.500000 36.0 spng
+48 14 16 200.0 1.500000 36.0 spng
+49 15 17 200.0 1.500000 36.0 spng
+50 16 18 200.0 1.500000 36.0 spng
+51 17 19 200.0 1.500000 36.0 spng
+52 18 20 200.0 1.500000 36.0 spng
+53 19 21 200.0 1.500000 36.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 28 200.0 1.500000 36.0 spng
+60 26 27 200.0 1.500000 36.0 spng
+61 28 29 200.0 1.500000 36.0 spng
+62 27 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+68 1 4 200.0 1.500000 53.0 spng
+69 2 5 200.0 1.500000 54.0 spng
+70 3 6 200.0 1.500000 54.0 spng
+71 4 7 200.0 1.500000 54.0 spng
+72 5 8 200.0 1.500000 54.0 spng
+73 6 9 200.0 1.500000 54.0 spng
+74 7 10 200.0 1.500000 54.0 spng
+75 8 11 200.0 1.500000 54.0 spng
+76 9 12 200.0 1.500000 54.0 spng
+77 10 13 200.0 1.500000 54.0 spng
+78 11 14 200.0 1.500000 54.0 spng
+79 12 15 200.0 1.500000 54.0 spng
+80 13 16 200.0 1.500000 54.0 spng
+81 14 17 200.0 1.500000 54.0 spng
+82 15 18 200.0 1.500000 54.0 spng
+83 16 19 200.0 1.500000 54.0 spng
+84 17 20 200.0 1.500000 54.0 spng
+85 18 21 200.0 1.500000 54.0 spng
+86 19 22 200.0 1.500000 54.0 spng
+87 20 23 200.0 1.500000 54.0 spng
+88 21 24 200.0 1.500000 54.0 spng
+89 22 25 200.0 1.500000 54.0 spng
+90 23 26 200.0 1.500000 54.0 spng
+91 24 28 200.0 1.500000 54.0 spng
+92 25 27 200.0 1.500000 54.0 spng
+93 26 29 200.0 1.500000 54.0 spng
+94 28 30 200.0 1.500000 54.0 spng
+95 27 31 200.0 1.500000 54.0 spng
+96 29 32 200.0 1.500000 54.0 spng
+97 30 33 200.0 1.500000 54.0 spng
+98 31 34 200.0 1.500000 54.0 spng
+99 32 35 200.0 1.500000 50.0 spng
+
+10
+[
+ -400 400 random-range -400 400 random-range 2array
+ nodes> random
+ set-node-vel
+]
+times
+
+;
+
+! : go* ( quot -- )
+! [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
+
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
+
+! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces sequences springies springies.ui ;
+
+IN: springies.models.ball
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.01 >time-slice
+gravity on
+
+1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass
+2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass
+3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass
+4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass
+5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass
+6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass
+7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass
+8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass
+9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass
+10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass
+11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass
+12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass
+13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass
+14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass
+15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass
+16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass
+17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass
+18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass
+19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass
+20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass
+21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass
+22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass
+23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass
+24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass
+25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass
+26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass
+27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass
+28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass
+29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass
+30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass
+31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass
+32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass
+33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass
+34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass
+35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass
+36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass
+37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass
+38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass
+39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass
+40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass
+41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass
+42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass
+43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass
+44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass
+45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass
+46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass
+47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass
+48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass
+1 1 2 150.0 2.0 14.0 spng
+2 2 3 150.0 2.0 14.0 spng
+3 3 4 150.0 2.0 14.0 spng
+4 4 5 150.0 2.0 14.0 spng
+5 5 6 150.0 2.0 14.0 spng
+6 6 7 150.0 2.0 14.0 spng
+7 7 8 150.0 2.0 14.0 spng
+8 8 9 150.0 2.0 14.0 spng
+9 9 10 150.0 2.0 14.0 spng
+10 10 11 150.0 2.0 14.0 spng
+11 11 12 150.0 2.0 14.0 spng
+12 12 1 150.0 2.0 14.0 spng
+13 13 14 150.0 2.0 28.0 spng
+14 14 15 150.0 2.0 28.0 spng
+15 15 16 150.0 2.0 28.0 spng
+16 16 17 150.0 2.0 28.0 spng
+17 17 18 150.0 2.0 28.0 spng
+18 18 19 150.0 2.0 28.0 spng
+19 19 20 150.0 2.0 28.0 spng
+20 20 21 150.0 2.0 28.0 spng
+21 21 22 150.0 2.0 28.0 spng
+22 22 23 150.0 2.0 28.0 spng
+23 23 24 150.0 2.0 28.0 spng
+24 24 13 150.0 2.0 28.0 spng
+25 25 26 150.0 2.0 44.0 spng
+26 26 27 150.0 2.0 43.0 spng
+27 27 28 150.0 2.0 44.0 spng
+28 28 29 150.0 2.0 44.0 spng
+29 29 30 150.0 2.0 43.0 spng
+30 30 31 150.0 2.0 44.0 spng
+31 31 32 150.0 2.0 43.0 spng
+32 32 33 150.0 2.0 43.0 spng
+33 33 34 150.0 2.0 44.0 spng
+34 34 35 150.0 2.0 44.0 spng
+35 35 36 150.0 2.0 43.0 spng
+36 36 25 150.0 2.0 44.0 spng
+37 37 38 150.0 2.0 58.0 spng
+38 38 39 150.0 2.0 59.0 spng
+39 39 40 150.0 2.0 58.0 spng
+40 40 41 150.0 2.0 58.0 spng
+41 41 42 150.0 2.0 59.0 spng
+42 42 43 150.0 2.0 58.0 spng
+43 43 44 150.0 2.0 58.0 spng
+44 44 45 150.0 2.0 59.0 spng
+45 45 46 150.0 2.0 58.0 spng
+46 46 47 150.0 2.0 58.0 spng
+47 47 48 150.0 2.0 59.0 spng
+48 48 37 150.0 2.0 58.0 spng
+49 1 13 150.0 2.0 29.0 spng
+50 2 14 150.0 2.0 28.0 spng
+51 3 15 150.0 2.0 28.0 spng
+52 4 16 150.0 2.0 29.0 spng
+53 5 17 150.0 2.0 28.0 spng
+54 6 18 150.0 2.0 28.0 spng
+55 7 19 150.0 2.0 29.0 spng
+56 8 20 150.0 2.0 28.0 spng
+57 9 21 150.0 2.0 28.0 spng
+58 10 22 150.0 2.0 29.0 spng
+59 11 23 150.0 2.0 28.0 spng
+60 12 24 150.0 2.0 28.0 spng
+61 13 25 150.0 2.0 29.0 spng
+62 14 26 150.0 2.0 28.0 spng
+63 15 27 150.0 2.0 28.0 spng
+64 16 28 150.0 2.0 29.0 spng
+65 17 29 150.0 2.0 28.0 spng
+66 18 30 150.0 2.0 28.0 spng
+67 19 31 150.0 2.0 29.0 spng
+68 20 32 150.0 2.0 28.0 spng
+69 21 33 150.0 2.0 28.0 spng
+70 22 34 150.0 2.0 29.0 spng
+71 23 35 150.0 2.0 28.0 spng
+72 24 36 150.0 2.0 28.0 spng
+73 25 37 150.0 2.0 29.0 spng
+74 26 38 150.0 2.0 28.0 spng
+75 27 39 150.0 2.0 28.0 spng
+76 28 40 150.0 2.0 29.0 spng
+77 29 41 150.0 2.0 28.0 spng
+78 30 42 150.0 2.0 28.0 spng
+79 31 43 150.0 2.0 29.0 spng
+80 32 44 150.0 2.0 28.0 spng
+81 33 45 150.0 2.0 28.0 spng
+82 34 46 150.0 2.0 29.0 spng
+83 35 47 150.0 2.0 28.0 spng
+84 36 48 150.0 2.0 28.0 spng
+85 1 14 150.0 2.0 35.0 spng
+86 2 15 150.0 2.0 35.0 spng
+87 3 16 150.0 2.0 34.0 spng
+88 4 17 150.0 2.0 35.0 spng
+89 5 18 150.0 2.0 35.0 spng
+90 6 19 150.0 2.0 34.0 spng
+91 7 20 150.0 2.0 35.0 spng
+92 8 21 150.0 2.0 35.0 spng
+93 9 22 150.0 2.0 34.0 spng
+94 10 23 150.0 2.0 35.0 spng
+95 11 24 150.0 2.0 35.0 spng
+96 12 13 150.0 2.0 34.0 spng
+97 13 26 150.0 2.0 46.0 spng
+98 14 27 150.0 2.0 45.0 spng
+99 15 28 150.0 2.0 45.0 spng
+100 16 29 150.0 2.0 46.0 spng
+101 17 30 150.0 2.0 45.0 spng
+102 18 31 150.0 2.0 45.0 spng
+103 19 32 150.0 2.0 45.0 spng
+104 20 33 150.0 2.0 45.0 spng
+105 21 34 150.0 2.0 45.0 spng
+106 22 35 150.0 2.0 46.0 spng
+107 23 36 150.0 2.0 45.0 spng
+108 24 25 150.0 2.0 45.0 spng
+109 25 38 150.0 2.0 58.0 spng
+110 26 39 150.0 2.0 58.0 spng
+111 27 40 150.0 2.0 58.0 spng
+112 28 41 150.0 2.0 58.0 spng
+113 29 42 150.0 2.0 58.0 spng
+114 30 43 150.0 2.0 58.0 spng
+115 31 44 150.0 2.0 58.0 spng
+116 32 45 150.0 2.0 58.0 spng
+117 33 46 150.0 2.0 58.0 spng
+118 34 47 150.0 2.0 58.0 spng
+119 35 48 150.0 2.0 58.0 spng
+120 36 37 150.0 2.0 58.0 spng
+121 1 24 150.0 2.0 35.0 spng
+122 2 13 150.0 2.0 34.0 spng
+123 3 14 150.0 2.0 35.0 spng
+124 4 15 150.0 2.0 35.0 spng
+125 5 16 150.0 2.0 34.0 spng
+126 6 17 150.0 2.0 35.0 spng
+127 7 18 150.0 2.0 35.0 spng
+128 8 19 150.0 2.0 34.0 spng
+129 9 20 150.0 2.0 35.0 spng
+130 10 21 150.0 2.0 35.0 spng
+131 11 22 150.0 2.0 34.0 spng
+132 12 23 150.0 2.0 35.0 spng
+133 13 36 150.0 2.0 46.0 spng
+134 14 25 150.0 2.0 45.0 spng
+135 15 26 150.0 2.0 45.0 spng
+136 16 27 150.0 2.0 46.0 spng
+137 17 28 150.0 2.0 45.0 spng
+138 18 29 150.0 2.0 45.0 spng
+139 19 30 150.0 2.0 46.0 spng
+140 20 31 150.0 2.0 45.0 spng
+141 21 32 150.0 2.0 45.0 spng
+142 22 33 150.0 2.0 46.0 spng
+143 23 34 150.0 2.0 45.0 spng
+144 24 35 150.0 2.0 45.0 spng
+145 25 48 150.0 2.0 58.0 spng
+146 26 37 150.0 2.0 58.0 spng
+147 27 38 150.0 2.0 58.0 spng
+148 28 39 150.0 2.0 58.0 spng
+149 29 40 150.0 2.0 58.0 spng
+150 30 41 150.0 2.0 58.0 spng
+151 31 42 150.0 2.0 58.0 spng
+152 32 43 150.0 2.0 58.0 spng
+153 33 44 150.0 2.0 58.0 spng
+154 34 45 150.0 2.0 58.0 spng
+155 35 46 150.0 2.0 58.0 spng
+156 36 47 150.0 2.0 58.0 spng
+157 10 4 150.0 2.0 52.331631 spng
+158 7 1 150.0 2.0 52.436772 spng
+159 12 6 150.0 2.0 54.680698 spng
+160 5 11 150.0 2.0 54.589379 spng
+161 9 3 150.0 2.0 54.451569 spng
+162 2 8 150.0 2.0 54.482231 spng
+163 45 11 150.0 2.0 101.408150 spng
+164 46 12 150.0 2.0 101.542452 spng
+165 47 1 150.0 2.0 101.963064 spng
+166 48 2 150.0 2.0 101.517329 spng
+167 37 3 150.0 2.0 101.603694 spng
+168 38 4 150.0 2.0 102.014031 spng
+169 39 5 150.0 2.0 101.547660 spng
+170 40 6 150.0 2.0 101.573762 spng
+171 41 7 150.0 2.0 101.897300 spng
+172 42 8 150.0 2.0 101.497982 spng
+173 43 9 150.0 2.0 101.870594 spng
+174 44 10 150.0 2.0 102.043753 spng
+175 45 11 150.0 2.0 101.408150 spng
+176 46 8 150.0 2.0 101.548938 spng
+177 47 10 150.0 2.0 90.645939 spng
+178 48 10 150.0 2.0 101.952119 spng
+179 37 11 150.0 2.0 101.552352 spng
+180 38 12 150.0 2.0 101.491447 spng
+181 39 1 150.0 2.0 101.971524 spng
+182 40 2 150.0 2.0 101.587400 spng
+183 41 3 150.0 2.0 101.519279 spng
+184 42 4 150.0 2.0 101.976181 spng
+185 43 5 150.0 2.0 101.714570 spng
+186 44 6 150.0 2.0 101.388747 spng
+187 45 7 150.0 2.0 101.773286 spng
+
+nodes> [ { 0 100 } swap set-node-vel ] each ;
+
+USING: threads ui ;
+
+: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math ui random
+ springies springies.ui ;
+
+IN: springies.models.belt-tire
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.008 >time-slice
+gravity on
+
+1 274.078806900597328 346.307117178664043 0 0 1 0.5 mass
+2 284.142891110742823 329.83402842231834 0 0 1 0.5 mass
+3 295.307158356938658 355.695013578746227 0 0 1 0.5 mass
+4 300.698527801927128 337.003548930923216 0 0 1 0.5 mass
+5 318.093036910029696 359.203044347904552 0 0 1 0.5 mass
+6 318.542098798246286 339.592403450546044 0 0 1 0.5 mass
+7 340.949296214486822 356.831259237330983 0 0 1 0.5 mass
+8 336.494524828869885 337.754019325244656 0 0 1 0.5 mass
+9 362.534986907234952 348.770558940029559 0 0 1 0.5 mass
+10 353.491265306914897 331.642140359094469 0 0 1 0.5 mass
+11 381.368850422101502 335.37878701564847 0 0 1 0.5 mass
+12 368.085531061140216 321.055018811315335 0 0 1 0.5 mass
+13 396.117634938806759 317.519287773537314 0 0 1 0.5 mass
+14 379.675208211408915 307.277961968837246 0 0 1 0.5 mass
+15 405.655157991023771 296.391903048606025 0 0 1 0.5 mass
+16 387.124676448692242 290.862310093183567 0 0 1 0.5 mass
+17 409.337178964708642 273.594658653786666 0 0 1 0.5 mass
+18 389.76569804010461 273.012494879567555 0 0 1 0.5 mass
+19 407.11203230551871 250.712646124396059 0 0 1 0.5 mass
+20 387.966228461346304 255.061007930370067 0 0 1 0.5 mass
+21 399.188308328902735 229.098161823607285 0 0 1 0.5 mass
+22 381.896222954111181 238.073977723246998 0 0 1 0.5 mass
+23 385.883224011375262 210.148208473511374 0 0 1 0.5 mass
+24 371.614761646970464 223.279700317395225 0 0 1 0.5 mass
+25 367.955378160003875 195.334436550727929 0 0 1 0.5 mass
+26 357.817091674528911 211.717360072075536 0 0 1 0.5 mass
+27 346.743525482831387 185.884698478394085 0 0 1 0.5 mass
+28 341.291169697238729 204.55711005838188 0 0 1 0.5 mass
+29 323.935265230381788 182.330460182137188 0 0 1 0.5 mass
+30 323.466187791799882 201.937076877994031 0 0 1 0.5 mass
+31 301.04141769400843 184.703602685435726 0 0 1 0.5 mass
+32 305.532794735419941 203.763859300438838 0 0 1 0.5 mass
+33 279.442362700896183 192.851996602076866 0 0 1 0.5 mass
+34 288.551113492738239 209.893932668644339 0 0 1 0.5 mass
+35 260.65997798024199 206.334196608396638 0 0 1 0.5 mass
+36 273.960657978745814 220.516324161880476 0 0 1 0.5 mass
+37 246.029909853431349 224.197583023911335 0 0 1 0.5 mass
+38 262.719165304227545 234.58428660123181 0 0 1 0.5 mass
+39 236.458142984593252 245.235572499606377 0 0 1 0.5 mass
+40 254.870454491934908 250.81914136861181 0 0 1 0.5 mass
+41 232.703447579492519 268.042376651164432 0 0 1 0.5 mass
+42 252.226120754560156 268.679895159358864 0 0 1 0.5 mass
+43 234.96767702938331 291.007702051922024 0 0 1 0.5 mass
+44 254.040589506795527 286.621843971355872 0 0 1 0.5 mass
+45 242.759412026738119 312.577114225657738 0 0 1 0.5 mass
+46 260.111088599530603 303.593264087352964 0 0 1 0.5 mass
+47 256.101782779606651 331.52509923420655 0 0 1 0.5 mass
+48 270.373388641766439 318.366074596339615 0 0 1 0.5 mass
+49 320.448537383965288 270.292364746678743 0 0 10 0.5 mass
+1 1 4 200 2 28.284271247461902 spng
+2 4 5 200 2 28.284271247461902 spng
+3 5 8 200 2 28.284271247461902 spng
+4 8 9 200 2 28.284271247461902 spng
+5 9 12 200 2 28.284271247461902 spng
+6 12 13 200 2 28.284271247461902 spng
+7 13 16 200 2 28.284271247461902 spng
+8 16 17 200 2 28.284271247461902 spng
+9 17 20 200 2 28.284271247461902 spng
+10 20 21 200 2 28.284271247461902 spng
+11 21 24 200 2 28.284271247461902 spng
+12 24 25 200 2 28.284271247461902 spng
+13 25 28 200 2 28.284271247461902 spng
+14 28 29 200 2 28.284271247461902 spng
+15 29 32 200 2 28.284271247461902 spng
+16 32 33 200 2 28.284271247461902 spng
+17 33 36 200 2 28.284271247461902 spng
+18 36 37 200 2 28.284271247461902 spng
+19 37 40 200 2 28.284271247461902 spng
+20 40 41 200 2 28.284271247461902 spng
+21 41 44 200 2 28.284271247461902 spng
+22 44 45 200 2 28.284271247461902 spng
+23 45 48 200 2 28.284271247461902 spng
+24 3 6 200 2 28.284271247461902 spng
+25 7 10 200 2 28.284271247461902 spng
+26 11 14 200 2 28.284271247461902 spng
+27 15 18 200 2 28.284271247461902 spng
+28 19 22 200 2 28.284271247461902 spng
+29 23 26 200 2 28.284271247461902 spng
+30 27 30 200 2 28.284271247461902 spng
+31 31 34 200 2 28.284271247461902 spng
+32 35 38 200 2 28.284271247461902 spng
+33 39 44 200 2 44.7213595499957961 spng
+34 39 42 200 2 28.284271247461902 spng
+35 43 46 200 2 28.284271247461902 spng
+36 47 46 200 2 28.284271247461902 spng
+37 43 42 200 2 28.284271247461902 spng
+38 39 38 200 2 28.284271247461902 spng
+39 35 34 200 2 28.284271247461902 spng
+40 2 3 200 2 28.284271247461902 spng
+41 6 7 200 2 28.284271247461902 spng
+42 10 11 200 2 28.284271247461902 spng
+43 14 15 200 2 28.284271247461902 spng
+44 18 19 200 2 28.284271247461902 spng
+45 22 23 200 2 28.284271247461902 spng
+46 26 27 200 2 28.284271247461902 spng
+47 30 31 200 2 28.284271247461902 spng
+48 1 6 200 2 44.7213595499957961 spng
+49 3 8 200 2 44.7213595499957961 spng
+50 5 10 200 2 44.7213595499957961 spng
+51 7 12 200 2 44.7213595499957961 spng
+52 9 14 200 2 44.7213595499957961 spng
+53 11 16 200 2 44.7213595499957961 spng
+54 13 18 200 2 44.7213595499957961 spng
+55 15 20 200 2 44.7213595499957961 spng
+56 17 22 200 2 44.7213595499957961 spng
+57 19 24 200 2 44.7213595499957961 spng
+58 21 26 200 2 44.7213595499957961 spng
+59 23 28 200 2 44.7213595499957961 spng
+60 25 30 200 2 44.7213595499957961 spng
+61 27 32 200 2 44.7213595499957961 spng
+62 29 34 200 2 44.7213595499957961 spng
+63 31 36 200 2 44.7213595499957961 spng
+64 33 38 200 2 44.7213595499957961 spng
+65 35 40 200 2 44.7213595499957961 spng
+66 37 42 200 2 44.7213595499957961 spng
+67 41 46 200 2 44.7213595499957961 spng
+68 43 48 200 2 44.7213595499957961 spng
+69 2 5 200 2 44.7213595499957961 spng
+70 4 7 200 2 44.7213595499957961 spng
+71 6 9 200 2 44.7213595499957961 spng
+72 8 11 200 2 44.7213595499957961 spng
+73 10 13 200 2 44.7213595499957961 spng
+74 12 15 200 2 44.7213595499957961 spng
+75 14 17 200 2 44.7213595499957961 spng
+76 16 19 200 2 44.7213595499957961 spng
+77 18 21 200 2 44.7213595499957961 spng
+78 20 23 200 2 44.7213595499957961 spng
+79 22 25 200 2 44.7213595499957961 spng
+80 24 27 200 2 44.7213595499957961 spng
+81 26 29 200 2 44.7213595499957961 spng
+82 28 31 200 2 44.7213595499957961 spng
+83 30 33 200 2 44.7213595499957961 spng
+84 32 35 200 2 44.7213595499957961 spng
+85 34 37 200 2 44.7213595499957961 spng
+86 36 39 200 2 44.7213595499957961 spng
+87 38 41 200 2 44.7213595499957961 spng
+88 40 43 200 2 44.7213595499957961 spng
+89 42 45 200 2 44.7213595499957961 spng
+90 44 47 200 2 44.7213595499957961 spng
+91 1 8 200 2 63.2455532033675851 spng
+92 3 10 200 2 63.2455532033675851 spng
+93 5 12 200 2 63.2455532033675851 spng
+94 7 14 200 2 63.2455532033675851 spng
+95 9 16 200 2 63.2455532033675851 spng
+96 11 18 200 2 63.2455532033675851 spng
+97 13 20 200 2 63.2455532033675851 spng
+98 15 22 200 2 63.2455532033675851 spng
+99 17 24 200 2 63.2455532033675851 spng
+100 19 26 200 2 63.2455532033675851 spng
+101 21 28 200 2 63.2455532033675851 spng
+102 23 30 200 2 63.2455532033675851 spng
+103 25 32 200 2 63.2455532033675851 spng
+104 27 34 200 2 63.2455532033675851 spng
+105 29 36 200 2 63.2455532033675851 spng
+106 31 38 200 2 63.2455532033675851 spng
+107 33 40 200 2 63.2455532033675851 spng
+108 35 42 200 2 63.2455532033675851 spng
+109 37 44 200 2 63.2455532033675851 spng
+110 39 46 200 2 63.2455532033675851 spng
+111 48 41 200 2 63.2455532033675851 spng
+112 2 7 200 2 63.2455532033675851 spng
+113 4 9 200 2 63.2455532033675851 spng
+114 6 11 200 2 63.2455532033675851 spng
+115 8 13 200 2 63.2455532033675851 spng
+116 10 15 200 2 63.2455532033675851 spng
+117 12 17 200 2 63.2455532033675851 spng
+118 14 19 200 2 63.2455532033675851 spng
+119 16 21 200 2 63.2455532033675851 spng
+120 18 23 200 2 63.2455532033675851 spng
+121 20 25 200 2 63.2455532033675851 spng
+122 22 27 200 2 63.2455532033675851 spng
+123 24 29 200 2 63.2455532033675851 spng
+124 26 31 200 2 63.2455532033675851 spng
+125 28 33 200 2 63.2455532033675851 spng
+126 30 35 200 2 63.2455532033675851 spng
+127 32 37 200 2 63.2455532033675851 spng
+128 34 39 200 2 63.2455532033675851 spng
+129 36 41 200 2 63.2455532033675851 spng
+130 38 43 200 2 63.2455532033675851 spng
+131 40 45 200 2 63.2455532033675851 spng
+132 42 47 200 2 63.2455532033675851 spng
+133 1 3 200 2 20 spng
+134 3 5 200 2 20 spng
+135 5 7 200 2 20 spng
+136 7 9 200 2 20 spng
+137 9 11 200 2 20 spng
+138 11 13 200 2 20 spng
+139 13 15 200 2 20 spng
+140 15 17 200 2 20 spng
+141 17 19 200 2 20 spng
+142 19 21 200 2 20 spng
+143 21 23 200 2 20 spng
+144 23 25 200 2 20 spng
+145 25 27 200 2 20 spng
+146 27 29 200 2 20 spng
+147 29 31 200 2 20 spng
+148 31 33 200 2 20 spng
+149 33 35 200 2 20 spng
+150 35 37 200 2 20 spng
+151 37 39 200 2 20 spng
+152 39 41 200 2 20 spng
+153 41 43 200 2 20 spng
+154 43 45 200 2 20 spng
+155 45 47 200 2 20 spng
+156 2 4 200 2 20 spng
+157 4 6 200 2 20 spng
+158 6 8 200 2 20 spng
+159 8 10 200 2 20 spng
+160 10 12 200 2 20 spng
+161 12 14 200 2 20 spng
+162 14 16 200 2 20 spng
+163 16 18 200 2 20 spng
+164 18 20 200 2 20 spng
+165 20 22 200 2 20 spng
+166 22 24 200 2 20 spng
+167 24 26 200 2 20 spng
+168 26 28 200 2 20 spng
+169 28 30 200 2 20 spng
+170 30 32 200 2 20 spng
+171 32 34 200 2 20 spng
+172 34 36 200 2 20 spng
+173 36 38 200 2 20 spng
+174 38 40 200 2 20 spng
+175 40 42 200 2 20 spng
+176 42 44 200 2 20 spng
+177 44 46 200 2 20 spng
+178 46 48 200 2 20 spng
+179 1 2 200 2 20 spng
+180 3 4 200 2 20 spng
+181 5 6 200 2 20 spng
+182 7 8 200 2 20 spng
+183 9 10 200 2 20 spng
+184 11 12 200 2 20 spng
+185 13 14 200 2 20 spng
+186 15 16 200 2 20 spng
+187 17 18 200 2 20 spng
+188 19 20 200 2 20 spng
+189 21 22 200 2 20 spng
+190 23 24 200 2 20 spng
+191 25 26 200 2 20 spng
+192 27 28 200 2 20 spng
+193 29 30 200 2 20 spng
+194 31 32 200 2 20 spng
+195 33 34 200 2 20 spng
+196 35 36 200 2 20 spng
+197 37 38 200 2 20 spng
+198 39 40 200 2 20 spng
+199 41 42 200 2 20 spng
+200 43 44 200 2 20 spng
+201 45 46 200 2 20 spng
+202 47 48 200 2 20 spng
+203 47 2 200 2 28.284271247461902 spng
+204 1 48 200 2 28.284271247461902 spng
+205 1 46 200 2 44.7213595499957961 spng
+206 1 44 200 2 63.2455532033675851 spng
+207 47 4 200 2 44.7213595499957961 spng
+208 48 3 200 2 44.7213595499957961 spng
+209 47 6 200 2 63.2455532033675851 spng
+210 48 5 200 2 63.2455532033675851 spng
+211 46 3 200 2 63.2455532033675851 spng
+212 45 4 200 2 63.2455532033675851 spng
+213 47 1 200 2 20 spng
+214 48 2 200 2 20 spng
+215 18 49 300 3 69.2603782836911677 spng
+216 49 20 300 3 69.050706006528273 spng
+217 22 49 300 3 69.3541635375988079 spng
+218 49 24 300 3 69.5269731830747872 spng
+219 26 49 300 3 69.6347614342147381 spng
+220 49 28 300 3 68.9492567037527948 spng
+221 30 49 300 3 68.2641926635040477 spng
+222 49 32 300 3 68.0661443009665419 spng
+223 34 49 300 3 68.4470598345904051 spng
+224 49 36 300 3 68.1175454637056106 spng
+225 38 49 300 3 67.6756972627545252 spng
+226 49 40 300 3 68.6221538571910514 spng
+227 42 49 300 3 68.1835757349231386 spng
+228 49 44 300 3 68.249542123006222 spng
+229 46 49 300 3 68.8767014308902503 spng
+230 49 48 300 3 69.4262198308391305 spng
+231 2 49 300 3 69.8927750200262068 spng
+232 49 4 300 3 69.5701085237043486 spng
+233 6 49 300 3 69.1809222257119103 spng
+234 8 49 300 3 69.2314957226839027 spng
+235 49 10 300 3 69.7782200976780445 spng
+236 12 49 300 3 69.5269731830747872 spng
+237 49 14 300 3 69.8927750200262068 spng
+238 16 49 300 3 69.8927750200262068 spng
+
+
+nodes> 200 random -100 + 100 2array [ swap set-node-vel ] curry each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { "bundle-name" "Belt Tire.app" }
+}
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random springies springies.ui ;
+
+IN: springies.models.nifty
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.007 >time-slice
+gravity off
+
+1 148.581450999999987 350.573888000000011 0 -7.75 1 0.1 mass
+2 168.564277000000004 351.402524000000028 0 -7.75 1 0.1 mass
+3 188.54710399999999 352.231158999999991 0 -7.75 1 0.1 mass
+4 208.529931000000005 353.059794000000011 0 -7.75 1 0.1 mass
+5 228.512757999999991 353.888428999999974 0 -7.75 1 0.1 mass
+6 248.495584000000008 354.717063999999993 0 -7.75 1 0.1 mass
+7 149.410086000000007 330.591061000000025 0 -7.75 1 0.1 mass
+8 150.238720999999998 310.608234999999979 0 -7.75 1 0.1 mass
+9 151.06735599999999 290.625407999999993 0 -7.75 1 0.1 mass
+10 151.895991000000009 270.642581000000007 0 -7.75 1 0.1 mass
+11 152.724626000000001 250.65975499999999 0 -7.75 1 0.1 mass
+12 172.707452999999987 251.48839000000001 0 -7.749999 1 0.1 mass
+13 192.690280000000001 252.317025000000001 0 -7.75 1 0.1 mass
+14 212.67310599999999 253.145659999999992 0 -7.75 1 0.1 mass
+15 232.655933000000005 253.974295000000012 0 -7.75 1 0.1 mass
+16 252.638759999999991 254.802930000000003 0 -7.75 1 0.1 mass
+17 251.810124999999999 274.78575699999999 0 -7.75 1 0.1 mass
+18 250.98148900000001 294.768583999999976 0 -7.75 1 0.1 mass
+19 249.324218999999999 334.734237000000007 0 -7.75 1 0.1 mass
+20 250.152853999999991 314.751410000000021 0 -7.75 1 0.1 mass
+1 1 2 200 1.5 20 spng
+2 2 3 200 1.5 20 spng
+3 3 4 200 1.5 20 spng
+4 4 5 200 1.5 20 spng
+5 5 6 200 1.5 20 spng
+6 6 19 200 1.5 20 spng
+7 19 20 200 1.5 20 spng
+8 20 18 200 1.5 20 spng
+9 18 17 200 1.5 20 spng
+10 17 16 200 1.5 20 spng
+11 16 15 200 1.5 20 spng
+12 15 14 200 1.5 20 spng
+13 14 13 200 1.5 20 spng
+14 13 12 200 1.5 20 spng
+15 12 11 200 1.5 20 spng
+16 11 10 200 1.5 20 spng
+17 10 9 200 1.5 20 spng
+18 9 8 200 1.5 20 spng
+19 8 7 200 1.5 20 spng
+20 7 1 200 1.5 20 spng
+21 1 19 200 1.5 101.98039 spng
+22 19 14 200 1.5 89.4427189999999968 spng
+23 14 8 200 1.5 84.8528139999999951 spng
+24 8 5 200 1.5 89.4427189999999968 spng
+25 5 16 200 1.5 101.98039 spng
+26 16 10 200 1.5 101.98039 spng
+27 10 3 200 1.5 89.4427189999999968 spng
+28 3 18 200 1.5 84.8528139999999951 spng
+29 18 12 200 1.5 89.4427189999999968 spng
+30 12 1 200 1.5 101.98039 spng
+31 2 20 200 1.5 89.4427189999999968 spng
+32 20 13 200 1.5 84.8528139999999951 spng
+33 13 7 200 1.5 89.4427189999999968 spng
+34 7 6 200 1.5 101.98039 spng
+35 6 15 200 1.5 101.98039 spng
+36 15 9 200 1.5 89.4427189999999968 spng
+37 9 4 200 1.5 84.8528139999999951 spng
+38 4 17 200 1.5 89.4427189999999968 spng
+39 17 11 200 1.5 101.98039 spng
+40 11 2 200 1.5 101.98039 spng
+
+nodes> 200 random -100 + 200 random -100 + 2array [ swap set-node-vel ] curry
+each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random
+ springies springies.ui ;
+
+IN: springies.models.urchin
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.007 >time-slice
+gravity on
+
+1 507.296953 392.174236 -11.451186 -71.267273 1.0 1.0 mass
+2 514.879820 372.128025 11.950035 -70.858717 1.0 1.0 mass
+3 536.571268 364.423706 18.394466 -41.159445 1.0 1.0 mass
+4 554.886966 369.953895 15.173664 -11.009243 1.0 1.0 mass
+5 572.432935 379.927626 8.228103 -1.120846 1.0 1.0 mass
+6 585.774508 392.380791 5.443281 -8.186599 1.0 1.0 mass
+7 584.650543 411.934530 -15.582843 -24.911756 1.0 1.0 mass
+8 569.409148 424.155713 -24.100159 -42.285960 1.0 1.0 mass
+9 553.751996 434.663690 -26.069217 -41.610454 1.0 1.0 mass
+10 536.684374 444.915694 -30.702349 -45.021926 1.0 1.0 mass
+11 516.677286 435.936238 -33.128410 -60.977340 1.0 1.0 mass
+12 514.170680 414.649472 -24.471518 -64.104425 1.0 1.0 mass
+13 602.101547 478.298945 1.612646 -53.040881 1.0 1.0 mass
+14 637.0 427.598266 0.0 0.0 1.0 1.0 mass
+15 608.000171 350.425575 31.812856 23.456940 1.0 1.0 mass
+16 484.367809 332.414622 42.575378 -91.238351 1.0 1.0 mass
+17 480.857379 475.215663 -24.240991 -53.909049 1.0 1.0 mass
+18 548.580015 492.173168 -34.565312 -52.436468 1.0 1.0 mass
+19 578.155338 487.173526 22.544495 -71.920721 1.0 1.0 mass
+20 630.992588 379.333707 16.662115 37.873709 1.0 1.0 mass
+21 591.256916 324.817423 63.036114 27.988433 1.0 1.0 mass
+22 539.051461 311.597938 159.501014 -27.955219 1.0 1.0 mass
+23 448.396171 396.882674 -15.045910 -138.652372 1.0 1.0 mass
+24 448.194414 419.993896 -27.625008 -84.936708 1.0 1.0 mass
+1 1 2 200.0 3.0 20.0 spng
+2 2 3 200.0 3.0 20.0 spng
+3 3 4 200.0 3.0 20.0 spng
+4 4 5 200.0 3.0 20.0 spng
+5 5 6 200.0 3.0 20.0 spng
+6 6 7 200.0 3.0 20.0 spng
+7 7 8 200.0 3.0 20.0 spng
+8 8 9 200.0 3.0 20.0 spng
+9 9 10 200.0 3.0 20.0 spng
+10 10 11 200.0 3.0 20.0 spng
+11 11 12 200.0 3.0 20.0 spng
+12 1 3 200.0 3.0 40.0 spng
+13 2 4 200.0 3.0 40.0 spng
+14 3 5 200.0 3.0 40.0 spng
+15 4 6 200.0 3.0 40.0 spng
+16 6 8 200.0 3.0 40.0 spng
+17 7 9 200.0 3.0 40.0 spng
+18 8 10 200.0 3.0 40.0 spng
+19 9 11 200.0 3.0 40.0 spng
+20 10 12 200.0 3.0 40.0 spng
+21 12 1 200.0 3.0 21.0 spng
+22 12 2 200.0 3.0 41.0 spng
+23 11 1 200.0 3.0 41.0 spng
+24 6 12 200.0 3.0 72.681733 spng
+25 5 11 200.0 3.0 81.191259 spng
+26 10 4 200.0 3.0 76.026311 spng
+27 3 9 200.0 3.0 72.615425 spng
+28 8 2 200.0 3.0 74.966659 spng
+29 1 7 200.0 3.0 80.280757 spng
+30 17 11 200.0 3.0 55.036352 spng
+31 10 18 200.0 3.0 49.819675 spng
+32 19 9 200.0 3.0 54.918121 spng
+33 8 13 200.0 3.0 62.201286 spng
+34 14 7 200.0 3.0 58.600341 spng
+35 6 20 200.0 3.0 46.400431 spng
+36 15 5 200.0 3.0 44.045431 spng
+37 4 21 200.0 3.0 57.454330 spng
+38 22 3 200.0 3.0 53.823787 spng
+39 2 16 200.0 3.0 51.039201 spng
+40 23 1 200.0 3.0 58.668561 spng
+41 12 24 200.0 3.0 64.404969 spng
+42 24 11 200.0 3.0 71.217975 spng
+43 17 12 200.0 3.0 65.0 spng
+44 11 18 200.0 3.0 60.745370 spng
+45 18 9 200.0 3.0 60.406953 spng
+46 9 13 200.0 3.0 67.779053 spng
+47 13 7 200.0 3.0 66.708320 spng
+48 7 20 200.0 3.0 55.659680 spng
+49 20 5 200.0 3.0 60.0 spng
+50 5 21 200.0 3.0 61.846584 spng
+51 21 3 200.0 3.0 64.031242 spng
+52 3 16 200.0 3.0 63.568860 spng
+53 16 1 200.0 3.0 59.774577 spng
+54 1 24 200.0 3.0 65.802736 spng
+55 17 10 200.0 3.0 64.845971 spng
+56 10 19 200.0 3.0 58.249464 spng
+57 19 8 200.0 3.0 67.268120 spng
+58 8 14 200.0 3.0 67.268120 spng
+59 14 6 200.0 3.0 64.629715 spng
+60 6 15 200.0 3.0 50.089919 spng
+61 15 4 200.0 3.0 56.320511 spng
+62 4 22 200.0 3.0 60.728906 spng
+63 22 2 200.0 3.0 61.032778 spng
+64 2 23 200.0 3.0 66.528190 spng
+65 23 12 200.0 3.0 72.277244 spng
+
+nodes>
+ 75 random -75 + 0 2array [ over node-vel v+ swap set-node-vel ]
+curry each
+
+;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel combinators sequences arrays math math.vectors
+ generalizations vars accessors math.physics.vel ;
+
+IN: springies
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ;
+
+: vector-projection ( a b -- vec )
+ [ nip normalize ] [ scalar-projection ] 2bi v*n ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: nodes
+VAR: springs
+VAR: time-slice
+VAR: world-size
+
+: world-width ( -- width ) world-size> first ;
+
+: world-height ( -- height ) world-size> second ;
+
+VAR: gravity
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! node
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: node < vel mass elas force ;
+
+C: <node> node
+
+: node-vel ( node -- vel ) vel>> ;
+
+: set-node-vel ( vel node -- ) swap >>vel drop ;
+
+: pos-x ( node -- x ) pos>> first ;
+: pos-y ( node -- y ) pos>> second ;
+: vel-x ( node -- y ) vel>> first ;
+: vel-y ( node -- y ) vel>> second ;
+
+: >>pos-x ( node x -- node ) over pos>> set-first ;
+: >>pos-y ( node y -- node ) over pos>> set-second ;
+: >>vel-x ( node x -- node ) over vel>> set-first ;
+: >>vel-y ( node y -- node ) over vel>> set-second ;
+
+: apply-force ( node vec -- ) over force>> v+ >>force drop ;
+
+: reset-force ( node -- node ) 0 0 2array >>force ;
+
+: node-id ( id -- node ) 1- nodes> nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! spring
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: spring rest-length k damp node-a node-b ;
+
+C: <spring> spring
+
+: end-points ( spring -- b-pos a-pos )
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
+
+: spring-length ( spring -- length ) end-points v- norm ;
+
+: stretch-length ( spring -- length )
+ [ spring-length ] [ rest-length>> ] bi - ;
+
+: dir ( spring -- vec ) end-points v- normalize ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Hooke
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! F = -kx
+!
+! k :: spring constant
+! x :: distance stretched beyond rest length
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
+
+: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
+
+: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
+
+: act-on-nodes-hooke ( spring -- )
+ [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
+ apply-force
+ apply-force ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! damping
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! F = -bv
+!
+! b :: Damping constant
+! v :: Velocity
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : damping-force-a ( spring -- vec )
+! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ;
+
+! : damping-force-b ( spring -- vec )
+! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-velocity-a ( spring -- vel )
+ [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
+
+: unit-vec-b->a ( spring -- vec )
+ [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
+
+: relative-velocity-along-spring-a ( spring -- vel )
+ [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
+
+: damping-force-a ( spring -- vec )
+ [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-velocity-b ( spring -- vel )
+ [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
+
+: unit-vec-a->b ( spring -- vec )
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
+
+: relative-velocity-along-spring-b ( spring -- vel )
+ [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
+
+: damping-force-b ( spring -- vec )
+ [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: act-on-nodes-damping ( spring -- )
+ dup
+ [ node-a>> ] [ damping-force-a ] bi apply-force
+ [ node-b>> ] [ damping-force-b ] bi apply-force ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: below? ( node -- ? ) pos-y 0 < ;
+
+: above? ( node -- ? ) pos-y world-height >= ;
+
+: beyond-left? ( node -- ? ) pos-x 0 < ;
+
+: beyond-right? ( node -- ? ) pos-x world-width >= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounce-top ( node -- )
+ world-height 1- >>pos-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
+ drop ;
+
+: bounce-bottom ( node -- )
+ 0 >>pos-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
+ drop ;
+
+: bounce-left ( node -- )
+ 0 >>pos-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
+ drop ;
+
+: bounce-right ( node -- )
+ world-width 1- >>pos-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: handle-bounce ( node -- )
+ { { [ dup above? ] [ bounce-top ] }
+ { [ dup below? ] [ bounce-bottom ] }
+ { [ dup beyond-left? ] [ bounce-left ] }
+ { [ dup beyond-right? ] [ bounce-right ] }
+ { [ t ] [ drop ] } }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: act-on-nodes ( spring -- )
+ dup
+ act-on-nodes-hooke
+ act-on-nodes-damping ;
+
+! : act-on-nodes ( spring -- ) act-on-nodes-hooke ;
+
+: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-gravity ( node -- ) { 0 -9.8 } apply-force ;
+
+: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! F = ma
+
+: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
+
+: new-vel ( node -- vel )
+ [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
+
+: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
+
+: iterate-node ( node -- )
+ dup new-pos >>pos
+ dup new-vel >>vel
+ reset-force
+ handle-bounce ;
+
+: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Reading xspringies data files
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mass ( id x y x-vel y-vel mass elas -- )
+ node new
+ swap >>elas
+ swap >>mass
+ -rot 2array >>vel
+ -rot 2array >>pos
+ 0 0 2array >>force
+ nodes> swap suffix >nodes
+ drop ;
+
+: spng ( id id-a id-b k damp rest-length -- )
+ spring new
+ swap >>rest-length
+ swap >>damp
+ swap >>k
+ swap node-id >>node-b
+ swap node-id >>node-a
+ springs> swap suffix >springs
+ drop ;
\ No newline at end of file
--- /dev/null
+Mass and spring simulation (inspired by xspringies)
--- /dev/null
+simulation
+physics
+demos
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces threads sequences math math.vectors
+ opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
+ fry rewrite-closures vars springies accessors math.geometry.rect ;
+
+IN: springies.ui
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
+
+: draw-spring ( spring -- )
+ [ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
+
+: draw-nodes ( -- ) nodes> [ draw-node ] each ;
+
+: draw-springs ( -- ) springs> [ draw-spring ] each ;
+
+: set-projection ( -- )
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ 0 world-width 1- 0 world-height 1- -1 1 glOrtho
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity ;
+
+! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: slate
+
+VAR: loop
+
+: update-world-size ( -- ) slate> rect-dim >world-size ;
+
+: refresh-slate ( -- ) slate> relayout-1 ;
+
+DEFER: maybe-loop
+
+: run ( -- )
+ update-world-size
+ iterate-system
+ refresh-slate
+ yield
+ maybe-loop ;
+
+: maybe-loop ( -- ) loop> [ run ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: springies-window* ( -- )
+
+ C[ display ] <slate>
+ { 800 600 } >>pdim
+ C[ { 500 500 } >world-size loop on [ run ] in-thread ] >>graft
+ C[ loop off ] >>ungraft
+ [ >slate ] [ "Springies" open-window ] bi ;
+
+: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
--- /dev/null
+
+USING: kernel lexer parser words quotations compiler.units ;
+
+IN: sto
+
+! Use 'sto' to bind a value on the stack to a word.
+!
+! Example:
+!
+! 10 sto A
+
+: sto
+ \ 1quotation parsed
+ scan
+ current-vocab create
+ dup set-word
+ literalize parsed
+ \ swap parsed
+ [ define ] parsed
+ \ with-compilation-unit parsed ; parsing
+++ /dev/null
-USING: kernel sequences strings.lib tools.test ;
-IN: temporary
-
-[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
-[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
+++ /dev/null
-USING: math math.ranges arrays sequences kernel random splitting
-strings unicode.case ;
-IN: strings.lib
-
-: >Upper ( str -- str )
- dup empty? [ unclip ch>upper prefix ] unless ;
-
-: >Upper-dashes ( str -- str )
- "-" split [ >Upper ] map "-" join ;
-
-: lower-alpha-chars ( -- seq )
- CHAR: a CHAR: z [a,b] ;
-
-: upper-alpha-chars ( -- seq )
- CHAR: A CHAR: Z [a,b] ;
-
-: numeric-chars ( -- seq )
- CHAR: 0 CHAR: 9 [a,b] ;
-
-: alpha-chars ( -- seq )
- lower-alpha-chars upper-alpha-chars append ;
-
-: alphanumeric-chars ( -- seq )
- alpha-chars numeric-chars append ;
-
-: random-alpha-char ( -- ch )
- alpha-chars random ;
-
-: random-alphanumeric-char ( -- ch )
- alphanumeric-chars random ;
-
-: random-alphanumeric-string ( length -- str )
- [ random-alphanumeric-char ] "" replicate-as ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.swap
-
-: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
-: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
-: SWAP_FLAG_PRIO_SHIFT 0 ;
-
-FUNCTION: int swapon ( char* path, int flags ) ;
-
-FUNCTION: int swapoff ( char* path ) ;
\ No newline at end of file
+++ /dev/null
-unportable
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.product combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed < frame names toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+:: add-toggle ( n name model toggler -- )\r
+ <frame>\r
+ n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
+ @right grid-add\r
+ n model name <toggle-button> @center grid-add\r
+ toggler swap add-gadget drop ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ _ _ add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ names>> length 1 - swap ]\r
+ [ model>> ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> swap add-gadget drop ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: new-tabbed ( assoc class -- tabbed )\r
+ new-frame\r
+ 0 <model> >>model\r
+ <pile> 1 >>fill >>toggler\r
+ dup toggler>> @left grid-add\r
+ swap\r
+ [ keys >vector >>names ]\r
+ [ values over model>> <book> >>content dup content>> @center grid-add ]\r
+ bi\r
+ dup redo-toggler ;\r
+ \r
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
--- /dev/null
+
+USING: kernel accessors locals namespaces sequences threads
+ math math.order math.vectors
+ calendar
+ colors opengl ui ui.gadgets ui.gestures ui.render
+ circular
+ processing.shapes ;
+
+IN: trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Return the mouse location relative to the current gadget
+
+: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop { 0 0 } ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
+
+: dot ( pos percent -- ) percent->radius circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <trails-gadget> < gadget paused points ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ ! Add a valid point if the mouse is in the gadget
+ ! Otherwise, add an "invisible" point
+
+ hand-gadget get GADGET =
+ [ mouse GADGET points>> push-circular ]
+ [ { -10 -10 } GADGET points>> push-circular ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-trails-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <trails-gadget> pref-dim* ( <trails-gadget> -- dim ) drop { 500 500 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: each-percent ( seq quot -- )
+ [
+ dup length
+ dup [ / ] curry
+ [ 1+ ] prepose
+ ] dip compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <trails-gadget> draw-gadget* ( GADGET -- )
+ origin get
+ [
+ T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
+ T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
+
+ black gl-clear
+
+ GADGET points>> [ dot ] each-percent
+ ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: trails-gadget ( -- <trails-gadget> )
+
+ <trails-gadget> new-gadget
+
+ 300 point-list >>points
+
+ t >>clipped?
+
+ dup start-trails-thread ;
+
+: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: trails-window
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.font
-
-SYMBOL: <font>
-
-<font> { "dpy" "name" "id" "struct" } accessors define-independent-class
-
-<font> "create" !( name <font> -- font ) [
-new-empty swap >>name dpy get >>dpy
-dpy get $ptr over $name XLoadQueryFont >>struct
-dup $struct XFontStruct-fid >>id
-] add-class-method
-
-<font> {
-
-"ascent" !( font -- ascent ) [ $struct XFontStruct-ascent ]
-
-"descent" !( font -- ascent ) [ $struct XFontStruct-descent ]
-
-"height" !( font -- ascent ) [ dup <- ascent swap <- descent + ]
-
-"text-width" !( font string -- width ) [ >r $struct r> dup length XTextWidth ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
- slot-accessors x x.font ;
-
-IN: x.gc
-
-SYMBOL: <gc>
-
-<gc> { "dpy" "ptr" "font" } accessors define-independent-class
-
-<gc> "create" !( <gc> -- gc ) [
-new-empty dpy get >>dpy
-dpy get $ptr dpy get $default-root $id 0 f XCreateGC >>ptr
-"6x13" <font> new* >>font
-] add-class-method
-
-<gc> {
-
-"set-subwindow-mode" !( gc mode -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetSubwindowMode drop ]
-
-"set-function" !( gc function -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetFunction drop ]
-
-"set-foreground" !( gc foreground -- gc )
- [ >r dup $dpy $ptr over $ptr r> lookup-color XSetForeground drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel strings assocs sequences math ;
-
-IN: x.keysym-table
-
-: keysym-table ( -- table )
-H{ { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RETURN" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESCAPE" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE-UP" }
- { HEX: FF56 "PAGE-DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- { HEX: FFC7 "F10" }
- { HEX: FFC8 "F11" }
- { HEX: FFC9 "F12" }
- { HEX: FFE1 "LEFT-SHIFT" }
- { HEX: FFE2 "RIGHT-SHIFT" }
- { HEX: FFE3 "LEFT-CONTROL" }
- { HEX: FFE4 "RIGHT-CONTROL" }
- { HEX: FFE5 "CAPSLOCK" }
- { HEX: FFE9 "LEFT-ALT" }
- { HEX: FFEA "RIGHT-ALT" }
-} ;
-
-: keysym>name ( keysym -- name )
-dup keysym-table at dup [ nip ] [ drop 1string ] if ;
-
-: name>keysym ( name -- keysym ) keysym-table value-at ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
-
-IN: x.pen
-
-SYMBOL: <pen>
-
-<pen> <pos> { "window" "gc" } accessors define-simple-class
-
-<pen> "create" !( window <pen> -- pen )
-[ new-empty swap >>window <gc> new* >>gc 0 0 2array >>pos ]
-add-class-method
-
-<pen> {
-
-"line-to" ! ( pen point -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos r> <---- draw-line >>pos ]
-
-"line-by" ! ( pen offset -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos dup r> v+ <---- draw-line
- <-- move-by ]
-
-"draw-string" ! ( pen string -- pen )
- [ >r dup dup $window swap dup $gc swap $pos r> <---- draw-string ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators math x11.xlib
- mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
-
-IN: x.widgets.button
-
-SYMBOL: <button>
-
-<button>
- <label>
- { "action-1" "action-2" "action-3" } accessors
-define-simple-class
-
-<button> "create" !( <button> -- button ) [
-new-empty
-<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
-] add-class-method
-
-<button> "handle-button-press" !( event button -- ) [
-{ { [ over XButtonEvent-button Button1 = ] [ nip $action-1 call ] }
- { [ over XButtonEvent-button Button2 = ] [ nip $action-2 call ] }
- { [ over XButtonEvent-button Button3 = ] [ nip $action-3 call ] } }
-cond
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel strings arrays sequences sequences.lib math x11.xlib
- mortar mortar.sugar slot-accessors x x.pen x.widgets ;
-
-IN: x.widgets.keymenu
-
-SYMBOL: <keymenu>
-
-<keymenu> <widget> { "items" "pen" } accessors define-simple-class
-
-<keymenu> "create" !( <keymenu> -- keymenu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-: numbers-and-letters ( -- seq )
-"1234567890abcdefghijklmnopqrstuvwxyz" [ 1string ] { } map-as ;
-
-<keymenu> {
-
-"keymenu-init" !( keymenu -- keymenu ) [
- dup <pen> new* >>pen
- ExposureMask KeyPressMask bitor >>mask
- <- init-widget
-]
-
-"item-labels" !( keymenu -- labels ) [ $items [ first ] map ]
-
-"item-actions" !( keymenu -- actions ) [ $items [ second ] map ]
-
-"keymenu-labels" !( keymenu -- seq )
-[ numbers-and-letters swap <- item-labels [ " - " swap 3append ] 2map ]
-
-"reset-pen" !( keymenu -- keymenu ) [
- dup $pen
- 1 <-- set-x
- dup $gc $font <- ascent 1+ <-- set-y
- drop ]
-
-"handle-expose" !( event keymenu -- ) [
- nip
- <- reset-pen
- dup $pen swap <- keymenu-labels
- [ <-- draw-string dup $gc $font <- height <-- move-by-y ] each drop ]
-
-"keymenu-handle-key-press" !( event keymenu -- ) [
- swap 0 key-event-to-string numbers-and-letters index
- [ swap <- item-actions ?nth [ call ] when* ]
- [ drop ]
- if* ]
-
-"handle-key-press" !( event keymenu -- ) [ <- keymenu-handle-key-press ]
-
-"calc-height" !( keymenu -- height )
- [ dup $items length swap $pen $gc $font <- height * ]
-
-"calc-width" !( keymenu -- width )
- [ dup $pen $gc $font
- swap $items [ first " " append ] map
- dup empty? [ drop "" ] [ longest ] if
- <-- text-width ]
-
-"calc-size" !( keymenu -- size )
- [ dup <- calc-width swap <- calc-height 2array ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
-
-IN: x.widgets.label
-
-SYMBOL: <label>
-
-<label> <widget> { "gc" "text" } accessors define-simple-class
-
-<label> "create" !( text <label> -- label ) [
-new-empty swap >>text <gc> new* >>gc ExposureMask >>mask <- init-widget
-] add-class-method
-
-<label> "handle-expose" !( event label -- ) [
- nip <- clear dup $gc { 20 20 } pick $text <---- draw-string
-] add-method
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences combinators math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.widgets
-
-SYMBOL: <widget>
-
-<widget> <window> { "mask" } accessors define-simple-class
-
-<widget> {
-
-"init-widget" !( widget -- widget )
- [ <- init-window <- add-to-window-table dup $mask <-- select-input ]
-
-"add-to-window-table" !( window -- window )
- [ dup $dpy over <-- add-to-window-table ]
-
-"remove-from-window-table" !( window -- window )
- [ dup $dpy over <-- remove-from-window-table ]
-
-"handle-event" !( event widget -- ) [
- over XAnyEvent-type
- { { [ dup Expose = ] [ drop <- handle-expose ] }
- { [ dup KeyPress = ] [ drop <- handle-key-press ] }
- { [ dup ButtonPress = ] [ drop <- handle-button-press ] }
- { [ dup EnterNotify = ] [ drop <- handle-enter-window ] }
- { [ dup DestroyNotify = ] [ drop <- handle-destroy-window ] }
- { [ dup MapRequest = ] [ drop <- handle-map-request ] }
- { [ dup MapNotify = ] [ drop <- handle-map ] }
- { [ dup ConfigureRequest = ] [ drop <- handle-configure-request ] }
- { [ dup UnmapNotify = ] [ drop <- handle-unmap ] }
- { [ dup PropertyNotify = ] [ drop <- handle-property ] }
- { [ t ] [ "handle-event :: ignoring event"
- print flush 3drop ] }
- } cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences
- x11.xlib mortar slot-accessors x x.widgets ;
-
-IN: x.widgets.wm.child
-
-SYMBOL: <wm-child>
-
-<wm-child> <widget> { } define-simple-class
-
-<wm-child> "create" !( id <wm-child> -- wm-child ) [
- new-empty swap >>id dpy get >>dpy PropertyChangeMask >>mask
- <- add-to-save-set
- 0 <-- set-border-width
- <- add-to-window-table
- dup $mask <-- select-input
-] add-class-method
-
-<wm-child> "handle-property" !( event wm-child -- ) [
- drop
- "child handle-property :: atom name = " write
- XPropertyEvent-atom get-atom-name print flush
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences combinators math.vectors
- x11.xlib x11.constants
- mortar slot-accessors x x.gc geom.rect ;
-
-IN: x.widgets.wm.frame.drag
-
-SYMBOL: <wm-frame-drag>
-
-<wm-frame-drag>
- { "dpy" "gc" "frame" "event" "push" "posn" } accessors
-define-independent-class
-
-<wm-frame-drag> {
-
-"next-event" !( wfdm -- wfdm ) [ dup $dpy over $event <-- next-event 2drop ]
-
-"event-type" !( wfdm -- wfdm event-type ) [ dup $event XAnyEvent-type ]
-
-"drag-offset" !( wfdm -- offset ) [ dup $posn swap $push v- ]
-
-"update-posn" !( wfd -- wfd ) [ dup $event XMotionEvent-root-position >>posn ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.move
-
-SYMBOL: <wm-frame-drag-move>
-
-<wm-frame-drag-move> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-move> "create" !( event frame <wm-frame-drag-move> -- ) [
- new-empty swap >>frame swap >>event dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-move-outline
- <- loop
-] add-class-method
-
-<wm-frame-drag-move> {
-
-"move-outline" !( wfdm -- rect )
- [ dup $frame <- as-rect swap <- drag-offset <-- move-by ]
-
-"draw-move-outline" !( wfdm -- wfdm )
- [ dpy get $default-root over $gc pick <- move-outline <--- draw-rect ]
-
-"loop" !( wfdm -- wfdm ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-move-outline <- update-posn <- draw-move-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-move-outline
- dup $frame <- position over <- drag-offset v+ >r
- dup $frame r> <-- move drop
- dup $frame <- raise drop drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.size
-
-SYMBOL: <wm-frame-drag-size>
-
-<wm-frame-drag-size> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-size> "create" !( event frame <wfds> -- ) [
- new-empty swap >>frame swap >>event
- dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-size-outline <- loop
-] add-class-method
-
-<wm-frame-drag-size> {
-
-"size-outline" !( wfds -- rect )
- [ dup $frame <- position swap $posn over v- <rect> new ]
-
-"draw-size-outline" !( wfdm -- wfdm )
- [ dup $dpy $default-root over $gc pick <- size-outline <--- draw-rect ]
-
-"loop" !( wfdm -- ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-size-outline <- update-posn <- draw-size-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-size-outline
- dup $frame over $posn pick $frame <- position v- <-- resize
- <- adjust-child drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io combinators namespaces quotations arrays sequences
- math math.vectors
- x11.xlib x11.constants
- mortar mortar.sugar slot-accessors
- geom.rect
- math.bitwise
- x x.gc x.widgets
- x.widgets.button
- x.widgets.wm.child
- x.widgets.wm.frame.drag.move
- x.widgets.wm.frame.drag.size ;
-
-IN: x.widgets.wm.frame
-
-SYMBOL: <wm-frame>
-
-<wm-frame> <widget> { "child" "gc" "last-state" } accessors define-simple-class
-
-<wm-frame> "create" !( id <wm-frame> -- wm-frame ) [
- new-empty
- swap <wm-child> new* >>child
- <gc> new* "white" <-- set-foreground >>gc
-
- {
- SubstructureRedirectMask
- ExposureMask
- ButtonPressMask
- ButtonReleaseMask
- ButtonMotionMask
- EnterWindowMask
- ! experimental masks
- SubstructureNotifyMask
- } flags
- >>mask
-
- <- init-widget
- "cornflowerblue" <-- set-background
- dup $child <- position <-- move
- dup $child over <-- reparent drop
- <- position-child
- <- fit-to-child
- <- make-frame-button
-
- <- map-subwindows
- <- map
-] add-class-method
-
-SYMBOL: WM_PROTOCOLS
-SYMBOL: WM_DELETE_WINDOW
-
-: init-atoms ( -- )
-"WM_PROTOCOLS" 0 intern-atom WM_PROTOCOLS set
-"WM_DELETE_WINDOW" 0 intern-atom WM_DELETE_WINDOW set ;
-
-<wm-frame> {
-
-"fit-to-child" !( wm-frame -- wm-frame )
- [ dup $child <- size { 10 20 } v+ <-- resize ]
-
-"position-child" !( wm-frame -- wm-frame )
- [ dup $child { 5 15 } <-- move drop ]
-
-"set-child-size" !( wm-frame size -- frame )
- [ >r dup $child r> <-- resize drop <- fit-to-child ]
-
-"set-child-width" !( wm-frame width -- frame )
- [ >r dup $child r> <- set-width drop <- fit-to-child ]
-
-"set-child-height" !( wm-frame height -- frame )
- [ >r dup $child r> <- set-height drop <- fit-to-child ]
-
-"adjust-child" !( wm-frame -- wm-frame )
- [ dup $child over <- size { 10 20 } v- <-- resize drop ]
-
-"update-title" !( wm-frame -- wm-frame )
- [ <- clear
- dup >r
- ! dup $gc { 5 1 } pick $child <- fetch-name <--- draw-string/top-left
- dup $gc { 5 11 } pick $child <- fetch-name <---- draw-string
- r> ]
-
-"delete-child" !( wm-frame -- wm-frame ) [
- dup $child WM_PROTOCOLS get WM_DELETE_WINDOW get <--- send-client-message
- drop ]
-
-"drag-move" !( event wm-frame -- ) [ <wm-frame-drag-move> new* ]
-
-"drag-size" !( event wm-frame -- ) [ <wm-frame-drag-size> new* ]
-
-"make-frame-button" !( frame -- frame ) [
-<button> new*
- over <-- reparent
- "" >>text
- over [ <- unmap drop ] curry >>action-1
- over [ <- delete-child drop ] curry >>action-3
- { 9 9 } <-- resize
- NorthEastGravity <-- set-gravity
- "white" <-- set-background
- over <- width 9 - 5 - 3 2array <-- move
- drop ]
-
-! !!!!!!!!!! Event handlers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-"handle-enter-window" !( event wm-frame -- )
- [ nip $child RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-
-"handle-expose" !( event wm-frame -- ) [ nip <- clear <- update-title drop ]
-
-"handle-button-press" !( event wm-frame -- ) [
- over XButtonEvent-button
- { { [ dup Button1 = ] [ drop <- drag-move ] }
- { [ dup Button2 = ] [ drop <- drag-size ] }
- { [ t ] [ 3drop ] } }
- cond ]
-
-"handle-map" !( event wm-frame -- )
- [ "<wm-frame> handle-map :: ignoring values" print flush 2drop ]
-
-"handle-unmap" !( event wm-frame -- ) [ nip <- unmap drop ]
-
-"handle-destroy-window" !( event wm-frame -- ) [
- nip dup $child <- remove-from-window-table drop
- <- remove-from-window-table <- destroy ]
-
-"handle-configure-request" !( event frame -- ) [
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-frame> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- set-child-size ] }
- { [ over CWWidth? ]
- [ over XConfigureRequestEvent-width <-- set-child-width ] }
- { [ over CWHeight? ]
- [ over XConfigureRequestEvent-height <-- set-child-height ] }
- { [ t ]
- [ "<wm-frame> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wm-frame-maximize ( wm-frame -- wm-frame )
-<- save-state
-{ 0 0 } <-- move
-dup $dpy $default-root <- size
- <-- resize
-<- adjust-child
-<- raise ;
-
-: wm-frame-maximize-vertical ( wm-frame -- wm-frame )
-0 <-- set-y
-dup $dpy $default-root <- height
- <-- set-height
-<- adjust-child ;
-
-<wm-frame> "save-state" !( wm-frame -- wm-frame ) [
- dup <- position
- over <- size
- <rect> new
- >>last-state
-] add-method
-
-<wm-frame> "restore-state" !( wm-frame -- wm-frame ) [
- dup $last-state $pos <-- move
- dup $last-state $dim <-- resize
- <- adjust-child
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
-
-IN: x.widgets.wm.menu
-
-SYMBOL: <wm-menu>
-
-<wm-menu> <keymenu> { } define-simple-class
-
-<wm-menu> "create" !( <wm-menu> -- wm-menu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-<wm-menu> {
-
-"wm-menu-handle-key-press" !( event wm-menu -- )
- [ <- unmap <- keymenu-handle-key-press ]
-
-"handle-key-press" !( event wm-menu -- ) [ <- wm-menu-handle-key-press ]
-
-"wm-menu-popup" !( wm-menu -- wm-menu )
- [ <- map <- raise RevertToPointerRoot CurrentTime <--- set-input-focus ]
-
-"popup" !( wm-menu -- wm-menu ) [ <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io combinators namespaces arrays assocs sequences math
- x11.xlib
- x11.constants
- vars mortar slot-accessors
- x x.keysym-table x.widgets x.widgets.wm.child x.widgets.wm.frame ;
-
-IN: x.widgets.wm.root
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <wm-root>
-
-<wm-root>
- <widget>
- { "keymap" } accessors
-define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: wm-root
-
-: create-wm-root ( -- )
- <wm-root> new-empty
- dpy> >>dpy
- dpy> $default-root $id >>id
- SubstructureRedirectMask >>mask
- <- add-to-window-table
- SubstructureRedirectMask <-- select-input
- H{ } clone >>keymap
- >wm-root ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-in-table ( window -- object )
-dup >r $id dpy get $window-table at r> or ;
-
-: circulate-focus ( -- )
-dpy get $default-root <- children
-[ find-in-table ] map [ <- mapped? ] filter dup length 1 >
-[ reverse dup first <- lower drop
- second <- raise
- dup <wm-frame> is? [ $child ] [ ] if
- RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-[ drop ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: managed? ( id -- ? )
-dpy get $window-table values [ <wm-child> is? ] filter [ $id ] map member? ;
-
-: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
-
-: event>state-and-name ( event -- array )
-dup XKeyEvent-state swap event>keyname 2array ;
-
-: resolve-key-event ( keymap event -- item ) event>state-and-name swap at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<wm-root> {
-
-"handle-map-request" !( event wm-root -- ) [
- { { [ over XMapRequestEvent-window managed? ]
- [ "<wm-root> handle-map-request :: window already managed" print flush
- 2drop ] }
- { [ t ] [ drop XMapRequestEvent-window <wm-frame> <<- create drop ] } }
- cond ]
-
-"handle-unmap" !( event wm-root -- ) [ 2drop ]
-
-"handle-key-press" !( event wm-root -- )
- [ $keymap swap resolve-key-event call ]
-
-"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
- 3dup name>keysym keysym-to-keycode spin
- False GrabModeAsync GrabModeAsync grab-key ]
-
-"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
- >r <--- grab-key r>
- -rot 2array pick $keymap set-at ]
-
-"handle-configure-request" !( event wm-root -- ) [
- $dpy over XConfigureRequestEvent-window <window> new ! event window
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-root> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- resize ] }
- { [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] }
- { [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] }
- { [ t ] [ "<wm-root> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces quotations arrays assocs sequences
- mortar slot-accessors x x.widgets.wm.menu x.widgets.wm.frame
- vars ;
-
-IN: x.widgets.wm.unmapped-frames-menu
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <unmapped-frames-menu>
-
-<unmapped-frames-menu> <wm-menu> { } define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: unmapped-frames-menu
-
-: create-unmapped-frames-menu ( -- )
-<unmapped-frames-menu>
- new-empty
- <- keymenu-init
- 1 <-- set-border-width
->unmapped-frames-menu ;
-
-: unmapped-frames ( -- seq )
-dpy get $window-table values
-[ <wm-frame> is? ] filter [ <- mapped? not ] filter ;
-
-<unmapped-frames-menu> {
-
-"refresh" !( menu -- menu ) [
- unmapped-frames dup
- [ $child <- fetch-name ] map swap
- [ [ <- map ] curry ] map
- [ 2array ] 2map
- >>items
- dup <- calc-size <-- resize ]
-
-"popup" !( menu -- menu ) [ <- refresh <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces namespaces.lib math sequences vars mortar
-accessors slot-accessors x ;
-
-IN: x.widgets.wm.workspace
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: workspace windows ;
-
-C: <workspace> workspace
-
-VAR: workspaces
-
-VAR: current-workspace
-
-: init-workspaces ( -- ) V{ } clone >workspaces ;
-
-: add-workspace ( -- ) { } clone <workspace> workspaces> push ;
-
-: mapped-windows ( -- seq )
-dpy get $default-root <- children [ <- mapped? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: switch-to-workspace ( n -- )
-mapped-windows current-workspace> workspaces> nth (>>windows)
-mapped-windows [ <- unmap drop ] each
-dup workspaces> nth windows>> [ <- map drop ] each
-current-workspace set* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: next-workspace ( -- )
-current-workspace> 1+ dup workspaces> length <
-[ switch-to-workspace ] [ drop ] if ;
-
-: prev-workspace ( -- )
-current-workspace> 1- dup 0 >=
-[ switch-to-workspace ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: setup-workspaces ( n -- )
-workspaces>
- [ drop ]
- [ init-workspaces [ add-workspace ] times 0 >current-workspace ]
-if ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io alien alien.c-types alien.strings namespaces threads
- arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
- io.encodings.ascii ;
-
-IN: x
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <display>
-
-SYMBOL: <window>
-
-! SYMBOL: dpy
-
-VAR: dpy
-
-<display>
- { "ptr"
- "name"
- "default-screen"
- "default-root"
- "default-gc"
- "black-pixel"
- "white-pixel"
- "colormap"
- "window-table" } accessors
-define-independent-class
-
-<display> "create" !( name <display> -- display ) [
- new-empty swap >>name
- dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
- dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
- dup $ptr XDefaultScreen >>default-screen
- dup $ptr XDefaultRootWindow dupd <window> new >>default-root
- dup $ptr over $default-screen XDefaultGC >>default-gc
- dup $ptr over $default-screen XBlackPixel >>black-pixel
- dup $ptr over $default-screen XWhitePixel >>white-pixel
- dup $ptr over $default-screen XDefaultColormap >>colormap
- H{ } clone >>window-table
- [ <- start-event-loop ] in-thread
-] add-class-method
-
-{ "id" } accessors drop
-
-DEFER: check-window-table
-
-<display> {
-
-"add-to-window-table" !( display window -- )
- [ dup $id rot $window-table set-at ]
-
-"remove-from-window-table" !( display window -- )
- [ $id swap $window-table delete-at ]
-
-"next-event" !( display event -- display event )
- [ over $ptr over XNextEvent drop ]
-
-"events-queued" !( display mode -- n ) [ >r $ptr r> XEventsQueued ]
-
-"concurrent-next-event" !( display event -- display event )
- [ over QueuedAfterFlush <-- events-queued 0 >
- [ <-- next-event ] [ 100 sleep <-- concurrent-next-event ] if ]
-
-"event-loop" !( display event -- )
-[ <-- concurrent-next-event
- 2dup >r >r
- dup XAnyEvent-window rot $window-table at dup
- [ <- handle-event ] [ 2drop ] if
- r> r>
- <-- event-loop ]
-
-"start-event-loop" !( display -- ) [ "XEvent" <c-object> <-- event-loop ]
-
-"flush" !( display -- display ) [ dup $ptr XFlush drop ]
-
-"pointer-window" !( display -- window ) [
- dup $ptr
- over $default-root $id
- 0 <Window>
- 0 <Window> dup >r
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <uint>
- XQueryPointer drop
- r> *Window <window> new
- check-window-table ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> { "dpy" "id" } accessors define-independent-class
-
-: create-window ( -- window ) <window> new-empty <- init-window ;
-
-: create-window-from-id ( dpy id -- window ) <window> new ;
-
-: check-window-table ( window -- window )
- dup $id
- over $dpy $window-table
- at
- swap or ;
-
-<window> "init-window"
- !( window -- window )
- [ dpy get
- >>dpy
- dpy get $ptr
- dpy get $default-root $id
- 0 0 100 100 0
- dpy get $black-pixel
- dpy get $white-pixel
- XCreateSimpleWindow
- >>id ]
-add-method
-
-! <window> new-empty <- init
-
-<window> "raw"
- !( window -- dpy-ptr id )
- [ dup $dpy $ptr swap $id ]
-add-method
-
-<window> "move"
- !( window point -- window )
- [ >r dup <- raw r> first2 XMoveWindow drop ]
-add-method
-
-<window> "set-x" !( window x -- window ) [
- over <- y 2array <-- move
-] add-method
-
-<window> "set-y" !( window y -- window ) [
- over <- x swap 2array <-- move
-] add-method
-
-<window> "flush"
- !( window -- window )
- [ dup $dpy <- flush drop ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 3 - Window Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 3.3 - Creating Windows
-
-<window> "destroy" !( window -- window )
- [ dup <- raw XDestroyWindow drop ]
-add-method
-
-<window> "map"
- !( window -- window )
- [ dup <- raw XMapWindow drop ]
-add-method
-
-<window> "map-subwindows"
- !( window -- window )
- [ dup <- raw XMapSubwindows drop ]
-add-method
-
-<window> "unmap"
- !( window -- window )
- [ dup <- raw XUnmapWindow drop ]
-add-method
-
-<window> "unmap-subwindows"
- !( window -- window )
- [ dup <- raw XUnmapSubwindows drop ]
-add-method
-
-! 3.7 - Configuring Windows
-
-<window> "resize"
- !( window size -- window )
- [ >r dup <- raw r> first2 XResizeWindow drop ]
-add-method
-
-<window> "set-width"
- !( window width -- window )
- [ over <- height 2array <-- resize ]
-add-method
-
-<window> "set-height"
- !( window height -- window )
- [ over <- width swap 2array <-- resize ]
-add-method
-
-<window> "set-border-width"
- !( window n -- window )
- [ >r dup <- raw r> XSetWindowBorderWidth drop ]
-add-method
-
-! 3.8 Changing Window Stacking Order
-
-<window> "raise"
- !( window -- window )
- [ dup <- raw XRaiseWindow drop ]
-add-method
-
-<window> "lower"
- !( window -- window )
- [ dup <- raw XLowerWindow drop ]
-add-method
-
-! 3.9 - Changing Window Attributes
-
-! : change-window-attributes ( valuemask attr window -- )
-! -rot >r >r <- raw r> r> XChangeWindowAttributes drop ;
-
-<window> "change-attributes" !( window valuemask attr -- window ) [
->r >r dup <- raw r> r> XChangeWindowAttributes drop
-] add-method
-
-DEFER: lookup-color
-
-<window> "set-background"
- !( window color -- window )
- [ >r dup <- raw r> lookup-color XSetWindowBackground drop ]
-add-method
-
-<window> "set-gravity" !( window gravity -- window ) [
-CWWinGravity swap
-"XSetWindowAttributes" <c-object> tuck set-XSetWindowAttributes-win_gravity
-<--- change-attributes
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 4 - Window Information Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 4.1 - Obtaining Window Information
-
-<window> {
-
-"children" !( window -- seq )
- [ <- raw 0 <uint> 0 <uint> f <void*> 0 <uint> 2dup >r >r XQueryTree drop
- r> r> swap *void* swap *uint c-uint-array>
- [ dpy get swap <window> new ] map ]
-
-"parent" !( window -- parent ) [
- dup $dpy >r
-
- dup $dpy $ptr
- swap $id
- 0 <Window>
- 0 <Window> dup >r
- f <void*>
- 0 <uint>
- XQueryTree drop
- r> *Window
- r> swap
- <window> new
- check-window-table ]
-
-"size" !( window -- size )
- [ <- raw 0 <Window> 0 <int> 0 <int>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *uint ] map ]
-
-"width" !( window -- width ) [ <- size first ]
-
-"height" !( window -- height ) [ <- size second ]
-
-"position" !( window -- position )
- [ <- raw 0 <Window>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint> 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *int ] map ]
-
-"x" !( window -- x ) [ <- position first ]
-
-"y" !( window -- y ) [ <- position second ]
-
-"as-rect" !( window -- rect ) [ dup <- position swap <- size <rect> new ]
-
-"attributes" !( window -- XWindowAttributes )
- [ <- raw "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ]
-
-"map-state" !( window -- state ) [ <- attributes XWindowAttributes-map_state ]
-
-"mapped?" !( window -- ? ) [ <- map-state IsUnmapped = not ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-atom-name ( atom -- name ) dpy get $ptr swap XGetAtomName ;
-
-: intern-atom ( atom-name only-if-exists? -- atom )
-dpy get $ptr -rot XInternAtom ;
-
-: lookup-color ( name -- pixel )
-dpy get $ptr dpy get $colormap rot
-"XColor" <c-object> dup >r "XColor" <c-object> XLookupColor drop
-dpy get $ptr dpy get $colormap r> dup >r XAllocColor drop r> XColor-pixel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 8 - Graphics Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "clear"
- !( window -- window )
- [ dup <- raw XClearWindow drop ]
-add-method
-
-<window> "draw-string"
- !( window gc pos string -- )
- [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
- XDrawString drop ]
-add-method
-
-! <window> "draw-string"
-! !( window gc pos string -- )
-! [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
-! XDrawString drop ]
-! add-method
-
-<window> "draw-line"
- !( window gc a b -- )
- [ >r >r >r <- raw r> $ptr r> first2 r> first2 XDrawLine drop ]
-add-method
-
-<window> "draw-rect"
- !( window gc rect -- )
- [ 3dup dup <- top-left swap <- top-right <---- draw-line
- 3dup dup <- top-right swap <- bottom-right <---- draw-line
- 3dup dup <- bottom-left swap <- bottom-right <---- draw-line
- dup <- top-left swap <- bottom-left <---- draw-line ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 9 - Window and Session Manager Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "reparent"
- !( window parent -- window )
- [ >r dup <- raw r> $id 0 0 XReparentWindow drop ]
-add-method
-
-<window> "add-to-save-set" !( window -- window ) [
- dup <- raw XAddToSaveSet drop
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 10 - Events
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: XButtonEvent-root-position ( event -- position )
-dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
-
-: XMotionEvent-root-position ( event -- position )
-dup XMotionEvent-x_root swap XMotionEvent-y_root 2array ;
-
-! Utility words for XConfigureRequestEvent
-
-: XConfigureRequestEvent-position ( XConfigureRequestEvent -- position )
-dup XConfigureRequestEvent-x swap XConfigureRequestEvent-y 2array ;
-
-: XConfigureRequestEvent-size ( XConfigureRequestEvent -- size )
-dup XConfigureRequestEvent-width swap XConfigureRequestEvent-height 2array ;
-
-: bit-test ( a b -- t-or-f ) bitand 0 = not ;
-
-: CWX? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWX bit-test ;
-
-: CWY? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWY bit-test ;
-
-: CWWidth? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWWidth bit-test ;
-
-: CWHeight? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWHeight bit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 11 - Event Handling Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "select-input"
- !( window mask -- window )
- [ >r dup <- raw r> XSelectInput drop ]
-add-method
-
-! 11.8 - Handling Protocol Errors
-
-SYMBOL: error-handler-quot
-
-: error-handler-callback ( -- xt )
-"void" { "Display*" "XErrorEvent*" } "cdecl"
-[ error-handler-quot get call ] alien-callback ;
-
-: set-error-handler ( quot -- )
-error-handler-quot set error-handler-callback XSetErrorHandler drop ;
-
-: install-default-error-handler ( -- )
-[ "X11 : error-handler called" print flush ] set-error-handler ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 12 - Input Device Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 12.2 - Keyboard Grabbing
-
-: grab-key
-( keycode modifiers grab-window owner-events pointer-mode keyboard-mode -- )
->r >r >r <- raw >r -rot r> r> r> r> XGrabKey drop ;
-
-! 12.5 - Controlling Input Focus
-
-<window> "set-input-focus" !( window revert-to time -- window )
- [ >r >r dup <- raw r> r> XSetInputFocus drop ]
-add-method
-
-: get-input-focus ( -- window )
- dpy> $ptr
- 0 <Window> dup >r
- 0 <int>
- XGetInputFocus drop
- r> *Window
- dpy> swap
- create-window-from-id
- check-window-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 14 - Inter-Client Communication Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "fetch-name" !( window -- name-or-f )
- [ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 16 - Application Utility Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 16.1 - Using Keyboard Utility Functions
-
-! this should go in xlib.factor
-
-USING: alien.syntax ;
-
-FUNCTION: KeyCode XKeysymToKeycode ( Display* display, KeySym keysym ) ;
-
-FUNCTION: KeySym XKeycodeToKeysym ( Display* display,
- KeyCode keycode,
- int index ) ;
-
-FUNCTION: char* XKeysymToString ( KeySym keysym ) ;
-
-: keysym-to-keycode ( keysym -- keycode ) dpy get $ptr swap XKeysymToKeycode ;
-
-USE: strings
-
-: lookup-string* ( event -- keysym string )
-10 "char" <c-array> dup >r 10 0 <KeySym> dup >r f XLookupString
-r> *KeySym swap r> swap c-char-array> >string ;
-
-: lookup-string ( event -- string ) lookup-string* nip ;
-
-: lookup-keysym ( event -- keysym ) lookup-string* drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7
-
-: event-to-keysym ( event index -- keysym )
->r dup XKeyEvent-display swap XKeyEvent-keycode r> XKeycodeToKeysym ;
-
-: keysym-to-string ( keysym -- string ) XKeysymToString ;
-
-: key-event-to-string ( event index -- str ) event-to-keysym keysym-to-string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Misc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: no-modifiers ( -- mask ) 0 ;
-
-: control-alt ( -- mask ) ControlMask Mod1Mask bitor ;
-
-: alt ( -- mask ) Mod1Mask ;
-
-: True 1 ;
-: False 0 ;
-
-<window> "send-client-message" !( window message-type data -- window ) [
-
-"XClientMessageEvent" <c-object>
-
-tuck set-XClientMessageEvent-data0
-tuck set-XClientMessageEvent-message_type
-over $id over set-XClientMessageEvent-window
-ClientMessage over set-XClientMessageEvent-type
-32 over set-XClientMessageEvent-format
-CurrentTime over set-XClientMessageEvent-data1
-
->r dup <- raw False NoEventMask r> XSendEvent drop
-
-] add-method
\ No newline at end of file
projects / factor.git / commitdiff
