{ $values { "ch" "a character" } { "?" "a boolean" } }\r
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;\r
\r
+HELP: ascii?\r
+{ $values { "ch" "a character" } { "?" "a boolean" } }\r
+{ $description "Tests for whether a number is an ASCII character." } ;\r
+\r
+HELP: ch>lower\r
+{ $values { "ch" "a character" } { "lower" "a character" } }\r
+{ $description "Converts an ASCII character to lower case." } ;\r
+\r
+HELP: ch>upper\r
+{ $values { "ch" "a character" } { "upper" "a character" } }\r
+{ $description "Converts an ASCII character to upper case." } ;\r
+\r
+HELP: >lower\r
+{ $values { "str" "a string" } { "lower" "a string" } }\r
+{ $description "Converts an ASCII string to lower case." } ;\r
+\r
+HELP: >upper\r
+{ $values { "str" "a string" } { "upper" "a string" } }\r
+{ $description "Converts an ASCII string to upper case." } ;\r
+\r
ARTICLE: "ascii" "ASCII character classes"\r
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"\r
{ $subsection blank? }\r
{ $subsection printable? }\r
{ $subsection control? }\r
{ $subsection quotable? }\r
-"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;\r
+{ $subsection ascii? }\r
+"ASCII case conversion is also implemented:"\r
+{ $subsection ch>lower }\r
+{ $subsection ch>upper }\r
+{ $subsection >lower }\r
+{ $subsection >upper }\r
+"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;\r
\r
ABOUT: "ascii"\r
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
] unit-test
+
+[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
+
+[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
+[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test
combinators.short-circuit ;\r
IN: ascii\r
\r
+: ascii? ( ch -- ? ) 0 127 between? ; inline\r
+\r
: blank? ( ch -- ? ) " \t\n\r" member? ; inline\r
\r
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline\r
\r
: alpha? ( ch -- ? )\r
[ [ Letter? ] [ digit? ] ] 1|| ;\r
+\r
+: ch>lower ( ch -- lower )\r
+ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;\r
+\r
+: >lower ( str -- lower )\r
+ [ ch>lower ] map ;\r
+\r
+: ch>upper ( ch -- upper )\r
+ dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;\r
+\r
+: >upper ( str -- upper )\r
+ [ ch>upper ] map ;\r
{ $examples
{ $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
}
-{ $see-also base64> } ;
+{ $see-also base64> >base64-lines } ;
+
+HELP: >base64-lines
+{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
+{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." }
+{ $see-also base64> >base64-lines } ;
+
HELP: base64>
{ $values { "base64" "a string of base64 characters" } { "seq" sequence } }
{ $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
}
{ $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
-{ $see-also >base64 } ;
+{ $see-also >base64 >base64-lines } ;
+
+HELP: encode-base64
+{ $description "Reads the standard input and writes it to standard output encoded in base64." } ;
+
+HELP: decode-base64
+{ $description "Reads the standard input and decodes it, writing to standard output." } ;
+
+HELP: encode-base64-lines
+{ $description "Reads the standard input and writes it to standard output encoded in base64 with a crlf every 76 characters." } ;
ARTICLE: "base64" "Base 64 conversions"
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
-"Converting to base 64:"
+"Converting to and from base64 as strings:"
{ $subsection >base64 }
-"Converting back to binary:"
-{ $subsection base64> } ;
+{ $subsection >base64-lines }
+{ $subsection base64> }
+"Using base64 from streams:"
+{ $subsection encode-base64 }
+{ $subsection encode-base64-lines }
+{ $subsection decode-base64 } ;
ABOUT: "base64"
-USING: kernel tools.test base64 strings ;
+USING: kernel tools.test base64 strings sequences ;
IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
[ "a" ] [ "a" >base64 base64> >string ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
>base64 >string
] unit-test
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+ "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+ >base64-lines >string
+] unit-test
+
\ >base64 must-infer
\ base64> must-infer
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping
-accessors ;
+USING: combinators io io.binary io.encodings.binary
+io.streams.byte-array io.streams.string kernel math namespaces
+sequences strings ;
IN: base64
<PRIVATE
-: count-end ( seq quot -- n )
- trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
+: read1-ignoring ( ignoring -- ch )
+ read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+
+: read-ignoring ( ignoring n -- str )
+ [ drop read1-ignoring ] with map harvest
+ [ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+ nth ; inline
: base64>ch ( ch -- ch )
{
f 0 f f f 0 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 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ;
+ } nth ; inline
+
+SYMBOL: column
+
+: write1-lines ( ch -- )
+ write1
+ column get [
+ 1+ [ 76 = [ "\r\n" write ] when ]
+ [ 76 mod column set ] bi
+ ] when* ;
-: encode3 ( seq -- seq )
+: write-lines ( str -- )
+ [ write1-lines ] each ;
+
+: encode3 ( seq -- )
be> 4 <reversed> [
- -6 * shift HEX: 3f bitand ch>base64
- ] with B{ } map-as ;
+ -6 * shift HEX: 3f bitand ch>base64 write1-lines
+ ] with each ; inline
+
+: encode-pad ( seq n -- )
+ [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
+ [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
-: decode4 ( str -- str )
- 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
+ERROR: malformed-base64 ;
-: >base64-rem ( str -- str )
- [ 3 0 pad-right encode3 ] [ length 1+ ] bi
- head-slice 4 CHAR: = pad-right ;
+: decode4 ( seq -- )
+ [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+ [ [ CHAR: = = ] count ] bi head-slice*
+ [ write1 ] each ; inline
PRIVATE>
+: encode-base64 ( -- )
+ 3 read dup length {
+ { 0 [ drop ] }
+ { 3 [ encode3 encode-base64 ] }
+ [ encode-pad encode-base64 ]
+ } case ;
+
+: encode-base64-lines ( -- )
+ 0 column [ encode-base64 ] with-variable ;
+
+: decode-base64 ( -- )
+ "\n\r" 4 read-ignoring dup length {
+ { 0 [ drop ] }
+ { 4 [ decode4 decode-base64 ] }
+ [ malformed-base64 ]
+ } case ;
+
: >base64 ( seq -- base64 )
- #! cut string into two pieces, convert 3 bytes at a time
- #! pad string with = when not enough bits
- dup length dup 3 mod - cut
- [ 3 <groups> [ encode3 ] map concat ]
- [ [ "" ] [ >base64-rem ] if-empty ]
- bi* append ;
+ binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
: base64> ( base64 -- seq )
- #! input length must be a multiple of 4
- [ 4 <groups> [ decode4 ] map concat ]
- [ [ CHAR: = = ] count-end ]
- bi head* ;
+ [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+
+: >base64-lines ( seq -- base64 )
+ binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;
IN: bootstrap.help
: load-help ( -- )
+ "help.lint" require
"alien.syntax" require
"compiler" require
"math.ratios" require
"math.floats" require
-"math.complex" require
-
-"prettyprint" vocab [ "math.complex.prettyprint" require ] when
+"math.complex" require
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs vocabs.loader kernel ;
+USING: vocabs vocabs.loader kernel io.thread threads
+compiler.utilities namespaces ;
IN: bootstrap.threads
-USE: io.thread
-USE: threads
-
"debugger" vocab [
"debugger.threads" require
] when
+
+[ yield ] yield-hook set-global
\ No newline at end of file
-USING: strings.parser kernel namespaces unicode unicode.data ;
-IN: bootstrap.unicode
-
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math sequences
+multiline ;
+IN: combinators.smart
+
+HELP: input<sequence
+{ $values
+ { "quot" quotation }
+ { "newquot" quotation }
+}
+{ $description "Infers the number of inputs, " { $snippet "n" } ", to " { $snippet "quot" } " and calls the " { $snippet "quot" } " with the first " { $snippet "n" } " values from a sequence." }
+{ $examples
+ { $example
+ "USING: combinators.smart math prettyprint ;"
+ "{ 1 2 3 } [ + + ] input<sequence ."
+ "6"
+ }
+} ;
+
+HELP: output>array
+{ $values
+ { "quot" quotation }
+ { "newquot" quotation }
+}
+{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
+{ $examples
+ { $example
+ <" USING: combinators combinators.smart math prettyprint ;
+9 [
+ { [ 1- ] [ 1+ ] [ sq ] } cleave
+] output>array .">
+ "{ 8 10 81 }"
+ }
+} ;
+
+HELP: output>sequence
+{ $values
+ { "quot" quotation } { "exemplar" "an exemplar" }
+ { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ."
+ "V{ 5 6 7 }"
+ }
+} ;
+
+HELP: reduce-outputs
+{ $values
+ { "quot" quotation } { "operation" quotation }
+ { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ."
+ "-9"
+ }
+} ;
+
+HELP: sum-outputs
+{ $values
+ { "quot" quotation }
+ { "n" integer }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+ "20"
+ }
+} ;
+
+ARTICLE: "combinators.smart" "Smart combinators"
+"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
+"Smart inputs from a sequence:"
+{ $subsection input<sequence }
+"Smart outputs to a sequence:"
+{ $subsection output>sequence }
+{ $subsection output>array }
+"Reducing the output of a quotation:"
+{ $subsection reduce-outputs }
+"Summing the output of a quotation:"
+{ $subsection sum-outputs } ;
+
+ABOUT: "combinators.smart"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test combinators.smart math kernel ;
+IN: combinators.smart.tests
+
+: test-bi ( -- 9 11 )
+ 10 [ 1- ] [ 1+ ] bi ;
+
+[ [ test-bi ] output>array ] must-infer
+[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
+
+[ { 9 11 } [ + ] input<sequence ] must-infer
+[ 20 ] [ { 9 11 } [ + ] input<sequence ] unit-test
+
+
+
+[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test
+
+[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer
+
+[ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry generalizations kernel macros math.order
+stack-checker math ;
+IN: combinators.smart
+
+MACRO: output>sequence ( quot exemplar -- newquot )
+ [ dup infer out>> ] dip
+ '[ @ _ _ nsequence ] ;
+
+: output>array ( quot -- newquot )
+ { } output>sequence ; inline
+
+MACRO: input<sequence ( quot -- newquot )
+ [ infer in>> ] keep
+ '[ _ firstn @ ] ;
+
+MACRO: reduce-outputs ( quot operation -- newquot )
+ [ dup infer out>> 1 [-] ] dip n*quot compose ;
+
+: sum-outputs ( quot -- n )
+ [ + ] reduce-outputs ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays sets threads libc continuations.private
+alien.strings alien.arrays sets libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder
-compiler.codegen.fixup ;
+compiler.codegen.fixup
+compiler.utilities ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
dup current-callback eq? [
drop
] [
- yield wait-to-return
+ yield-hook get call wait-to-return
] if ;
: do-callback ( quot token -- )
-! Copyright (C) 2004, 2008 Slava Pestov.
+! 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
-threads graphs generic combinators deques search-deques io
+graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
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.cfg.stack-frame compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield ] slurp-deque ;
+ [ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry
+words namespaces continuations classes fry combinators.smart
compiler.tree
compiler.tree.builder
compiler.tree.recursive
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
- [ classes-known? 2 0 ? ]
[
- {
- [ body-length-bias ]
- [ "default" word-prop -4 0 ? ]
- [ "specializer" word-prop 1 0 ? ]
- [ method-body? 1 0 ? ]
- } cleave
- node-count-bias
- loop-nesting get 0 or 2 *
- ] bi* + + + + + + ;
+ [ classes-known? 2 0 ? ]
+ [
+ {
+ [ body-length-bias ]
+ [ "default" word-prop -4 0 ? ]
+ [ "specializer" word-prop 1 0 ? ]
+ [ method-body? 1 0 ? ]
+ } cleave
+ node-count-bias
+ loop-nesting get 0 or 2 *
+ ] bi*
+ ] sum-outputs ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
-! 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 arrays vectors fry
-math.order ;
+math.order namespaces assocs ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
+
+SYMBOL: yield-hook
+
+yield-hook global [ [ ] or ] change-at
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db.tester ;
+IN: db.tester.tests
+
+[ ] [ sqlite-test-db db-tester ] unit-test
+[ ] [ sqlite-test-db db-tester2 ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db.pools db.sqlite db.tuples
+db.types kernel math random threads tools.test db sequences
+io prettyprint ;
+IN: db.tester
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
+: test-db ( -- db ) "test.db" <sqlite-db> ;
+
+: db-tester ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ 10 [
+ drop
+ 10 [
+ dup [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] with-db
+ ] times
+ ] with parallel-each
+ ] bi ;
+
+: db-tester2 ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ <db-pool> [
+ 10 [
+ 10 [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] times
+ ] parallel-each
+ ] with-pooled-db
+ ] bi ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
-io definitions kernel continuations ;
+io io.styles definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
editors.vim vocabs.loader make ;
IN: editors.gvim
+! This code builds on the code in editors.vim; see there for
+! more information.
+
SINGLETON: gvim
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
- [ gvim-path , swap , "+" swap number>string append , ] { } make ;
+ [ gvim-path , "+" swap number>string append , , ] { } make ;
gvim vim-editor set-global
! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating http.server.templating.fhtml
-io.files ;
+USING: html.templates html.templates.fhtml io.files io.pathnames ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path <fhtml>
- "misc/factor.vim" resource-path
+ "misc/vim/syntax/factor.vim" resource-path
template-convert ;
MAIN: generate-vim-syntax
"USE: vim"
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
}
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
-
+"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
+$nl
+"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "." ;
USING: combinators.short-circuit accessors combinators io
io.encodings.8-bit io.encodings io.encodings.binary
io.encodings.utf8 io.files io.files.info io.directories
-io.pathnames io.sockets kernel math.parser namespaces make
-sequences ftp io.launcher.unix.parser unicode.case splitting
+io.sockets kernel math.parser namespaces make sequences
+ftp io.launcher.unix.parser unicode.case splitting
assocs classes io.servers.connection destructors calendar
io.timeouts io.streams.duplex threads continuations math
concurrency.promises byte-arrays io.backend tools.hexdump
-tools.files io.streams.string math.bitwise ;
+io.streams.string math.bitwise tools.files io.pathnames ;
IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ;
{ $examples\r
"Some core words expressed in terms of " { $link napply } ":"\r
{ $table\r
- { { $link bi@ } { $snippet "1 napply" } }\r
- { { $link tri@ } { $snippet "2 napply" } }\r
+ { { $link call } { $snippet "1 napply" } }\r
+ { { $link bi@ } { $snippet "2 napply" } }\r
+ { { $link tri@ } { $snippet "3 napply" } }\r
}\r
} ;\r
\r
-USING: tools.test generalizations kernel math arrays sequences ;\r
+USING: tools.test generalizations kernel math arrays sequences ascii ;\r
IN: generalizations.tests\r
\r
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
+\r
+[ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test\r
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test\r
[ [ dup 2^ 2array ] 5 napply ] must-infer\r
\r
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
-MACRO: napply ( n -- )
- 2 [a,b]
- [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
- map concat >quotation [ call ] append ;
+MACRO: napply ( quot n -- )
+ swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] <repetition> spread>quot ;
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
- "{ 1 2 3 4 5 6 } 3 <groups> 0 swap nth ."
+ "{ 1 2 3 4 5 6 } 3 <groups> first ."
"{ 1 2 3 }"
}
} ;
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
- "{ 1 2 3 4 5 6 } 3 <sliced-groups> 1 swap nth ."
+ "{ 1 2 3 4 5 6 } 3 <sliced-groups> second ."
"T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
}
} ;
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files tools.files
-sequences kernel ;
+ <" USING: command-line namespaces io io.files
+io.pathnames tools.files sequences kernel ;
command-line get [
current-directory get directory.
{ $subsection "io.streams.byte-array" }
{ $heading "Utilities" }
{ $subsection "stream-binary" }
-{ $subsection "styles" }
+{ $subsection "io.styles" }
{ $subsection "checksums" }
{ $heading "Implementation" }
{ $subsection "io.streams.c" }
{ $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
-{ $subsection "tools.deploy" } ;
+{ $subsection "tools.deploy" }
+{ $see-also "ui-tools" } ;
ARTICLE: "article-index" "Article index"
{ $index [ articles get keys ] } ;
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel namespaces prettyprint quotations
+USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present fry ;
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components html.forms
-splitting unicode.categories furnace accessors ;
+splitting unicode.categories furnace accessors
+html.templates.chloe.compiler ;
IN: html.templates.chloe.tests
: run-template
"test12" test-template call-template
] run-template
] unit-test
+
+[
+ [
+ "test13" test-template call-template
+ ] run-template
+] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with
[ drop tag-stack get pop* ]
} cleave ;
+ERROR: unknown-chloe-tag tag ;
+
: compile-chloe-tag ( tag -- )
- ! "Unknown chloe tag: " prepend throw
dup main>> dup tags get at
- [ curry assert-depth ] [ 2drop ] ?if ;
+ [ curry assert-depth ]
+ [ unknown-chloe-tag ]
+ ?if ;
: compile-element ( element -- )
{
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:this-tag-does-not-exist />
+
+</t:chloe>
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n\"" intersect empty?
- [ "Header injection attack" throw ] unless ;
+ dup "\r\n\"" intersects?
+ [ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
>alist sort-keys [
] { } make ;
: check-cookie-string ( string -- string' )
- dup "=;'\"\r\n" intersect empty?
- [ "Bad cookie name or value" throw ] unless ;
+ dup "=;'\"\r\n" intersects?
+ [ "Bad cookie name or value" throw ] when ;
: unparse-cookie-value ( key value -- )
{
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+HELP: with-directory-entries
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+
HELP: delete-file
{ $values { "path" "a pathname string" } }
{ $description "Deletes a file." }
"Directory listing:"
{ $subsection directory-entries }
{ $subsection directory-files }
+{ $subsection with-directory-entries }
{ $subsection with-directory-files } ;
ARTICLE: "io.directories.create" "Creating directories"
: directory-files ( path -- seq )
directory-entries [ name>> ] map ;
+: with-directory-entries ( path quot -- )
+ '[ "" directory-entries @ ] with-directory ; inline
+
: with-directory-files ( path quot -- )
'[ "" directory-files @ ] with-directory ; inline
: push-directory ( path iter -- )
[ qualified-directory ] dip [
- dup queue>> swap bfs>>
+ [ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
] curry each ;
USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
-sequences grouping alien.strings io.encodings.utf8
+sequences grouping alien.strings io.encodings.utf8 unix.types
specialized-arrays.direct.uint arrays io.files.info.unix ;
IN: io.files.info.unix.freebsd
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
-io.pathnames ;
+io.pathnames unix.types ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
{ "n" integer } }
{ $description "Returns the Unix file permissions for a given file." } ;
-HELP: file-username
+HELP: file-user-name
{ $values
{ "path" "a pathname string" }
{ "string" string } }
-{ $description "Returns the username for a given file." } ;
+{ $description "Returns the user-name for a given file." } ;
HELP: file-user-id
{ $values
HELP: set-file-user
{ $values
{ "path" "a pathname string" } { "string/id" "a string or a user id" } }
-{ $description "Sets a file's user id from the given user id or username." } ;
+{ $description "Sets a file's user id from the given user id or user-name." } ;
HELP: set-file-modified-time
{ $values
ARTICLE: "unix-file-ids" "Unix file user and group ids"
"Reading file user data:"
{ $subsection file-user-id }
-{ $subsection file-username }
+{ $subsection file-user-name }
"Setting file user data:"
{ $subsection set-file-user }
"Reading file group data:"
PRIVATE>
-: ch>file-type ( ch -- type )
- {
- { CHAR: b [ +block-device+ ] }
- { CHAR: c [ +character-device+ ] }
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: s [ +socket+ ] }
- { CHAR: p [ +fifo+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: file-type>ch ( type -- string )
- {
- { +block-device+ [ CHAR: b ] }
- { +character-device+ [ CHAR: c ] }
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +socket+ [ CHAR: s ] }
- { +fifo+ [ CHAR: p ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline
: file-user-id ( path -- uid )
normalize-path file-info uid>> ;
-: file-username ( path -- string )
- file-user-id username ;
+: file-user-name ( path -- string )
+ file-user-id user-name ;
: file-group-id ( path -- gid )
normalize-path file-info gid>> ;
: file-group-name ( path -- string )
file-group-id group-name ;
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- ch )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+<PRIVATE
+
+: file-type>executable ( directory-entry -- string )
+ name>> any-execute? "*" "" ? ;
+
+PRIVATE>
+
+: file-type>trailing ( directory-entry -- string )
+ dup type>>
+ {
+ { +directory+ [ drop "/" ] }
+ { +symbolic-link+ [ drop "@" ] }
+ { +fifo+ [ drop "|" ] }
+ { +socket+ [ drop "=" ] }
+ { +whiteout+ [ drop "%" ] }
+ { +unknown+ [ file-type>executable ] }
+ { +regular-file+ [ file-type>executable ] }
+ [ drop file-type>executable ]
+ } case ;
USING: help.markup help.syntax io io.ports kernel math
-io.pathnames io.directories math.parser io.files ;
+io.pathnames io.directories math.parser io.files strings ;
IN: io.files.unique
HELP: temporary-path
HELP: make-unique-file*
{ $values
- { "prefix" null } { "suffix" null }
+ { "prefix" string } { "suffix" string }
{ "path" "a pathname string" }
}
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
ARTICLE: "io.files.unique" "Temporary files"
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
-"Files:"
+"Creating temporary files:"
{ $subsection make-unique-file }
{ $subsection make-unique-file* }
{ $subsection with-unique-file }
-"Directories:"
+"Creating temporary directories:"
{ $subsection make-unique-directory }
{ $subsection with-unique-directory } ;
[ ] [ test-file f f 2array set-file-times ] unit-test
-[ ] [ test-file real-username set-file-user ] unit-test
+[ ] [ test-file real-user-name set-file-user ] unit-test
[ ] [ test-file real-user-id set-file-user ] unit-test
[ ] [ test-file real-group-name set-file-group ] unit-test
[ ] [ test-file real-group-id set-file-group ] unit-test
-[ t ] [ test-file file-username real-username = ] unit-test
+[ t ] [ test-file file-user-name real-user-name = ] unit-test
[ t ] [ test-file file-group-name real-group-name = ] unit-test
[ ]
CreateFile-flags f CreateFile opened-file
] with-destructors ;
-: open-pipe-r/w ( path -- win32-file )
+: open-r/w ( path -- win32-file )
{ GENERIC_READ GENERIC_WRITE } flags
OPEN_EXISTING 0 open-file ;
HELP: with-stream
{ $values { "stream" duplex-stream } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ", which must be a duplex stream. The stream is closed if the quotation returns or throws an error." } ;
HELP: with-stream*
{ $values { "stream" duplex-stream } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } "." }
+{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ", which must be a duplex stream." }
{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
HELP: <encoder-duplex>
--- /dev/null
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"
\ No newline at end of file
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io io.timeouts io.styles destructors ;
IN: io.streams.null
-USING: kernel io io.timeouts io.streams.duplex destructors ;
-TUPLE: null-stream ;
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ;
-TUPLE: null-reader < null-stream ;
-
M: null-reader stream-readln drop f ;
M: null-reader stream-read1 drop f ;
M: null-reader stream-read-until 2drop f f ;
M: null-reader stream-read 2drop f ;
-TUPLE: null-writer < null-stream ;
-
M: null-writer stream-write1 2drop ;
M: null-writer stream-write 2drop ;
M: null-writer stream-nl drop ;
M: null-writer stream-write-table 3drop ;
: with-null-reader ( quot -- )
- T{ null-reader } swap with-input-stream* ; inline
+ null-reader swap with-input-stream* ; inline
: with-null-writer ( quot -- )
- T{ null-writer } swap with-output-stream* ; inline
-
-: with-null-stream ( quot -- )
- T{ duplex-stream f T{ null-reader } T{ null-writer } }
- swap with-stream* ; inline
+ null-writer swap with-output-stream* ; inline
\ No newline at end of file
USING: help.markup help.syntax io.streams.plain io strings
-hashtables ;
+hashtables kernel quotations ;
IN: io.styles
+HELP: stream-format
+{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
+$nl
+"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-block-stream
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
+$nl
+"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
+$nl
+"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: stream-write-table
+{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $contract "Prints a table of cells produced by " { $link with-cell } "."
+$nl
+"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-cell-stream
+{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $contract "Creates an output stream which writes to a table cell object." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: make-span-stream
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
+$nl
+"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: format
+{ $values { "str" string } { "style" "a hashtable" } }
+{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $notes "Details are in the documentation for " { $link stream-format } "." }
+$io-error ;
+
+HELP: with-nesting
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
+{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
+$io-error ;
+
+HELP: tabular-output
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
+$nl
+"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
+{ $examples
+ { $code
+ "{ { 1 2 } { 3 4 } }"
+ "H{ { table-gap { 10 10 } } } ["
+ " [ [ [ [ . ] with-cell ] each ] with-row ] each"
+ "] tabular-output"
+ }
+}
+$io-error ;
+
+HELP: with-row
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
+$io-error ;
+
+HELP: with-cell
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
+$io-error ;
+
+HELP: write-cell
+{ $values { "str" string } }
+{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
+$io-error ;
+
+HELP: with-style
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
+{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
+$io-error ;
+
+ARTICLE: "formatted-stream-protocol" "Formatted stream protocol"
+"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for output streams that support rich text."
+{ $subsection stream-format }
+{ $subsection make-span-stream }
+{ $subsection make-block-stream }
+{ $subsection make-cell-stream }
+{ $subsection stream-write-table } ;
+
+ARTICLE: "formatted-stdout" "Formatted output on the default stream"
+"The below words perform formatted output on " { $link output-stream } "."
+$nl
+"Formatted output:"
+{ $subsection format }
+{ $subsection with-style }
+{ $subsection with-nesting }
+"Tabular output:"
+{ $subsection tabular-output }
+{ $subsection with-row }
+{ $subsection with-cell }
+{ $subsection write-cell } ;
+
ARTICLE: "character-styles" "Character styles"
"Character styles for " { $link stream-format } " and " { $link with-style } ":"
{ $subsection foreground }
"The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:"
{ $subsection write-object } ;
-ARTICLE: "styles" "Formatted output"
+ARTICLE: "styles" "Styled text"
"The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$nl
"Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary."
{ $subsection "table-styles" }
{ $subsection "presentations" } ;
-ABOUT: "styles"
+ARTICLE: "io.styles" "Formatted output"
+"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for formatted output. This is used by the prettyprinter, help system, and various developer tools. Implementations include " { $vocab-link "ui.gadgets.panes" } ", " { $vocab-link "html.streams" } ", and " { $vocab-link "io.streams.plain" } "."
+{ $subsection "formatted-stream-protocol" }
+{ $subsection "formatted-stdout" }
+{ $subsection "styles" } ;
+
+ABOUT: "io.styles"
HELP: plain
{ $description "A value for the " { $link font-style } " character style denoting plain text." } ;
HELP: standard-table-style
{ $values { "style" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
+
+ARTICLE: "io.streams.plain" "Plain writer streams"
+"Plain writer streams wrap an underlying stream and provide a default implementation of "
+{ $link stream-nl } ", "
+{ $link stream-format } ", "
+{ $link make-span-stream } ", "
+{ $link make-block-stream } " and "
+{ $link make-cell-stream } "."
+{ $subsection plain-writer } ;
\ No newline at end of file
--- /dev/null
+IN: io.styles.tests
+USING: io.styles tools.test ;
+
+\ stream-format must-infer
+\ stream-write-table must-infer
+\ make-span-stream must-infer
+\ make-block-stream must-infer
+\ make-cell-stream must-infer
\ No newline at end of file
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io colors summary make accessors splitting
-kernel ;
+USING: hashtables io io.streams.plain io.streams.string
+colors summary make accessors splitting math.order
+kernel namespaces assocs destructors strings sequences ;
IN: io.styles
+GENERIC: stream-format ( str style stream -- )
+GENERIC: make-span-stream ( style stream -- stream' )
+GENERIC: make-block-stream ( style stream -- stream' )
+GENERIC: make-cell-stream ( style stream -- stream' )
+GENERIC: stream-write-table ( table-cells style stream -- )
+
+: format ( str style -- ) output-stream get stream-format ;
+
+: tabular-output ( style quot -- )
+ swap [ { } make ] dip output-stream get stream-write-table ; inline
+
+: with-row ( quot -- )
+ { } make , ; inline
+
+: with-cell ( quot -- )
+ H{ } output-stream get make-cell-stream
+ [ swap with-output-stream ] keep , ; inline
+
+: write-cell ( str -- )
+ [ write ] with-cell ; inline
+
+: with-style ( style quot -- )
+ swap dup assoc-empty? [
+ drop call
+ ] [
+ output-stream get make-span-stream swap with-output-stream
+ ] if ; inline
+
+: with-nesting ( style quot -- )
+ [ output-stream get make-block-stream ] dip
+ with-output-stream ; inline
+
+TUPLE: filter-writer stream ;
+
+M: filter-writer stream-format
+ stream>> stream-format ;
+
+M: filter-writer stream-write
+ stream>> stream-write ;
+
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
+
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
+
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
+
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
+
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ stream>> dispose ;
+
+TUPLE: ignore-close-stream < filter-writer ;
+
+M: ignore-close-stream dispose drop ;
+
+C: <ignore-close-stream> ignore-close-stream
+
+TUPLE: style-stream < filter-writer style ;
+
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap assoc-union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
+
+M: style-stream stream-format
+ do-nested-style stream-format ;
+
+M: style-stream stream-write
+ [ style>> ] [ stream>> ] bi stream-format ;
+
+M: style-stream stream-write1
+ [ 1string ] dip stream-write ;
+
+M: style-stream make-span-stream
+ do-nested-style make-span-stream ;
+
+M: style-stream make-block-stream
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
+
+M: style-stream make-cell-stream
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
+
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
+
+M: plain-writer stream-format
+ nip stream-write ;
+
+M: plain-writer make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+M: plain-writer make-block-stream
+ nip <ignore-close-stream> ;
+
+: format-column ( seq ? -- seq )
+ [
+ [ 0 [ length max ] reduce ] keep
+ swap [ CHAR: \s pad-right ] curry map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
+
+M: plain-writer stream-write-table
+ [ drop format-table [ print ] each ] with-output-stream* ;
+
+M: plain-writer make-cell-stream 2drop <string-writer> ;
+
+! Font styles
SYMBOL: plain
SYMBOL: bold
SYMBOL: italic
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test
+
+[ 4 ] [ BIN: 1010101 bit-count ] unit-test
+[ 0 ] [ BIN: 0 bit-count ] unit-test
+[ 1 ] [ BIN: 1 bit-count ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
-combinators fry io.binary ;
+combinators fry io.binary combinators.smart ;
IN: math.bitwise
! utilities
GENERIC: (bit-count) ( x -- n )
M: fixnum (bit-count)
- {
- [ byte-bit-count ]
- [ -8 shift byte-bit-count ]
- [ -16 shift byte-bit-count ]
- [ -24 shift byte-bit-count ]
- } cleave + + + ;
+ [
+ {
+ [ byte-bit-count ]
+ [ -8 shift byte-bit-count ]
+ [ -16 shift byte-bit-count ]
+ [ -24 shift byte-bit-count ]
+ } cleave
+ ] sum-outputs ;
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
math.libm math.functions arrays math.functions.private sequences
IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
+
+USE: prettyprint.custom
+
+M: complex pprint* pprint-object ;
+M: complex pprint-delims drop \ C{ \ } ;
+M: complex >pprint-sequence >rect 2array ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions arrays prettyprint.custom kernel ;
-IN: math.complex.prettyprint
-
-M: complex pprint* pprint-object ;
-M: complex pprint-delims drop \ C{ \ } ;
-M: complex >pprint-sequence >rect 2array ;
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested accessors sets ;
+accessors sets ;
IN: prettyprint.sections
! State
dup
[ nfa-table>> final-states>> keys ]
[ dfa-table>> transitions>> states ] bi
- [ intersect empty? not ] with filter
+ [ intersects? ] with filter
swap dfa-table>> final-states>>
[ conjoin ] curry each ;
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 ;
+regexp.transition-tables words sets regexp.classes unicode.case.private ;
+! 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
SYMBOL: negation-mode
M: character-class-range nfa-node ( node -- )
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
USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser namespaces sets
quotations sequences splitting vectors math.order
-unicode.categories strings regexp.backend regexp.utils
-unicode.case words locals regexp.classes ;
+strings regexp.backend regexp.utils
+unicode.case unicode.categories words locals regexp.classes ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
parse-til-E
drop1
[ epsilon ] [
- [ quot call <constant> ] V{ } map-as
+ quot call [ <constant> ] V{ } map-as
first|concatenation
] if-empty ; inline
[ ] (parse-escaped-literals) ;
: lower-case-literals ( -- obj )
- [ ch>lower ] (parse-escaped-literals) ;
+ [ >lower ] (parse-escaped-literals) ;
: upper-case-literals ( -- obj )
- [ ch>upper ] (parse-escaped-literals) ;
+ [ >upper ] (parse-escaped-literals) ;
: parse-escaped ( -- obj )
read1
[ { "hello" "." "world" } validate-message ] must-fail
-[ "hello\r\nworld\r\n.\r\n" ] [
+[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
"hello\nworld" [ send-body ] with-string-writer
] unit-test
[
{
+ { "Content-Transfer-Encoding" "base64" }
+ { "Content-Type" "Text/plain; charset=utf-8" }
{ "From" "Doug <erg@factorcode.org>" }
+ { "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
}
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" intersect empty?
- [ bad-email-address ] unless ;
+ dup "\r\n>" intersects?
+ [ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
[ message-contains-dot ] when ;
: send-body ( body -- )
- string-lines
- validate-message
- [ write crlf ] each
+ utf8 encode
+ >base64-lines write crlf
"." command ;
: quit ( -- )
: auth ( -- ) smtp-auth get send-auth ;
+: encode-header ( string -- string' )
+ dup aux>> [
+ "=?utf-8?B?"
+ swap utf8 encode >base64
+ "?=" 3append
+ ] when ;
+
ERROR: invalid-header-string string ;
: validate-header ( string -- string' )
- dup "\r\n" intersect empty?
- [ invalid-header-string ] unless ;
+ dup "\r\n" intersects?
+ [ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]
- [ ": " write validate-header write ] bi* crlf ;
+ [ ": " write validate-header encode-header write ] bi* crlf ;
: write-headers ( assoc -- )
[ write-header ] assoc-each ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
+: utf8-mime-header ( -- alist )
+ {
+ { "MIME-Version" "1.0" }
+ { "Content-Transfer-Encoding" "base64" }
+ { "Content-Type" "Text/plain; charset=utf-8" }
+ } ;
+
: email>headers ( email -- hashtable )
[
{
} cleave
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
- ] { } make-assoc ;
+ ] { } make-assoc utf8-mime-header append ;
: (send-email) ( headers email -- )
[
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math.order quotations
+sequences strings ;
+IN: sorting.human
+
+HELP: find-numbers
+{ $values
+ { "string" string }
+ { "seq" sequence }
+}
+{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
+
+HELP: human-<=>
+{ $values
+ { "obj1" object } { "obj2" object }
+ { "<=>" "an ordering specifier" }
+}
+{ $description "Compares two objects after converting numbers in the string into integers." } ;
+
+HELP: human->=<
+{ $values
+ { "obj1" object } { "obj2" object }
+ { ">=<" "an ordering specifier" }
+}
+{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
+
+HELP: human-compare
+{ $values
+ { "obj1" object } { "obj2" object } { "quot" quotation }
+ { "<=>" "an ordering specifier" }
+}
+{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
+
+HELP: human-sort
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
+
+HELP: human-sort-keys
+{ $values
+ { "seq" "an alist" }
+ { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
+
+HELP: human-sort-values
+{ $values
+ { "seq" "an alist" }
+ { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
+
+{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
+
+ARTICLE: "sorting.human" "sorting.human"
+"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
+"Comparing two objects:"
+{ $subsection human-<=> }
+{ $subsection human->=< }
+{ $subsection human-compare }
+"Sort a sequence:"
+{ $subsection human-sort }
+{ $subsection human-sort-keys }
+{ $subsection human-sort-values }
+"Splitting a string into substrings and integers:"
+{ $subsection find-numbers } ;
+
+ABOUT: "sorting.human"
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting ;
+USING: peg.ebnf math.parser kernel assocs sorting fry
+math.order sequences ascii splitting.monotonic ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-: human-sort ( seq -- seq' )
- [ dup find-numbers ] { } map>assoc sort-values keys ;
+: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+
+: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
+
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
+
+: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
+
+: human-sort-keys ( seq -- sortedseq )
+ [ [ first ] human-compare ] sort ;
+
+: human-sort-values ( seq -- sortedseq )
+ [ [ second ] human-compare ] sort ;
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math.order
+sequences ;
+IN: sorting.slots
+
+HELP: compare-slots
+{ $values
+ { "sort-specs" "a sequence of accessors ending with a comparator" }
+ { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+}
+{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
+
+HELP: sort-by-slots
+{ $values
+ { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
+ { "seq'" sequence }
+}
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
+{ $examples
+ "Sort by slot c, then b descending:"
+ { $example
+ "USING: accessors math.order prettyprint sorting.slots ;"
+ "IN: scratchpad"
+ "TUPLE: sort-me a b ;"
+ "{"
+ " T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
+ " T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
+ "}"
+ "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+ "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
+ }
+} ;
+
+HELP: split-by-slots
+{ $values
+ { "accessor-seqs" "a sequence of sequences of tuple accessors" }
+ { "quot" quotation }
+}
+{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+
+ARTICLE: "sorting.slots" "Sorting by slots"
+"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
+"Comparing two objects by a sequence of slots:"
+{ $subsection compare-slots }
+"Sorting a sequence by a sequence of slots:"
+{ $subsection sort-by-slots } ;
+
+ABOUT: "sorting.slots"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.order sorting.slots tools.test
+sorting.human arrays sequences kernel assocs multiline ;
+IN: sorting.literals.tests
+
+TUPLE: sort-test a b c tuple2 ;
+
+TUPLE: tuple2 d ;
+
+[
+ {
+ T{ sort-test { a 1 } { b 3 } { c 9 } }
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ }
+] [
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+ {
+ T{ sort-test { a 1 } { b 3 } { c 9 } }
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ }
+] [
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+ {
+ {
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ }
+ { T{ sort-test { a 1 } { b 3 } { c 9 } } }
+ {
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ }
+ }
+] [
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ }
+ { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
+ [ but-last-slice ] map split-by-slots [ >array ] map
+] unit-test
+
+: split-test ( seq -- seq' )
+ { { a>> } { b>> } } split-by-slots ;
+
+[ split-test ] must-infer
+
+[ { } ]
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+
+[
+ {
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+ }
+] [
+ {
+ T{ sort-test f 6 f f T{ tuple2 f 1 } }
+ T{ sort-test f 5 f f T{ tuple2 f 4 } }
+ T{ sort-test f 6 f f T{ tuple2 f 3 } }
+ T{ sort-test f 6 f f T{ tuple2 f 3 } }
+ T{ sort-test f 5 f f T{ tuple2 f 3 } }
+ T{ sort-test f 6 f f T{ tuple2 f 2 } }
+ } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
+] unit-test
+
+[
+ {
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 1 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 2 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 5 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ T{ sort-test
+ { a 6 }
+ { tuple2 T{ tuple2 { d 3 } } }
+ }
+ }
+ {
+ T{ sort-test
+ { a 5 }
+ { tuple2 T{ tuple2 { d 4 } } }
+ }
+ }
+ }
+] [
+ {
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+ T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+ } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit fry kernel macros math.order
+sequences words sorting sequences.deep assocs splitting.monotonic
+math ;
+IN: sorting.slots
+
+<PRIVATE
+
+: slot-comparator ( seq -- quot )
+ [
+ but-last-slice
+ [ '[ [ _ execute ] bi@ ] ] map concat
+ ] [
+ peek
+ '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+ ] bi ;
+
+PRIVATE>
+
+MACRO: compare-slots ( sort-specs -- <=> )
+ #! sort-spec: { accessors comparator }
+ [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by-slots ( seq sort-specs -- seq' )
+ '[ _ compare-slots ] sort ;
+
+MACRO: split-by-slots ( accessor-seqs -- quot )
+ [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
+ '[ [ _ 2&& ] slice monotonic-slice ] ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences grouping assocs kernel ascii unicode.case tr ;
+USING: sequences grouping assocs kernel ascii ascii tr ;
IN: soundex
TR: soundex-tr
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations classes sequences
+multiline ;
+IN: splitting.monotonic
+
+HELP: monotonic-slice
+{ $values
+ { "seq" sequence } { "quot" quotation } { "class" class }
+ { "slices" "a sequence of slices" }
+}
+{ $description "Monotonically splits a sequence into slices of the type " { $snippet "class" } "." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
+ <" {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 2 3 4 } }
+ }
+ T{ upward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 2 3 4 } }
+ }
+}">
+ }
+} ;
+
+HELP: monotonic-split
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" "a sequence of sequences" }
+}
+{ $description "Compares pairs of elements in a sequence and collects elements into sequences while they satisfy the predicate. Once the predicate fails, a new sequence is started, and all sequences are returned in a single sequence." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 2 3 4 } [ < ] monotonic-split ."
+ "{ V{ 1 2 3 } V{ 2 3 4 } }"
+ }
+} ;
+
+HELP: downward-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of downward-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: stable-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of stable-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: upward-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of upward-slices" }
+}
+{ $description "Returns an array of monotonically increasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: trends
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of downward, stable, and upward slices" }
+}
+{ $description "Returns a sorted sequence of downward, stable, or upward slices. The endpoints of some slices may overlap with each other." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 3 2 1 } trends ."
+ <" {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ stable-slice
+ { from 2 }
+ { to 4 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ downward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+}">
+ }
+} ;
+
+ARTICLE: "splitting.monotonic" "Splitting trending sequences"
+"The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl
+"Splitting into sequences:"
+{ $subsection monotonic-split }
+"Splitting into slices:"
+{ $subsection monotonic-slice }
+"Trending:"
+{ $subsection downward-slices }
+{ $subsection stable-slices }
+{ $subsection upward-slices }
+{ $subsection trends } ;
+
+ABOUT: "splitting.monotonic"
[ { { 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
+[ { } ]
+[ { } [ = ] slice monotonic-slice ] unit-test
+
+[ t ]
+[ { 1 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 } } ]
+[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ { 1 } [ = ] slice monotonic-slice ] must-infer
+
+[ t ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 1 1 } { 2 2 } { 3 3 } { 4 } } ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ { { 3 3 } } ]
+[ { 3 3 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[
+ {
+ T{ upward-slice { from 0 } { to 3 } { seq { 1 2 3 2 1 } } }
+ T{ downward-slice { from 2 } { to 5 } { seq { 1 2 3 2 1 } } }
+ }
+]
+[ { 1 2 3 2 1 } trends ] unit-test
+
+[
+ {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ stable-slice
+ { from 2 }
+ { to 4 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ downward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ }
+] [ { 1 2 3 3 2 1 } trends ] unit-test
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: make namespaces sequences kernel fry ;
+USING: make namespaces sequences kernel fry arrays compiler.utilities
+math accessors circular grouping combinators sorting math.order ;
IN: splitting.monotonic
+<PRIVATE
+
: ,, ( obj -- ) building get peek push ;
: v, ( -- ) V{ } clone , ;
: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
v, '[ over ,, @ [ v, ] unless ] 2each ,v
] { } make ; inline
+PRIVATE>
+
: monotonic-split ( seq quot -- newseq )
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
+
+<PRIVATE
+
+: (monotonic-slice) ( seq quot class -- slices )
+ [
+ dupd '[
+ [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+ [ @ not [ , ] [ drop ] if ] 3each
+ ] { } make
+ dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+ swap
+ ] dip
+ '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
+
+PRIVATE>
+
+: monotonic-slice ( seq quot class -- slices )
+ pick length {
+ { 0 [ 2drop ] }
+ { 1 [ nip [ 0 1 rot ] dip boa 1array ] }
+ [ drop (monotonic-slice) ]
+ } case ; inline
+
+TUPLE: downward-slice < slice ;
+TUPLE: stable-slice < slice ;
+TUPLE: upward-slice < slice ;
+
+: downward-slices ( seq -- slices )
+ [ > ] downward-slice monotonic-slice [ length 1 > ] filter ;
+
+: stable-slices ( seq -- slices )
+ [ = ] stable-slice monotonic-slice [ length 1 > ] filter ;
+
+: upward-slices ( seq -- slices )
+ [ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
+
+: trends ( seq -- slices )
+ dup length {
+ { 0 [ ] }
+ { 1 [ [ 0 1 ] dip stable-slice boa ] }
+ [
+ drop
+ [ downward-slices ]
+ [ stable-slices ]
+ [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+ ]
+ } case ;
\ stream-write must-infer
\ stream-write1 must-infer
\ stream-nl must-infer
-\ stream-format must-infer
-\ stream-write-table must-infer
\ stream-flush must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
! Test stream utilities
\ lines must-infer
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays cocoa.messages cocoa.runtime combinators
-prettyprint ;
+prettyprint combinators.smart ;
IN: tools.cocoa
: method. ( method -- )
- {
- [ method_getName sel_getName ]
- [ method-return-type ]
- [ method-arg-types ]
- [ method_getImplementation ]
- } cleave 4array . ;
+ [
+ {
+ [ method_getName sel_getName ]
+ [ method-return-type ]
+ [ method-arg-types ]
+ [ method_getImplementation ]
+ } cleave
+ ] output>array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;
io.files.temp kernel tools.deploy.config\r
tools.deploy.config.editor tools.deploy.backend math sequences\r
io.launcher arrays namespaces continuations layouts accessors\r
-io.encodings.ascii urls math.parser io.directories ;\r
-\r
-: shake-and-bake ( vocab -- )\r
- [ "test.image" temp-file delete-file ] ignore-errors\r
- "resource:" [\r
- [ vm "test.image" temp-file ] dip\r
- dup deploy-config make-deploy-image\r
- ] with-directory ;\r
-\r
-: small-enough? ( n -- ? )\r
- [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;\r
+io.encodings.ascii urls math.parser io.directories\r
+tools.deploy.test ;\r
\r
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
\r
[ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
] when\r
\r
-: run-temp-image ( -- )\r
- vm\r
- "-i=" "test.image" temp-file append\r
- 2array try-process ;\r
-\r
{\r
"tools.deploy.test.1"\r
"tools.deploy.test.2"\r
"tools.deploy.test.9" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.10" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test tools.deploy.test.10 ;
+IN: tools.deploy.test.10.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: prettyprint ;
+IN: tools.deploy.test.10
+
+: main ( -- ) C{ 0 1 } pprint ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-reflection 3 }
+ { deploy-unicode? f }
+ { deploy-io 2 }
+ { deploy-word-props? f }
+ { deploy-compiler? f }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-ui? f }
+ { deploy-math? t }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.10" }
+}
--- /dev/null
+USING: accessors arrays continuations io.directories io.files.info
+io.files.temp io.launcher kernel layouts math sequences system
+tools.deploy.backend tools.deploy.config.editor ;
+IN: tools.deploy.test
+
+: shake-and-bake ( vocab -- )
+ [ "test.image" temp-file delete-file ] ignore-errors
+ "resource:" [
+ [ vm "test.image" temp-file ] dip
+ dup deploy-config make-deploy-image
+ ] with-directory ;
+
+: small-enough? ( n -- ? )
+ [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
+
+: run-temp-image ( -- )
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process ;
\ No newline at end of file
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.files strings kernel ;
IN: tools.files.tests
-\ directory. must-infer
-
[ ] [ "" directory. ] unit-test
[ ] [ file-systems. ] unit-test
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io io.files io.files.info
-io.directories kernel math.parser sequences system vocabs.loader
-calendar math fry prettyprint ;
+USING: accessors arrays calendar combinators fry io io.directories
+io.files.info kernel math math.parser prettyprint sequences system
+vocabs.loader sorting.slots calendar.format ;
IN: tools.files
<PRIVATE
-: ls-time ( timestamp -- string )
+: dir-or-size ( file-info -- str )
+ dup directory? [
+ drop "<DIR>" 20 CHAR: \s pad-right
+ ] [
+ size>> number>string 20 CHAR: \s pad-left
+ ] if ;
+
+: listing-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
-: ls-timestamp ( timestamp -- string )
+: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ]
[
dup year>> dup now year>> =
- [ drop ls-time ] [ nip number>string ] if
+ [ drop listing-time ] [ nip number>string ] if
5 CHAR: \s pad-left
] tri 3array " " join ;
: execute>string ( ? -- string ) "x" "-" ? ; inline
-HOOK: (directory.) os ( path -- lines )
-
PRIVATE>
-: directory. ( path -- )
- [ (directory.) ] with-directory-files [ print ] each ;
+SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
+file-date file-time file-datetime uid gid user group link-target unix-datetime
+directory-or-size ;
+
+TUPLE: listing-tool path specs sort ;
+
+TUPLE: file-listing directory-entry file-info ;
+
+C: <file-listing> file-listing
+
+: <listing-tool> ( path -- listing-tool )
+ listing-tool new
+ swap >>path
+ { file-name } >>specs ;
+
+: list-slow? ( listing-tool -- ? )
+ specs>> { file-name } sequence= not ;
+
+ERROR: unknown-file-spec symbol ;
+
+HOOK: file-spec>string os ( file-listing spec -- string )
+
+M: object file-spec>string ( file-listing spec -- string )
+ {
+ { file-name [ directory-entry>> name>> ] }
+ { directory-or-size [ file-info>> dir-or-size ] }
+ { file-size [ file-info>> size>> number>string ] }
+ { file-date [ file-info>> modified>> listing-date ] }
+ { file-time [ file-info>> modified>> listing-time ] }
+ { file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
+ [ unknown-file-spec ]
+ } case ;
+
+: list-files-fast ( listing-tool -- array )
+ path>> [ [ name>> 1array ] map ] with-directory-entries ; inline
+
+: list-files-slow ( listing-tool -- array )
+ [ path>> ] [ sort>> ] [ specs>> ] tri '[
+ [ dup name>> file-info file-listing boa ] map
+ _ [ sort-by-slots ] when*
+ [ _ [ file-spec>string ] with map ] map
+ ] with-directory-entries ; inline
+
+: list-files ( listing-tool -- array )
+ dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
+
+HOOK: (directory.) os ( path -- lines )
+
+: directory. ( path -- ) (directory.) simple-table. ;
SYMBOLS: device-name mount-point type
available-space free-space used-space total-space
: file-system-spec ( file-system-info obj -- str )
{
- { device-name [ device-name>> [ "" ] unless* ] }
- { mount-point [ mount-point>> [ "" ] unless* ] }
- { type [ type>> [ "" ] unless* ] }
- { available-space [ available-space>> [ 0 ] unless* ] }
- { free-space [ free-space>> [ 0 ] unless* ] }
- { used-space [ used-space>> [ 0 ] unless* ] }
- { total-space [ total-space>> [ 0 ] unless* ] }
+ { device-name [ device-name>> "" or ] }
+ { mount-point [ mount-point>> "" or ] }
+ { type [ type>> "" or ] }
+ { available-space [ available-space>> 0 or ] }
+ { free-space [ free-space>> 0 or ] }
+ { used-space [ used-space>> 0 or ] }
+ { total-space [ total-space>> 0 or ] }
{ percent-used [
[ used-space>> ] [ total-space>> ] bi
- [ [ 0 ] unless* ] bi@ dup 0 =
+ [ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if
] }
} case ;
[ [ unparse ] map ] bi prefix simple-table. ;
: file-systems. ( -- )
- { device-name free-space used-space total-space percent-used mount-point }
- print-file-systems ;
+ {
+ device-name available-space free-space used-space
+ total-space percent-used mount-point
+ } print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case io.files
-io.files.info io.files.info.unix tools.files generalizations
+io.files.info io.files.info.unix generalizations
strings arrays sequences math.parser unix.groups unix.users
-tools.files.private unix.stat math ;
+tools.files.private unix.stat math fry macros combinators.smart
+io.files.info.unix io tools.files math.order prettyprint ;
IN: tools.files.unix
<PRIVATE
} case ;
: permissions-string ( permissions -- str )
- {
- [ type>> file-type>ch 1string ]
- [ user-read? read>string ]
- [ user-write? write>string ]
- [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
- [ group-read? read>string ]
- [ group-write? write>string ]
- [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
- [ other-read? read>string ]
- [ other-write? write>string ]
- [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
- } cleave 10 narray concat ;
+ [
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
+ } cleave
+ ] output>array concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
} cond ;
M: unix (directory.) ( path -- lines )
- [ [
- [
- dup file-info
- {
- [ permissions-string ]
- [ nlink>> number>string 3 CHAR: \s pad-left ]
- ! [ uid>> ]
- ! [ gid>> ]
- [ size>> number>string 15 CHAR: \s pad-left ]
- [ modified>> ls-timestamp ]
- } cleave 4 narray swap suffix " " join
- ] map
- ] with-group-cache ] with-user-cache ;
+ <listing-tool>
+ { permissions nlinks user group file-size file-date file-name } >>specs
+ { { directory-entry>> name>> <=> } } >>sort
+ [ [ list-files ] with-group-cache ] with-user-cache ;
+
+M: unix file-spec>string ( file-listing spec -- string )
+ {
+ { file-name/type [
+ directory-entry>> [ name>> ] [ file-type>trailing ] bi append
+ ] }
+ { permissions [ file-info>> permissions-string ] }
+ { nlinks [ file-info>> nlink>> number>string ] }
+ { user [ file-info>> uid>> user-name ] }
+ { group [ file-info>> gid>> group-name ] }
+ { uid [ file-info>> uid>> number>string ] }
+ { gid [ file-info>> gid>> number>string ] }
+ [ call-next-method ]
+ } case ;
PRIVATE>
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system tools.files
-generalizations tools.files.private io.files.info ;
+generalizations tools.files.private io.files.info math.order ;
IN: tools.files.windows
<PRIVATE
-: directory-or-size ( file-info -- str )
- dup directory? [
- drop "<DIR>" 20 CHAR: \s pad-right
- ] [
- size>> number>string 20 CHAR: \s pad-left
- ] if ;
-
M: windows (directory.) ( entries -- lines )
- [
- dup file-info {
- [ modified>> timestamp>ymdhms ]
- [ directory-or-size ]
- } cleave 2 narray swap suffix " " join
- ] map ;
+ <listing-tool>
+ { file-datetime directory-or-size file-name } >>specs
+ { { directory-entry>> name>> <=> } } >>sort
+ list-files ;
PRIVATE>
HELP: scaffold-vocab
{ $values
{ "vocab-root" "a vocabulary root string" } { "string" string } }
-{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
HELP: using
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
IN: tr.tests
-USING: tr tools.test unicode.case ;
+USING: tr tools.test ascii ;
TR: tr-test ch>upper "ABC" "XYZ" ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays strings sequences sequences.private
+USING: byte-arrays strings sequences sequences.private ascii
fry kernel words parser lexer assocs math math.order summary ;
IN: tr
<PRIVATE
-: ascii? ( ch -- ? ) 0 127 between? ; inline
-
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
: check-tr ( from to -- )
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types
-specialized-arrays.float fry ;
+specialized-arrays.float fry combinators.smart ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
<PRIVATE
: checkmark-points ( dim -- points )
- {
- [ { 0 0 } v* { 0.5 0.5 } v+ ]
- [ { 1 1 } v* { 0.5 0.5 } v+ ]
- [ { 1 0 } v* { -0.3 0.5 } v+ ]
- [ { 0 1 } v* { -0.3 0.5 } v+ ]
- } cleave 4array ;
+ [
+ {
+ [ { 0 0 } v* { 0.5 0.5 } v+ ]
+ [ { 1 1 } v* { 0.5 0.5 } v+ ]
+ [ { 1 0 } v* { -0.3 0.5 } v+ ]
+ [ { 0 1 } v* { -0.3 0.5 } v+ ]
+ } cleave
+ ] output>array ;
: checkmark-vertices ( dim -- vertices )
checkmark-points concat >float-array ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
-io.streams.string math.vectors ui.gadgets columns accessors
+io.styles math.vectors ui.gadgets columns accessors
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math namespaces
make opengl sequences strings splitting ui.gadgets
text>> dup string? [ "\n" join ] unless ; inline
: set-label-string ( string label -- )
- CHAR: \n pick memq? [
- [ string-lines ] dip (>>text)
- ] [
- (>>text)
- ] if ; inline
+ [ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
: label-theme ( gadget -- gadget )
sans-serif-font >>font
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors sorting
-splitting io.streams.nested assocs ui.gadgets.presentations
+splitting assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect fry ;
"v" get [
[ { 10 20 } ] [ "v" get model>> range-value ] unit-test
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+ [ { 10 20 } ] [ "g" get rect-loc vneg viewport-gap v+ scroller-border v+ ] unit-test
] with-grafted-gadget
[ ] [
"s" get [
[ { 34 34 } ] [ "s" get viewport>> rect-dim ] unit-test
- [ { 106 106 } ] [ "s" get viewport>> viewport-dim ] unit-test
+ [ { 107 107 } ] [ "s" get viewport>> viewport-dim ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
- [ { 106 106 } ] [ "s" get model>> range-max-value ] unit-test
+ [ { 107 107 } ] [ "s" get model>> range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
[ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+ [ { 10 20 } ] [ "g" get rect-loc vneg viewport-gap v+ scroller-border v+ ] unit-test
] with-grafted-gadget
<gadget> { 600 400 } >>dim "g1" set
swap dup quot>> call
dup layout
model>> dependencies>> [ range-max value>> ] map
- viewport-gap 2 v*n =
+ viewport-padding =
] unit-test
\ <scroller> must-infer
new-frame
t >>root?
<scroller-model> >>model
- faint-boundary
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+ dup model>> dependencies>>
+ [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
+ [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
- tuck model>> <viewport> >>viewport
- dup viewport>> @center grid-add ; inline
+ tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
+
+ faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
+kernel math namespaces sequences models math.vectors
+math.geometry.rect ;
+IN: ui.gadgets.viewports
-: viewport-gap { 3 3 } ; inline
+CONSTANT: viewport-gap { 3 3 }
+CONSTANT: scroller-border { 1 1 }
TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ;
+: viewport-padding ( -- padding )
+ viewport-gap 2 v*n scroller-border v+ ;
+
: viewport-dim ( viewport -- dim )
- gadget-child pref-dim viewport-gap 2 v*n v+ ;
+ gadget-child pref-dim viewport-padding v+ ;
: <viewport> ( content model -- viewport )
viewport new-gadget
swap add-gadget ;
M: viewport layout*
- [
- [ rect-dim viewport-gap 2 v*n v- ]
+ [ gadget-child ] [
+ [ dim>> viewport-padding v- ]
[ gadget-child pref-dim ]
bi vmax
- ] [ gadget-child ] bi (>>dim) ;
+ ] bi >>dim drop ;
M: viewport focusable-child*
gadget-child ;
M: viewport model-changed
nip
- dup relayout-1
- dup scroller-value
- vneg viewport-gap v+
- swap gadget-child (>>loc) ;
+ [ relayout-1 ]
+ [
+ [ gadget-child ]
+ [
+ scroller-value vneg
+ viewport-gap v+
+ scroller-border v+
+ ] bi
+ >>loc drop
+ ] bi ;
: visible-dim ( gadget -- dim )
dup parent>> viewport?
- [ parent>> rect-dim viewport-gap 2 v*n v- ]
- [ rect-dim ]
- if ;
+ [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs
arrays namespaces make math.ranges unicode.normalize.private values
-io.encodings.ascii unicode.syntax unicode.data compiler.units
+io.encodings.ascii unicode.syntax unicode.data compiler.units fry
alien.syntax sets accessors interval-maps memoize locals words ;
IN: unicode.breaks
: finish-table ( -- table )
table get [ [ 1 = ] map ] map ;
-: set-table ( class1 class2 val -- )
+: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
+
+: (set-table) ( class1 class2 val -- )
-rot table get nth [ swap or ] change-nth ;
+: set-table ( classes1 classes2 val -- )
+ [ [ eval-seq ] bi@ ] dip
+ [ [ (set-table) ] curry with each ] 2curry each ;
+
: connect ( class1 class2 -- ) 1 set-table ;
: disconnect ( class1 class2 -- ) 0 set-table ;
-
-: check-before ( class classes value -- )
- [ set-table ] curry with each ;
-
-: check-after ( classes class value -- )
- [ set-table ] 2curry each ;
-
-: connect-before ( class classes -- )
- 1 check-before ;
-
-: connect-after ( classes class -- )
- 1 check-after ;
: break-around ( classes1 classes2 -- )
- [ [ 2dup disconnect swap disconnect ] with each ] curry each ;
+ [ disconnect ] [ swap disconnect ] 2bi ;
: make-grapheme-table ( -- )
- CR LF connect
- Control CR LF 3array graphemes break-around
- L L V LV LVT 4array connect-before
- V V T 2array connect-before
- LV V T 2array connect-before
- T T connect
- LVT T connect
- graphemes Extend connect-after
- graphemes SpacingMark connect-after
- Prepend graphemes connect-before ;
+ { CR } { LF } connect
+ { Control CR LF } graphemes disconnect
+ graphemes { Control CR LF } disconnect
+ { L } { L V LV LVT } connect
+ { LV V } { V T } connect
+ { LVT T } { T } connect
+ graphemes { Extend } connect
+ graphemes { SpacingMark } connect
+ { Prepend } graphemes connect ;
VALUE: grapheme-table
: chars ( i str n -- str[i] str[i+n] )
swap [ dupd + ] dip [ ?nth ] curry bi@ ;
-: find-index ( seq quot -- i ) find drop ; inline
-: find-last-index ( seq quot -- i ) find-last drop ; inline
-
PRIVATE>
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
- [ grapheme-class tuck grapheme-break? ] find-index
+ [ grapheme-class tuck grapheme-break? ] find drop
nip swap length or 1+ ;
<PRIVATE
-:: (>pieces) ( str quot -- )
- str [
- dup quot call cut-slice
- swap , quot (>pieces)
- ] unless-empty ; inline recursive
-
-: >pieces ( str quot -- graphemes )
- [ (>pieces) ] { } make ; inline
+: >pieces ( str quot: ( str -- i ) -- graphemes )
+ [ dup empty? not ] swap '[ dup @ cut-slice swap ]
+ [ ] produce nip ; inline
PRIVATE>
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
+ [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
<PRIVATE
word-break-table interval-at
word-break-classes at [ wOther ] unless* ;
-: e ( seq -- seq ) [ execute ] map ;
-
SYMBOL: check-letter-before
SYMBOL: check-letter-after
SYMBOL: check-number-before
SYMBOL: check-number-after
: make-word-table ( -- )
- wCR wLF connect
- { wNewline wCR wLF } e words break-around
- wALetter dup connect
- wALetter { wMidLetter wMidNumLet } e check-letter-after check-before
- { wMidLetter wMidNumLet } e wALetter check-letter-before check-after
- wNumeric dup connect
- wALetter wNumeric connect
- wNumeric wALetter connect
- wNumeric { wMidNum wMidNumLet } e check-number-after check-before
- { wMidNum wMidNumLet } e wNumeric check-number-before check-after
- wKatakana dup connect
- { wALetter wNumeric wKatakana wExtendNumLet } e wExtendNumLet
- [ connect-after ] [ swap connect-before ] 2bi ;
+ { wCR } { wLF } connect
+ { wNewline wCR wLF } words disconnect
+ words { wNewline wCR wLF } disconnect
+ { wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
+ { wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
+ { wNumeric wALetter } { wNumeric wALetter } connect
+ { wNumeric } { wMidNum wMidNumLet } check-number-after set-table
+ { wMidNum wMidNumLet } { wNumeric } check-number-before set-table
+ { wKatakana } { wKatakana } connect
+ { wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
+ [ connect ] [ swap connect ] 2bi ;
VALUE: word-table
: word-table-nth ( class1 class2 -- ? )
word-table nth nth ;
-: property-not= ( i str property -- ? )
- pick [
- [ ?nth ] dip swap
- [ word-break-prop = not ] [ drop f ] if*
- ] [ 3drop t ] if ;
+:: property-not= ( str i property -- ? )
+ i [
+ i str ?nth [ word-break-prop property = not ]
+ [ f ] if*
+ ] [ t ] if ;
: format/extended? ( ch -- ? )
word-break-prop { 4 5 } member? ;
-:: walk-up ( str i -- j )
- i 1 + str [ format/extended? not ] find-from drop
- 1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
+: (walk-up) ( str i -- j )
+ swap [ format/extended? not ] find-from drop ;
+
+: walk-up ( str i -- j )
+ dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
+
+: (walk-down) ( str i -- j )
+ swap [ format/extended? not ] find-last-from drop ;
-:: walk-down ( str i -- j )
- i str [ format/extended? not ] find-last-from drop
- 1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
+: walk-down ( str i -- j )
+ dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
-:: word-break? ( table-entry i str -- ? )
- table-entry {
- { t [ f ] }
- { f [ t ] }
+: word-break? ( table-entry i str -- ? )
+ spin {
+ { t [ 2drop f ] }
+ { f [ 2drop t ] }
{ check-letter-after
- [ str i walk-up str wALetter property-not= ] }
+ [ dupd walk-up wALetter property-not= ] }
{ check-letter-before
- [ str i walk-down str wALetter property-not= ] }
+ [ dupd walk-down wALetter property-not= ] }
{ check-number-after
- [ str i walk-up str wNumeric property-not= ] }
+ [ dupd walk-up wNumeric property-not= ] }
{ check-number-before
- [ str i walk-down str wNumeric property-not= ] }
+ [ dupd walk-down wNumeric property-not= ] }
} case ;
:: word-break-next ( old-class new-char i str -- next-class ? )
- new-char word-break-prop dup { 4 5 } member?
- [ drop old-class dup { 1 2 3 } member? ]
- [ old-class over word-table-nth i str word-break? ] if ;
+ new-char dup format/extended?
+ [ drop old-class dup { 1 2 3 } member? ] [
+ word-break-prop old-class over word-table-nth
+ i str word-break?
+ ] if ;
PRIVATE>
-:: first-word ( str -- i )
- str unclip-slice word-break-prop over <enum>
- [ swap str word-break-next ] assoc-find 2drop
+: first-word ( str -- i )
+ [ unclip-slice word-break-prop over <enum> ] keep
+ '[ swap _ word-break-next ] assoc-find 2drop
nip swap length or 1+ ;
: >words ( str -- words )
{ $subsection >lower }
{ $subsection >title }
{ $subsection >case-fold }
-"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one."
-{ $subsection ch>upper }
-{ $subsection ch>lower }
-{ $subsection ch>title }
"To test if a string is in a given case:"
{ $subsection upper? }
{ $subsection lower? }
{ $description "Converts a string to title case." } ;
HELP: >case-fold
-{ $values { "string" string } { "case-fold" string } }
+{ $values { "string" string } { "fold" string } }
{ $description "Converts a string to case-folded form." } ;
HELP: upper?
HELP: case-fold?
{ $values { "string" string } { "?" "a boolean" } }
{ $description "Tests if a string is in case-folded form." } ;
-
-HELP: ch>lower
-{ $values { "ch" "a code point" } { "lower" "a code point" } }
-{ $description "Converts a code point to lower case." }
-{ $warning "Don't use this unless you know what you're doing! " { $code ">lower" } " is not the same as " { $code "[ ch>lower ] map" } "." } ;
-
-HELP: ch>upper
-{ $values { "ch" "a code point" } { "upper" "a code point" } }
-{ $description "Converts a code point to upper case." }
-{ $warning "Don't use this unless you know what you're doing! " { $code ">upper" } " is not the same as " { $code "[ ch>upper ] map" } "." } ;
-
-HELP: ch>title
-{ $values { "ch" "a code point" } { "title" "a code point" } }
-{ $description "Converts a code point to title case." }
-{ $warning "Don't use this unless you know what you're doing! " { $code ">title" } " is not the same as " { $code "[ ch>title ] map" } "." } ;
\ >lower must-infer
\ >title must-infer
-[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
+[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
-[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
+[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test
[
"tr" locale set
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
-! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
+ [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set
! Lithuanian casing tests
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.data sequences sequences.next namespaces make
-unicode.normalize math unicode.categories combinators
-assocs strings splitting kernel accessors ;
+USING: unicode.data sequences sequences.next namespaces
+sbufs make unicode.syntax unicode.normalize math hints
+unicode.categories combinators unicode.syntax assocs
+strings splitting kernel accessors unicode.breaks fry locals ;
+QUALIFIED: ascii
IN: unicode.case
<PRIVATE
-: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
-PRIVATE>
+: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
-: ch>lower ( ch -- lower ) simple-lower at-default ;
-: ch>upper ( ch -- upper ) simple-upper at-default ;
-: ch>title ( ch -- title ) simple-title at-default ;
+: ch>lower ( ch -- lower ) simple-lower at-default ; inline
+: ch>upper ( ch -- upper ) simple-upper at-default ; inline
+: ch>title ( ch -- title ) simple-title at-default ; inline
+PRIVATE>
SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE
+
+: split-subseq ( string sep -- strings )
+ [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
+
+: replace ( old new str -- newstr )
+ [ split-subseq ] dip join ; inline
+
: i-dot? ( -- ? )
locale get { "tr" "az" } member? ;
: dot-over ( -- ch ) HEX: 307 ;
-: lithuanian-ch>upper ( ? next ch -- ? )
- rot [ 2drop f ]
- [ swap dot-over = over "ij" member? and swap , ] if ;
-
: lithuanian>upper ( string -- lower )
- [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
+ "i\u000307" "i" replace
+ "j\u000307" "j" replace ;
: mark-above? ( ch -- ? )
combining-class 230 = ;
-: lithuanian-ch>lower ( next ch -- )
- ! This fails to add a dot above in certain edge cases
- ! where there is a non-above combining mark before an above one
- ! in Lithuanian
- dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
+: with-rest ( seq quot: ( seq -- seq ) -- seq )
+ [ unclip ] dip swap slip prefix ; inline
-: lithuanian>lower ( string -- lower )
- [ [ lithuanian-ch>lower ] each-next ] "" make ;
+: add-dots ( seq -- seq )
+ [ [ "" ] [
+ dup first mark-above?
+ [ CHAR: combining-dot-above prefix ] when
+ ] if-empty ] with-rest ; inline
-: turk-ch>upper ( ch -- )
- dup CHAR: i =
- [ drop CHAR: I , dot-over , ] [ , ] if ;
+: lithuanian>lower ( string -- lower )
+ "i" split add-dots "i" join
+ "j" split add-dots "i" join ; inline
: turk>upper ( string -- upper-i )
- [ [ turk-ch>upper ] each ] "" make ;
-
-: turk-ch>lower ( ? next ch -- ? )
- {
- { [ rot ] [ 2drop f ] }
- { [ dup CHAR: I = ] [
- drop dot-over =
- dup CHAR: i HEX: 131 ? ,
- ] }
- [ , drop f ]
- } cond ;
+ "i" "I\u000307" replace ; inline
: turk>lower ( string -- lower-i )
- [ f swap [ turk-ch>lower ] each-next drop ] "" make ;
+ "I\u000307" "i" replace
+ "I" "\u000131" replace ; inline
-: word-boundary ( prev char -- new ? )
- dup non-starter? [ drop dup ] when
- swap uncased? ;
+: fix-sigma-end ( string -- string )
+ [ "" ] [
+ dup peek CHAR: greek-small-letter-sigma =
+ [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
+ ] if-empty ; inline
: sigma-map ( string -- string )
- [
- swap [ uncased? ] keep not or
- [ drop HEX: 3C2 ] when
- ] map-next ;
+ { CHAR: greek-capital-letter-sigma } split [ [
+ [ { CHAR: greek-small-letter-sigma } ] [
+ dup first uncased?
+ CHAR: greek-small-letter-final-sigma
+ CHAR: greek-small-letter-sigma ? prefix
+ ] if-empty
+ ] map ] with-rest concat fix-sigma-end ; inline
: final-sigma ( string -- string )
- HEX: 3A3 over member? [ sigma-map ] when ;
-
-: map-case ( string string-quot char-quot -- case )
- [
- [
- [ dup special-casing at ] 2dip
- [ [ % ] compose ] [ [ , ] compose ] bi* ?if
- ] 2curry each
- ] "" make ; inline
+ CHAR: greek-capital-letter-sigma
+ over member? [ sigma-map ] when
+ "" like ; inline
+
+:: map-case ( string string-quot char-quot -- case )
+ string length <sbuf> :> out
+ string [
+ dup special-casing at
+ [ string-quot call out push-all ]
+ [ char-quot call out push ] ?if
+ ] each out "" like ; inline
+
PRIVATE>
+
: >lower ( string -- lower )
- i-dot? [ turk>lower ] when
- final-sigma [ lower>> ] [ ch>lower ] map-case ;
+ i-dot? [ turk>lower ] when final-sigma
+ [ lower>> ] [ ch>lower ] map-case ;
+
+HINTS: >lower string ;
: >upper ( string -- upper )
i-dot? [ turk>upper ] when
[ upper>> ] [ ch>upper ] map-case ;
+HINTS: >upper string ;
+
+<PRIVATE
+
+: (>title) ( string -- title )
+ i-dot? [ turk>upper ] when
+ [ title>> ] [ ch>title ] map-case ; inline
+
+: title-word ( string -- title )
+ unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
+
+PRIVATE>
+
: >title ( string -- title )
- final-sigma
- CHAR: \s swap
- [ tuck word-boundary swapd
- [ title>> ] [ lower>> ] if ]
- [ tuck word-boundary swapd
- [ ch>title ] [ ch>lower ] if ]
- map-case nip ;
+ final-sigma >words [ title-word ] map concat ;
+
+HINTS: >title string ;
: >case-fold ( string -- fold )
>upper >lower ;
USING: help.markup help.syntax kernel ;
IN: unicode.categories
-HELP: LETTER?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is an upper-cased letter" } ;
+HELP: LETTER
+{ $class-description "The class of upper cased letters" } ;
-HELP: Letter?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is a letter of any case" } ;
+HELP: Letter
+{ $class-description "The class of letters" } ;
-HELP: alpha?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is alphanumeric" } ;
+HELP: alpha
+{ $class-description "The class of code points which are alphanumeric" } ;
-HELP: blank?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is whitespace" } ;
+HELP: blank
+{ $class-description "The class of code points which are whitespace" } ;
-HELP: character?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a number is a code point which has been assigned" } ;
+HELP: character
+{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
-HELP: control?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a control character" } ;
+HELP: control
+{ $class-description "The class of control characters" } ;
-HELP: digit?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a digit" } ;
+HELP: digit
+{ $class-description "The class of code coints which are digits" } ;
-HELP: letter?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a lower-cased letter" } ;
+HELP: letter
+{ $class-description "The class of code points which are lower-cased letters" } ;
-HELP: printable?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is printable, as opposed to being a control character or formatting character" } ;
+HELP: printable
+{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
-HELP: uncased?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a character has a case" } ;
+HELP: uncased
+{ $class-description "The class of letters which don't have a case" } ;
ARTICLE: "unicode.categories" "Character classes"
-{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ASCII" "ascii" } " equivalents in most cases. Below are links to the useful predicates, but note that each of these is defined to be a predicate class."
-{ $subsection blank? }
-{ $subsection letter? }
-{ $subsection LETTER? }
-{ $subsection Letter? }
-{ $subsection digit? }
-{ $subsection printable? }
-{ $subsection alpha? }
-{ $subsection control? }
-{ $subsection uncased? }
-{ $subsection character? } ;
+{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
+{ $subsection blank }
+{ $subsection letter }
+{ $subsection LETTER }
+{ $subsection Letter }
+{ $subsection digit }
+{ $subsection printable }
+{ $subsection alpha }
+{ $subsection control }
+{ $subsection uncased }
+{ $subsection character } ;
ABOUT: "unicode.categories"
USING: io io.files splitting grouping unicode.collation\r
sequences kernel io.encodings.utf8 math.parser math.order\r
-tools.test assocs io.streams.null words ;\r
+tools.test assocs words ;\r
IN: unicode.collation.tests\r
\r
: parse-test ( -- strings )\r
unit-test\r
\r
parse-test 2 <clumps>\r
-[ [ test-two ] assoc-each ] with-null-writer\r
+[ test-two ] assoc-each\r
ascii io assocs strings math namespaces make sorting combinators\r
math.order arrays unicode.normalize unicode.data locals\r
unicode.syntax macros sequences.deep words unicode.breaks\r
-quotations ;\r
+quotations combinators.short-circuit ;\r
IN: unicode.collation\r
\r
<PRIVATE\r
building get empty? [ 0 ] [ building get peek peek ] if ;\r
\r
: blocked? ( char -- ? )\r
- combining-class [\r
- last combining-class =\r
- ] [ last combining-class ] if* ;\r
+ combining-class dup { 0 f } member?\r
+ [ drop last non-starter? ]\r
+ [ last combining-class = ] if ;\r
\r
: possible-bases ( -- slice-of-building )\r
- building get dup [ first combining-class not ] find-last\r
+ building get dup [ first non-starter? not ] find-last\r
drop [ 0 ] unless* tail-slice ;\r
\r
:: ?combine ( char slice i -- ? )\r
{ $subsection property? } ;
HELP: load-script
-{ $value { "filename" string } { "table" "an interval map" } }
+{ $values { "filename" string } { "table" "an interval map" } }
{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
HELP: canonical-entry
-{ $value { "char" "a code point" } { "seq" string } }
+{ $values { "char" "a code point" } { "seq" string } }
{ $description "Finds the canonical decomposition (NFD) for a code point" } ;
HELP: combine-chars
-{ $value { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
+{ $values { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
{ $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ;
HELP: compatibility-entry
-{ $value { "char" "a code point" } { "seq" string } }
+{ $values { "char" "a code point" } { "seq" string } }
{ $description "This returns the compatibility decomposition (NFKD) for a code point" } ;
HELP: combining-class
-{ $value { "char" "a code point" } { "n" "an integer" } }
+{ $values { "char" "a code point" } { "n" "an integer" } }
{ $description "Finds the combining class of a code point." } ;
HELP: non-starter?
-{ $value { "char" "a code point" } { "?" "a boolean" } }
+{ $values { "char" "a code point" } { "?" "a boolean" } }
{ $description "Returns true if the code point has a combining class." } ;
HELP: char>name
-{ $value { "char" "a code point" } { "name" string } }
+{ $values { "char" "a code point" } { "name" string } }
{ $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ;
HELP: name>char
-{ $value { "name" string } { "char" "a code point" } }
+{ $values { "name" string } { "char" "a code point" } }
{ $description "Looks up the code point corresponding to a given name." } ;
HELP: property?
-{ $value { "char" "a code point" } { "property" string } { "?" "a boolean" } }
+{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
io.files hashtables quotations splitting grouping arrays io
math.parser hash2 math.order byte-arrays words namespaces words
compiler.units parser io.encodings.ascii values interval-maps
-ascii sets combinators locals math.ranges sorting make io.encodings.utf8 ;
+ascii sets combinators locals math.ranges sorting make
+strings.parser io.encodings.utf8 ;
IN: unicode.data
VALUE: simple-lower
: combine-chars ( a b -- char/f ) combine-map hash2 ;
: compatibility-entry ( char -- seq ) compatibility-map at ;
: combining-class ( char -- n ) class-map at ;
-: non-starter? ( char -- ? ) class-map key? ;
-: name>char ( string -- char ) name-map at ;
-: char>name ( char -- string ) name-map value-at ;
+: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
+: name>char ( name -- char ) name-map at ;
+: char>name ( char -- name ) name-map value-at ;
: property? ( char property -- ? ) properties at interval-key? ;
! Loading data from UnicodeData.txt
cat categories index char table ?set-nth
] assoc-each table fill-ranges ] ;
-: ascii-lower ( string -- lower )
- [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
-
: process-names ( data -- names-hash )
1 swap (process-data) [
- ascii-lower { { CHAR: \s CHAR: - } } substitute swap
+ >lower { { CHAR: \s CHAR: - } } substitute swap
] H{ } assoc-map-as ;
: multihex ( hexstring -- string )
[ process-category to: category-map ]
} cleave
+: postprocess-class ( -- )
+ combine-map [ [ second ] map ] map concat
+ [ combining-class not ] filter
+ [ 0 swap class-map set-at ] each ;
+
+postprocess-class
+
load-special-casing to: special-casing
load-properties to: properties
: load-script ( filename -- table )
ascii <file-reader> parse-script process-script ;
+
+[ name>char [ "Invalid character" throw ] unless* ]
+name>char-hook set-global
{ $description "Converts a string to Normalization Form KC" } ;
HELP: nfkd
-{ $values { "string" string } { "nfc" "a string in NFKD" } }
+{ $values { "string" string } { "nfkd" "a string in NFKD" } }
{ $description "Converts a string to Normalization Form KD" } ;
locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests
+{ nfc nfkc nfd nfkd } [ must-infer ] each
+
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences namespaces make unicode.data kernel math arrays
-locals sorting.insertion accessors assocs math.order ;
+USING: ascii sequences namespaces make unicode.data kernel math arrays
+locals sorting.insertion accessors assocs math.order combinators
+unicode.syntax strings sbufs hints combinators.short-circuit vectors ;
IN: unicode.normalize
<PRIVATE
CONSTANT: final-count 28
: ?between? ( n/f from to -- ? )
- pick [ between? ] [ 3drop f ] if ;
+ pick [ between? ] [ 3drop f ] if ; inline
-: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
-: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
+: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
+: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; inline
! These numbers come from UAX 29
: initial? ( ch -- ? )
- dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
-: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
-: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
+ dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
+: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
+: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; inline
: hangul>jamo ( hangul -- jamo-string )
hangul-base - final-count /mod final-base +
: reorder-slice ( string start -- slice done? )
2dup swap [ non-starter? not ] find-from drop
- [ [ over length ] unless* rot <slice> ] keep not ;
+ [ [ over length ] unless* rot <slice> ] keep not ; inline
: reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [
reorder-slice
[ dup [ combining-class ] insertion-sort to>> ] dip
- ] [ length t ] if* ;
+ ] [ length t ] if* ; inline
: reorder-loop ( string start -- )
- dupd reorder-next [ 2drop ] [ reorder-loop ] if ;
+ dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
: reorder ( string -- )
0 reorder-loop ;
over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
:: decompose ( string quot -- decomposed )
- ! When there are 8 and 32-bit strings, this'll be
- ! equivalent to clone on 8 and the contents of the last
- ! main quotation on 32.
- string [ 127 < ] all? [ string ] [
- [
- string [
- dup hangul? [ hangul>jamo % ]
- [ dup quot call [ % ] [ , ] ?if ] if
- ] each
- ] "" make
- dup reorder
- ] if ; inline
+ string length <sbuf> :> out
+ string [
+ >fixnum dup ascii? [ out push ] [
+ dup hangul? [ hangul>jamo out push-all ]
+ [ dup quot call [ out push-all ] [ out push ] ?if ] if
+ ] if
+ ] each
+ out "" like dup reorder ; inline
+
+: with-string ( str quot -- str )
+ over aux>> [ call ] [ drop ] if ; inline
+
+: (nfd) ( string -- nfd )
+ [ canonical-entry ] decompose ;
+
+HINTS: (nfd) string ;
+
+: (nfkd) ( string -- nfkd )
+ [ compatibility-entry ] decompose ;
+
+HINTS: (nfkd) string ;
PRIVATE>
: nfd ( string -- nfd )
- [ canonical-entry ] decompose ;
+ [ (nfd) ] with-string ;
: nfkd ( string -- nfkd )
- [ compatibility-entry ] decompose ;
+ [ (nfkd) ] with-string ;
: string-append ( s1 s2 -- string )
[ append ] keep
0 over ?nth non-starter?
[ length dupd reorder-back ] [ drop ] if ;
+HINTS: string-append string string ;
+
<PRIVATE
! Normalization -- Composition
-SYMBOL: main-str
-SYMBOL: ind
-SYMBOL: after
-SYMBOL: char
-
-: get-str ( i -- ch ) ind get + main-str get ?nth ;
-: current ( -- ch ) 0 get-str ;
-: to ( -- ) ind inc ;
-: initial-medial? ( -- ? )
- current initial? [ 1 get-str medial? ] [ f ] if ;
-
-: --final? ( -- ? )
- 2 get-str final? ;
-
-: imf, ( -- )
- current to current to current jamo>hangul , ;
-
-: im, ( -- )
- current to current final-base jamo>hangul , ;
-
-: compose-jamo ( -- )
- initial-medial? [
- --final? [ imf, ] [ im, ] if
- ] [ current , ] if to ;
-
-: pass-combining ( -- )
- current non-starter? [ current , to pass-combining ] when ;
-
-:: try-compose ( last-class new-char current-class -- new-class )
- last-class current-class = [ new-char after get push last-class ] [
- char get new-char combine-chars
- [ char set last-class ]
- [ new-char after get push current-class ] if*
- ] if ;
+: initial-medial? ( str i -- ? )
+ { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
+
+: --final? ( str i -- ? )
+ 2 + swap ?nth final? ;
+
+: imf, ( str i -- str i )
+ [ tail-slice first3 jamo>hangul , ]
+ [ 3 + ] 2bi ;
+
+: im, ( str i -- str i )
+ [ tail-slice first2 final-base jamo>hangul , ]
+ [ 2 + ] 2bi ;
+
+: compose-jamo ( str i -- str i )
+ 2dup initial-medial? [
+ 2dup --final? [ imf, ] [ im, ] if
+ ] [ 2dup swap nth , 1+ ] if ;
+
+: pass-combining ( str -- str i )
+ dup [ non-starter? not ] find drop
+ [ dup length ] unless*
+ 2dup head-slice % ;
+
+TUPLE: compose-state i str char after last-class ;
+
+: get-str ( state i -- ch )
+ swap [ i>> + ] [ str>> ] bi ?nth ; inline
+: current ( state -- ch ) 0 get-str ; inline
+: to ( state -- state ) [ 1+ ] change-i ; inline
+: push-after ( ch state -- state ) [ ?push ] change-after ; inline
+
+:: try-compose ( state new-char current-class -- state )
+ state last-class>> current-class =
+ [ new-char state push-after ] [
+ state char>> new-char combine-chars
+ [ state swap >>char ] [
+ new-char state push-after
+ current-class >>last-class
+ ] if*
+ ] if ; inline
DEFER: compose-iter
-: try-noncombining ( char -- )
- char get swap combine-chars
- [ char set to f compose-iter ] when* ;
-
-: compose-iter ( last-class -- )
- current [
- dup combining-class
- [ try-compose to compose-iter ]
- [ swap [ drop ] [ try-noncombining ] if ] if*
- ] [ drop ] if* ;
-
-: ?new-after ( -- )
- after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
-
-: (compose) ( -- )
- current [
- dup jamo? [ drop compose-jamo ] [
- char set to ?new-after
- f compose-iter
- char get , after get %
+: try-noncombining ( char state -- state )
+ tuck char>> swap combine-chars
+ [ >>char to f >>last-class compose-iter ] when* ; inline
+
+: compose-iter ( state -- state )
+ dup current [
+ dup combining-class {
+ { f [ drop ] }
+ { 0 [
+ over last-class>>
+ [ drop ] [ swap try-noncombining ] if ] }
+ [ try-compose to compose-iter ]
+ } case
+ ] when* ; inline recursive
+
+: compose-combining ( ch str i -- str i )
+ compose-state new
+ swap >>i
+ swap >>str
+ swap >>char
+ compose-iter
+ { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
+
+:: (compose) ( str i -- )
+ i str ?nth [
+ dup jamo? [ drop str i compose-jamo ] [
+ i 1+ str ?nth combining-class
+ [ str i 1+ compose-combining ] [ , str i 1+ ] if
] if (compose)
- ] when* ;
+ ] when* ; inline recursive
-: compose ( str -- comp )
- [
- main-str set
- 0 ind set
- SBUF" " clone after set
- pass-combining (compose)
- ] "" make ;
+: combine ( str -- comp )
+ [ pass-combining (compose) ] "" make ;
+
+HINTS: combine string ;
PRIVATE>
: nfc ( string -- nfc )
- nfd compose ;
+ [ (nfd) combine ] with-string ;
: nfkc ( string -- nfkc )
- nfkd compose ;
+ [ (nfkd) combine ] with-string ;
HELP: group-id
{ $values
{ "string" string }
- { "id" integer } }
-{ $description "Returns the group id given a group name." } ;
+ { "id/f" "an integer or f" } }
+{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
HELP: group-name
{ $values
HELP: group-struct
{ $values
{ "obj" object }
- { "group" "a group struct" } }
+ { "group/f" "a group struct or f" } }
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
HELP: real-group-id
USING: tools.test unix.groups kernel strings math ;
IN: unix.groups.tests
-
[ ] [ all-groups drop ] unit-test
\ all-groups must-infer
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
[ ] [ [ ] with-group-cache ] unit-test
+
+[ ] [ real-group-id group-name drop ] unit-test
+
+[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ]
+[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
SYMBOL: group-cache
-GENERIC: group-struct ( obj -- group )
+GENERIC: group-struct ( obj -- group/f )
<PRIVATE
"group" <c-object> tuck 4096
[ <byte-array> ] keep f <void*> ;
-M: integer group-struct ( id -- group )
- (group-struct) getgrgid_r io-error ;
+: check-group-struct ( group-struct ptr -- group-struct/f )
+ *void* [ drop f ] unless ;
-M: string group-struct ( string -- group )
- (group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
+M: integer group-struct ( id -- group/f )
+ (group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
+
+M: string group-struct ( string -- group/f )
+ (group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
: group-struct>group ( group-struct -- group )
[ \ group new ] dip
: group-name ( id -- string )
dup group-cache get [
- at
+ dupd at* [ name>> nip ] [ drop number>string ] if
] [
- group-struct group-gr_name
+ group-struct [ group-gr_name ] [ f ] if*
] if*
[ nip ] [ number>string ] if* ;
-: group-id ( string -- id )
- group-struct group-gr_gid ;
+: group-id ( string -- id/f )
+ group-struct [ group-gr_gid ] [ f ] if* ;
<PRIVATE
(user-groups) ;
M: integer user-groups ( id -- seq )
- username (user-groups) ;
+ user-name (user-groups) ;
: all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.linux
C-STRUCT: statfs64
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
-grouping system alien.strings math.bitwise alien.syntax ;
+grouping system alien.strings math.bitwise alien.syntax
+unix.types ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
{ $values { "seq" sequence } }
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
-HELP: effective-username
+HELP: effective-user-name
{ $values { "string" string } }
-{ $description "Returns the effective username for the current user." } ;
+{ $description "Returns the effective user-name for the current user." } ;
HELP: effective-user-id
{ $values { "id" integer } }
-{ $description "Returns the effective username id for the current user." } ;
+{ $description "Returns the effective user-name id for the current user." } ;
HELP: new-passwd
{ $values { "passwd" passwd } }
{ "new-passwd" "a passwd tuple" } }
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
-HELP: real-username
+HELP: real-user-name
{ $values { "string" string } }
-{ $description "The real username of the current user." } ;
+{ $description "The real user-name of the current user." } ;
HELP: real-user-id
{ $values { "id" integer } }
HELP: set-effective-user
{ $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current effective user given a username or a user id." } ;
+{ $description "Sets the current effective user given a user-name or a user id." } ;
HELP: set-real-user
{ $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current real user given a username or a user id." } ;
+{ $description "Sets the current real user given a user-name or a user id." } ;
HELP: user-passwd
{ $values
{ "obj" object }
{ "passwd/f" "passwd or f" } }
-{ $description "Returns the passwd tuple given a username string or user id." } ;
+{ $description "Returns the passwd tuple given a user-name string or user id." } ;
-HELP: username
+HELP: user-name
{ $values
{ "id" integer }
{ "string" string } }
-{ $description "Returns the username associated with the user id." } ;
+{ $description "Returns the user-name associated with the user id." } ;
HELP: user-id
{ $values
{ "string" string }
{ "id" integer } }
-{ $description "Returns the user id associated with the username." } ;
+{ $description "Returns the user id associated with the user-name." } ;
HELP: with-effective-user
{ $values
{ "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
HELP: with-user-cache
{ $values
HELP: with-real-user
{ $values
{ "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
{
- real-username real-user-id set-real-user
- effective-username effective-user-id
+ real-user-name real-user-id set-real-user
+ effective-user-name effective-user-id
set-effective-user
} related-words
{ $subsection all-users }
"Returning a passwd tuple:"
"Real user:"
-{ $subsection real-username }
+{ $subsection real-user-name }
{ $subsection real-user-id }
{ $subsection set-real-user }
"Effective user:"
-{ $subsection effective-username }
+{ $subsection effective-user-name }
{ $subsection effective-user-id }
{ $subsection set-effective-user }
"Combinators to change users:"
\ all-users must-infer
-[ t ] [ real-username string? ] unit-test
-[ t ] [ effective-username string? ] unit-test
+[ t ] [ real-user-name string? ] unit-test
+[ t ] [ effective-user-name string? ] unit-test
[ t ] [ real-user-id integer? ] unit-test
[ t ] [ effective-user-id integer? ] unit-test
[ ] [ real-user-id set-real-user ] unit-test
[ ] [ effective-user-id set-effective-user ] unit-test
-[ ] [ real-username [ ] with-real-user ] unit-test
+[ ] [ real-user-name [ ] with-real-user ] unit-test
[ ] [ real-user-id [ ] with-real-user ] unit-test
-[ ] [ effective-username [ ] with-effective-user ] unit-test
+[ ] [ effective-user-name [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
[ ] [ [ ] with-user-cache ] unit-test
-[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
+[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
vocabs.loader system ;
IN: unix.users
-TUPLE: passwd username password uid gid gecos dir shell ;
+TUPLE: passwd user-name password uid gid gecos dir shell ;
HOOK: new-passwd os ( -- passwd )
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip
{
- [ passwd-pw_name >>username ]
+ [ passwd-pw_name >>user-name ]
[ passwd-pw_passwd >>password ]
[ passwd-pw_uid >>uid ]
[ passwd-pw_gid >>gid ]
M: string user-passwd ( string -- passwd/f )
getpwnam dup [ passwd>new-passwd ] when ;
-: username ( id -- string )
+: user-name ( id -- string )
dup user-passwd
- [ nip username>> ] [ number>string ] if* ;
+ [ nip user-name>> ] [ number>string ] if* ;
: user-id ( string -- id )
user-passwd uid>> ;
: real-user-id ( -- id )
getuid ; inline
-: real-username ( -- string )
- real-user-id username ; inline
+: real-user-name ( -- string )
+ real-user-id user-name ; inline
: effective-user-id ( -- id )
geteuid ; inline
-: effective-username ( -- string )
- effective-user-id username ; inline
+: effective-user-name ( -- string )
+ effective-user-id user-name ; inline
GENERIC: set-real-user ( string/id -- )
strings math regexp regexp.backend ;
IN: validators
+HELP: v-checkbox
+{ $values { "str" string } { "?" "a boolean" } }
+{ $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ;
+
HELP: v-captcha
{ $values { "str" string } }
{ $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ;
{ $subsection v-one-line }
{ $subsection v-one-word }
{ $subsection v-captcha }
+{ $subsection v-checkbox }
"More complex validators:"
{ $subsection v-email }
{ $subsection v-url }
[ "hello" ] [ "hello" v-one-word ] unit-test
[ "hello world" v-one-word ] must-fail
+[ t ] [ "on" v-checkbox ] unit-test
+[ f ] [ "off" v-checkbox ] unit-test
+
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ 123 ] [ "123" v-integer ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp unicode.categories arrays
-hashtables words classes quotations xmode.catalog ;
+hashtables words classes quotations xmode.catalog unicode.case ;
IN: validators
+: v-checkbox ( str -- ? )
+ >lower "on" = ;
+
: v-default ( str def -- str/def )
over empty? spin ? ;
: v-one-line ( str -- str )
v-required
- dup "\r\n" intersect empty?
- [ "must be a single line" throw ] unless ;
+ dup "\r\n" intersects?
+ [ "must be a single line" throw ] when ;
: v-one-word ( str -- str )
v-required
HELP: VALUE:\r
{ $syntax "VALUE: word" }\r
{ $values { "word" "a word to be created" } }\r
-{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;\r
+{ $description "Creates a value on the given word, initializing it to hold " { $snippet "f" } ". To get the value, just run the word. To set it, use " { $link POSTPONE: to: } "." }\r
+{ $examples\r
+ { $example\r
+ "USING: values math prettyprint ;"\r
+ "IN: scratchpad"\r
+ "VALUE: x"\r
+ "2 2 + to: x"\r
+ "x ."\r
+ "4"\r
+ }\r
+} ;\r
\r
HELP: get-value\r
{ $values { "word" "a value word" } { "value" "the contents" } }\r
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax kernel windows.types multiline ;
IN: windows.kernel32
CONSTANT: MAX_PATH 260
CONSTANT: THREAD_PRIORITY_NORMAL 0
CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15
+C-ENUM:
+ ComputerNameNetBIOS
+ ComputerNameDnsHostname
+ ComputerNameDnsDomain
+ ComputerNameDnsFullyQualified
+ ComputerNamePhysicalNetBIOS
+ ComputerNamePhysicalDnsHostname
+ ComputerNamePhysicalDnsDomain
+ ComputerNamePhysicalDnsFullyQualified
+ ComputerNameMax ;
+
+TYPEDEF: uint COMPUTER_NAME_FORMAT
+
C-STRUCT: OVERLAPPED
{ "UINT_PTR" "internal" }
{ "UINT_PTR" "internal-high" }
{ "WORD" "Data3" }
{ { "UCHAR" 8 } "Data4" } ;
+/*
+ fBinary :1;
+ fParity :1;
+ fOutxCtsFlow :1;
+ fOutxDsrFlow :1;
+ fDtrControl :2;
+ fDsrSensitivity :1;
+ fTXContinueOnXoff :1;
+ fOutX :1;
+ fInX :1;
+ fErrorChar :1;
+ fNull :1;
+ fRtsControl :2;
+ fAbortOnError :1;
+ fDummy2 :17;
+*/
+
+CONSTANT: SP_SERIALCOMM HEX: 1
+CONSTANT: BAUD_075 HEX: 1
+CONSTANT: BAUD_110 HEX: 2
+CONSTANT: BAUD_134_5 HEX: 4
+CONSTANT: BAUD_150 HEX: 8
+CONSTANT: BAUD_300 HEX: 10
+CONSTANT: BAUD_600 HEX: 20
+CONSTANT: BAUD_1200 HEX: 40
+CONSTANT: BAUD_1800 HEX: 80
+CONSTANT: BAUD_2400 HEX: 100
+CONSTANT: BAUD_4800 HEX: 200
+CONSTANT: BAUD_7200 HEX: 400
+CONSTANT: BAUD_9600 HEX: 800
+CONSTANT: BAUD_14400 HEX: 1000
+CONSTANT: BAUD_19200 HEX: 2000
+CONSTANT: BAUD_38400 HEX: 4000
+CONSTANT: BAUD_56K HEX: 8000
+CONSTANT: BAUD_57600 HEX: 40000
+CONSTANT: BAUD_115200 HEX: 20000
+CONSTANT: BAUD_128K HEX: 10000
+CONSTANT: BAUD_USER HEX: 10000000
+CONSTANT: PST_FAX HEX: 21
+CONSTANT: PST_LAT HEX: 101
+CONSTANT: PST_MODEM HEX: 6
+CONSTANT: PST_NETWORK_BRIDGE HEX: 100
+CONSTANT: PST_PARALLELPORT HEX: 2
+CONSTANT: PST_RS232 HEX: 1
+CONSTANT: PST_RS422 HEX: 3
+CONSTANT: PST_RS423 HEX: 4
+CONSTANT: PST_RS449 HEX: 5
+CONSTANT: PST_SCANNER HEX: 22
+CONSTANT: PST_TCPIP_TELNET HEX: 102
+CONSTANT: PST_UNSPECIFIED 0
+CONSTANT: PST_X25 HEX: 103
+CONSTANT: PCF_16BITMODE HEX: 200
+CONSTANT: PCF_DTRDSR HEX: 1
+CONSTANT: PCF_INTTIMEOUTS HEX: 80
+CONSTANT: PCF_PARITY_CHECK HEX: 8
+CONSTANT: PCF_RLSD HEX: 4
+CONSTANT: PCF_RTSCTS HEX: 2
+CONSTANT: PCF_SETXCHAR HEX: 20
+CONSTANT: PCF_SPECIALCHARS HEX: 100
+CONSTANT: PCF_TOTALTIMEOUTS HEX: 40
+CONSTANT: PCF_XONXOFF HEX: 10
+CONSTANT: SP_BAUD HEX: 2
+CONSTANT: SP_DATABITS HEX: 4
+CONSTANT: SP_HANDSHAKING HEX: 10
+CONSTANT: SP_PARITY HEX: 1
+CONSTANT: SP_PARITY_CHECK HEX: 20
+CONSTANT: SP_RLSD HEX: 40
+CONSTANT: SP_STOPBITS HEX: 8
+CONSTANT: DATABITS_5 1
+CONSTANT: DATABITS_6 2
+CONSTANT: DATABITS_7 4
+CONSTANT: DATABITS_8 8
+CONSTANT: DATABITS_16 16
+CONSTANT: DATABITS_16X 32
+CONSTANT: STOPBITS_10 1
+CONSTANT: STOPBITS_15 2
+CONSTANT: STOPBITS_20 4
+CONSTANT: PARITY_NONE 256
+CONSTANT: PARITY_ODD 512
+CONSTANT: PARITY_EVEN 1024
+CONSTANT: PARITY_MARK 2048
+CONSTANT: PARITY_SPACE 4096
+CONSTANT: COMMPROP_INITIALIZED HEX: e73cf52e
+
+CONSTANT: CBR_110 110
+CONSTANT: CBR_300 300
+CONSTANT: CBR_600 600
+CONSTANT: CBR_1200 1200
+CONSTANT: CBR_2400 2400
+CONSTANT: CBR_4800 4800
+CONSTANT: CBR_9600 9600
+CONSTANT: CBR_14400 14400
+CONSTANT: CBR_19200 19200
+CONSTANT: CBR_38400 38400
+CONSTANT: CBR_56000 56000
+CONSTANT: CBR_57600 57600
+CONSTANT: CBR_115200 115200
+CONSTANT: CBR_128000 128000
+CONSTANT: CBR_256000 256000
+CONSTANT: DTR_CONTROL_DISABLE 0
+CONSTANT: DTR_CONTROL_ENABLE 1
+CONSTANT: DTR_CONTROL_HANDSHAKE 2
+CONSTANT: RTS_CONTROL_DISABLE 0
+CONSTANT: RTS_CONTROL_ENABLE 1
+CONSTANT: RTS_CONTROL_HANDSHAKE 2
+CONSTANT: RTS_CONTROL_TOGGLE 3
+CONSTANT: EVENPARITY 2
+CONSTANT: MARKPARITY 3
+CONSTANT: NOPARITY 0
+CONSTANT: ODDPARITY 1
+CONSTANT: SPACEPARITY 4
+CONSTANT: ONESTOPBIT 0
+CONSTANT: ONE5STOPBITS 1
+CONSTANT: TWOSTOPBITS 2
+
+! Flowcontrol bit mask in DCB
+CONSTANT: FM_fBinary HEX: 1
+CONSTANT: FM_fParity HEX: 2
+CONSTANT: FM_fOutxCtsFlow HEX: 4
+CONSTANT: FM_fOutxDsrFlow HEX: 8
+CONSTANT: FM_fDtrControl HEX: 30
+CONSTANT: FM_fDsrSensitivity HEX: 40
+CONSTANT: FM_fTXContinueOnXoff HEX: 80
+CONSTANT: FM_fOutX HEX: 100
+CONSTANT: FM_fInX HEX: 200
+CONSTANT: FM_fErrorChar HEX: 400
+CONSTANT: FM_fNull HEX: 800
+CONSTANT: FM_fRtsControl HEX: 3000
+CONSTANT: FM_fAbortOnError HEX: 4000
+CONSTANT: FM_fDummy2 HEX: ffff8000
+
+CONSTANT: BM_fCtsHold HEX: 1
+CONSTANT: BM_fDsrHold HEX: 2
+CONSTANT: BM_fRlsdHold HEX: 4
+CONSTANT: BM_fXoffHold HEX: 8
+CONSTANT: BM_fXoffSent HEX: 10
+CONSTANT: BM_fEof HEX: 20
+CONSTANT: BM_fTxim HEX: 40
+CONSTANT: BM_AllBits HEX: 7f
+
+! PurgeComm bit mask
+CONSTANT: PURGE_TXABORT HEX: 1
+CONSTANT: PURGE_RXABORT HEX: 2
+CONSTANT: PURGE_TXCLEAR HEX: 4
+CONSTANT: PURGE_RXCLEAR HEX: 8
+
+! GetCommModemStatus bit mask
+CONSTANT: MS_CTS_ON HEX: 10
+CONSTANT: MS_DSR_ON HEX: 20
+CONSTANT: MS_RING_ON HEX: 40
+CONSTANT: MS_RLSD_ON HEX: 80
+
+! EscapeCommFunction operations
+CONSTANT: SETXOFF HEX: 1
+CONSTANT: SETXON HEX: 2
+CONSTANT: SETRTS HEX: 3
+CONSTANT: CLRRTS HEX: 4
+CONSTANT: SETDTR HEX: 5
+CONSTANT: CLRDTR HEX: 6
+CONSTANT: SETBREAK HEX: 8
+CONSTANT: CLRBREAK HEX: 9
+
+! ClearCommError bit mask
+CONSTANT: CE_RXOVER HEX: 1
+CONSTANT: CE_OVERRUN HEX: 2
+CONSTANT: CE_RXPARITY HEX: 4
+CONSTANT: CE_FRAME HEX: 8
+CONSTANT: CE_BREAK HEX: 10
+CONSTANT: CE_TXFULL HEX: 100
+! LPT only
+CONSTANT: CE_PTO HEX: 200
+CONSTANT: CE_IOE HEX: 400
+CONSTANT: CE_DNS HEX: 800
+CONSTANT: CE_OOP HEX: 1000
+! LPT only
+CONSTANT: CE_MODE HEX: 8000
+
+! GetCommMask bits
+CONSTANT: EV_RXCHAR HEX: 1
+CONSTANT: EV_RXFLAG HEX: 2
+CONSTANT: EV_TXEMPTY HEX: 4
+CONSTANT: EV_CTS HEX: 8
+CONSTANT: EV_DSR HEX: 10
+CONSTANT: EV_RLSD HEX: 20
+CONSTANT: EV_BREAK HEX: 40
+CONSTANT: EV_ERR HEX: 80
+CONSTANT: EV_RING HEX: 100
+CONSTANT: EV_PERR HEX: 200
+CONSTANT: EV_RX80FULL HEX: 400
+CONSTANT: EV_EVENT1 HEX: 800
+CONSTANT: EV_EVENT2 HEX: 1000
+
+C-STRUCT: DCB
+ { "DWORD" "DCBlength" }
+ { "DWORD" "BaudRate" }
+ { "DWORD" "flags" }
+ { "WORD" "wReserved" }
+ { "WORD" "XonLim" }
+ { "WORD" "XoffLim" }
+ { "BYTE" "ByteSize" }
+ { "BYTE" "Parity" }
+ { "BYTE" "StopBits" }
+ { "char" "XonChar" }
+ { "char" "XoffChar" }
+ { "char" "ErrorChar" }
+ { "char" "EofChar" }
+ { "char" "EvtChar" }
+ { "WORD" "wReserved1" } ;
+TYPEDEF: DCB* PDCB
+TYPEDEF: DCB* LPDCB
+
+C-STRUCT: COMM_CONFIG
+ { "DWORD" "dwSize" }
+ { "WORD" "wVersion" }
+ { "WORD" "wReserved" }
+ { "DCB" "dcb" }
+ { "DWORD" "dwProviderSubType" }
+ { "DWORD" "dwProviderOffset" }
+ { "DWORD" "dwProviderSize" }
+ { { "WCHAR" 1 } "wcProviderData" } ;
+TYPEDEF: COMMCONFIG* LPCOMMCONFIG
+
+C-STRUCT: COMMPROP
+ { "WORD" "wPacketLength" }
+ { "WORD" "wPacketVersion" }
+ { "DWORD" "dwServiceMask" }
+ { "DWORD" "dwReserved1" }
+ { "DWORD" "dwMaxTxQueue" }
+ { "DWORD" "dwMaxRxQueue" }
+ { "DWORD" "dwMaxBaud" }
+ { "DWORD" "dwProvSubType" }
+ { "DWORD" "dwProvCapabilities" }
+ { "DWORD" "dwSettableParams" }
+ { "DWORD" "dwSettableBaud" }
+ { "WORD" "wSettableData" }
+ { "WORD" "wSettableStopParity" }
+ { "DWORD" "dwCurrentTxQueue" }
+ { "DWORD" "dwCurrentRxQueue" }
+ { "DWORD" "dwProvSpec1" }
+ { "DWORD" "dwProvSpec2" }
+ { { "WCHAR" 1 } "wcProvChar" } ;
+TYPEDEF: COMMPROP* LPCOMMPROP
+
CONSTANT: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege"
CONSTANT: SE_ASSIGNPRIMARYTOKEN_NAME "SeAssignPrimaryTokenPrivilege"
! FUNCTION: GetCalendarInfoW
! FUNCTION: GetCommandLineA
! FUNCTION: GetCommandLineW
-! FUNCTION: GetCommConfig
-! FUNCTION: GetCommMask
-! FUNCTION: GetCommModemStatus
-! FUNCTION: GetCommProperties
-! FUNCTION: GetCommState
+FUNCTION: BOOL GetCommConfig ( HANDLE hCommDev, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
+FUNCTION: BOOL GetCommMask ( HANDLE hFile, LPDWORD lpEvtMask ) ;
+FUNCTION: BOOL GetCommModemStatus ( HANDLE hFile, LPDWORD lpModemStat ) ;
+FUNCTION: BOOL GetCommProperties ( HANDLE hFile, LPCOMMPROP lpCommProp ) ;
+FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: GetCommTimeouts
! FUNCTION: GetComPlusPackageInstallStatus
! FUNCTION: GetCompressedFileSizeA
! FUNCTION: GetCompressedFileSizeW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
-! FUNCTION: GetComputerNameExW
-! FUNCTION: GetComputerNameW
ALIAS: GetComputerName GetComputerNameW
+FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ;
+ALIAS: GetComputerNameEx GetComputerNameExW
! FUNCTION: GetConsoleAliasA
! FUNCTION: GetConsoleAliasesA
! FUNCTION: GetConsoleAliasesLengthA
! FUNCTION: GetDateFormatA
! FUNCTION: GetDateFormatW
! FUNCTION: GetDefaultCommConfigA
-! FUNCTION: GetDefaultCommConfigW
+FUNCTION: BOOL GetDefaultCommConfigW ( LPCTSTR lpszName, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
+ALIAS: GetDefaultCommConfig GetDefaultCommConfigW
! FUNCTION: GetDefaultSortkeySize
! FUNCTION: GetDevicePowerState
! FUNCTION: GetDiskFreeSpaceA
! FUNCTION: SetCalendarInfoA
! FUNCTION: SetCalendarInfoW
! FUNCTION: SetClientTimeZoneInformation
-! FUNCTION: SetCommBreak
-! FUNCTION: SetCommConfig
-! FUNCTION: SetCommMask
-! FUNCTION: SetCommState
+FUNCTION: BOOL SetCommBreak ( HANDLE hFile ) ;
+FUNCTION: BOOL SetCommConfig ( HANDLE hCommDev, LPCOMMCONFIG lpCC, DWORD dwSize ) ;
+FUNCTION: BOOL SetCommMask ( HANDLE hFile, DWORD dwEvtMask ) ;
+FUNCTION: BOOL SetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: SetCommTimeouts
! FUNCTION: SetComPlusPackageInstallStatus
! FUNCTION: SetComputerNameA
FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ;
ALIAS: SetCurrentDirectory SetCurrentDirectoryW
! FUNCTION: SetDefaultCommConfigA
-! FUNCTION: SetDefaultCommConfigW
+FUNCTION: BOOL SetDefaultCommConfigW ( LPCTSTR lpszName, LPCOMMCONFIG lpCC, LPDWORD lpdwSize ) ;
+ALIAS: SetDefaultCommConfig SetDefaultCommConfigW
! FUNCTION: SetDllDirectoryA
! FUNCTION: SetDllDirectoryW
FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ;
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
parser-combinators.regexp splitting parser-combinators ascii
-unicode.case combinators.short-circuit accessors ;
+ascii combinators.short-circuit accessors ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." }
$io-error ;
-HELP: stream-format
-{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
-{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
-$nl
-"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-block-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
-{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
-$nl
-"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
-$nl
-"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: stream-write-table
-{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
-{ $contract "Prints a table of cells produced by " { $link with-cell } "."
-$nl
-"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-cell-stream
-{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
-{ $contract "Creates an output stream which writes to a table cell object." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
-$io-error ;
-
-HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
-{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
-$nl
-"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
-$io-error ;
HELP: stream-print
{ $values { "str" string } { "stream" "an output stream" } }
{ $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
-HELP: format
-{ $values { "str" string } { "style" "a hashtable" } }
-{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
-{ $notes "Details are in the documentation for " { $link stream-format } "." }
-$io-error ;
-
-HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
-{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
-$io-error ;
-
-HELP: tabular-output
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
-$nl
-"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
-{ $examples
- { $code
- "{ { 1 2 } { 3 4 } }"
- "H{ { table-gap { 10 10 } } } ["
- " [ [ [ [ . ] with-cell ] each ] with-row ] each"
- "] tabular-output"
- }
-}
-$io-error ;
-
-HELP: with-row
-{ $values { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
-$io-error ;
-
-HELP: with-cell
-{ $values { "quot" quotation } }
-{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
-$io-error ;
-
-HELP: write-cell
-{ $values { "str" string } }
-{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
-$io-error ;
-
-HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
-{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
-$io-error ;
-
HELP: print
{ $values { "string" string } }
{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
{ $subsection stream-flush }
{ $subsection stream-write1 }
{ $subsection stream-write }
-{ $subsection stream-format }
{ $subsection stream-nl }
-{ $subsection make-span-stream }
-{ $subsection make-block-stream }
-{ $subsection make-cell-stream }
-{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "Default input and output streams"
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
-"Formatted output:"
-{ $subsection format }
-{ $subsection with-style }
-{ $subsection with-nesting }
-"Tabular output:"
-{ $subsection tabular-output }
-{ $subsection with-row }
-{ $subsection with-cell }
-{ $subsection write-cell }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
continuations destructors assocs ;
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
-GENERIC: stream-format ( str style stream -- )
-GENERIC: make-span-stream ( style stream -- stream' )
-GENERIC: make-block-stream ( style stream -- stream' )
-GENERIC: make-cell-stream ( style stream -- stream' )
-GENERIC: stream-write-table ( table-cells style stream -- )
: stream-print ( str stream -- )
[ stream-write ] keep stream-nl ;
: flush ( -- ) output-stream get stream-flush ;
: nl ( -- ) output-stream get stream-nl ;
-: format ( str style -- ) output-stream get stream-format ;
: with-input-stream* ( stream quot -- )
input-stream swap with-variable ; inline
[ [ drop dispose dispose ] 3curry ] 3bi
[ ] cleanup ; inline
-: tabular-output ( style quot -- )
- swap [ { } make ] dip output-stream get stream-write-table ; inline
-
-: with-row ( quot -- )
- { } make , ; inline
-
-: with-cell ( quot -- )
- H{ } output-stream get make-cell-stream
- [ swap with-output-stream ] keep , ; inline
-
-: write-cell ( str -- )
- [ write ] with-cell ; inline
-
-: with-style ( style quot -- )
- swap dup assoc-empty? [
- drop call
- ] [
- output-stream get make-span-stream swap with-output-stream
- ] if ; inline
-
-: with-nesting ( style quot -- )
- [ output-stream get make-block-stream ] dip
- with-output-stream ; inline
-
: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: io io.streams.nested help.markup help.syntax ;
-
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs kernel namespaces strings
-quotations io continuations destructors accessors sequences ;
-IN: io.streams.nested
-
-TUPLE: filter-writer stream ;
-
-M: filter-writer stream-format
- stream>> stream-format ;
-
-M: filter-writer stream-write
- stream>> stream-write ;
-
-M: filter-writer stream-write1
- stream>> stream-write1 ;
-
-M: filter-writer make-span-stream
- stream>> make-span-stream ;
-
-M: filter-writer make-block-stream
- stream>> make-block-stream ;
-
-M: filter-writer make-cell-stream
- stream>> make-cell-stream ;
-
-M: filter-writer stream-flush
- stream>> stream-flush ;
-
-M: filter-writer stream-nl
- stream>> stream-nl ;
-
-M: filter-writer stream-write-table
- stream>> stream-write-table ;
-
-M: filter-writer dispose
- stream>> dispose ;
-
-TUPLE: ignore-close-stream < filter-writer ;
-
-M: ignore-close-stream dispose drop ;
-
-C: <ignore-close-stream> ignore-close-stream
-
-TUPLE: style-stream < filter-writer style ;
-
-: do-nested-style ( style style-stream -- style stream )
- [ style>> swap assoc-union ] [ stream>> ] bi ; inline
-
-C: <style-stream> style-stream
-
-M: style-stream stream-format
- do-nested-style stream-format ;
-
-M: style-stream stream-write
- [ style>> ] [ stream>> ] bi stream-format ;
-
-M: style-stream stream-write1
- [ 1string ] dip stream-write ;
-
-M: style-stream make-span-stream
- do-nested-style make-span-stream ;
-
-M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] [ style>> ] bi
- <style-stream> ;
-
-M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] [ style>> ] bi
- <style-stream> ;
-
-M: style-stream stream-write-table
- [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
- stream-write-table ;
+++ /dev/null
-Support for with-stream-style implementation
USING: help.markup help.syntax io ;
IN: io.streams.plain
-ARTICLE: "io.streams.plain" "Plain writer streams"
-"Plain writer streams wrap an underlying stream and provide a default implementation of "
-{ $link stream-nl } ", "
-{ $link stream-format } ", "
-{ $link make-span-stream } ", "
-{ $link make-block-stream } " and "
-{ $link make-cell-stream } "."
-{ $subsection plain-writer } ;
-
ABOUT: "io.streams.plain"
HELP: plain-writer
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io io.streams.nested ;
+USING: kernel io ;
IN: io.streams.plain
MIXIN: plain-writer
M: plain-writer stream-nl
- CHAR: \n swap stream-write1 ;
-
-M: plain-writer stream-format
- nip stream-write ;
-
-M: plain-writer make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
-M: plain-writer make-block-stream
- nip <ignore-close-stream> ;
+ CHAR: \n swap stream-write1 ;
\ No newline at end of file
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
strings generic splitting continuations destructors
M: null-encoding decode-char drop stream-read1 ;
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
-
PRIVATE>
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
M: growable dispose drop ;
M: growable stream-write1 push ;
[ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
-
-M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-output-stream* ;
-
-M: plain-writer make-cell-stream 2drop <string-writer> ;
}
} ;
+HELP: >=<
+{ $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } }
+{ $description "Compares two objects using the " { $link <=> } " comparator and inverts the output." } ;
+
+{ <=> >=< } related-words
+
HELP: +lt+
{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
{ $subsection <=> }
+{ $subsection >=< }
{ $subsection compare }
{ $subsection invert-comparison }
"The above words output order specifiers."
GENERIC: <=> ( obj1 obj2 -- <=> )
+: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
+
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
GENERIC: before? ( obj1 obj2 -- ? )
{ $see POSTPONE: SYMBOL: }
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
{ $subsection CREATE }
+{ $subsection CREATE-WORD }
"Colon definitions are defined in a more elaborate way:"
{ $subsection POSTPONE: : }
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
+HELP: 3each
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
+{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
+
HELP: 2reduce
{ $values { "seq1" sequence }
{ "seq2" sequence }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
+HELP: 3map
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
+{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
+
HELP: 2map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
+HELP: 3map-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
+
HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
"V{ 1 2 3 }"
} } ;
+HELP: iota
+{ $values { "n" integer } { "iota" iota } }
+{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." }
+{ $examples
+ { $example
+ "USING: math sequences prettyprint ;"
+ "3 iota [ sq ] map ."
+ "{ 0 1 4 }"
+ }
+} ;
+
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
-{ $subsection "sequence-2combinators" } ;
+{ $subsection "sequence-2combinators" }
+{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
-"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
+"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
+ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
+"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
+{ $subsection 3each }
+{ $subsection 3map }
+{ $subsection 3map-as } ;
+
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection empty? }
{ 3 0 } [ [ 3drop ] 3each ] must-infer-as
-[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
\ No newline at end of file
+[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
+
+[ "asdf" iota ] must-fail
+[ T{ iota { n 10 } } ] [ 10 iota ] unit-test
+[ 0 ] [ 10 iota first ] unit-test
INSTANCE: integer immutable-sequence
+PRIVATE>
+
+! In the future, this will replace integer sequences
+TUPLE: iota { n integer read-only } ;
+
+: iota ( n -- iota ) \ iota boa ; inline
+
+<PRIVATE
+
+M: iota length n>> ;
+M: iota nth-unsafe drop ;
+
+INSTANCE: iota immutable-sequence
+
: first-unsafe ( seq -- first )
0 swap nth-unsafe ; inline
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
+"Set-theoretic predicates:"
+{ $subsection intersects? }
{ $subsection subset? }
{ $subsection set= }
"A word used to implement the above:"
{ diff intersect union } related-words
+HELP: intersects?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
+{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
+
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
+{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
+
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { } { 1 } intersects? ] unit-test
+
+[ f ] [ { 1 } { } intersects? ] unit-test
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences vectors ;
IN: sets
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
+<PRIVATE
+
+: tester ( seq -- quot ) unique [ key? ] curry ; inline
+
+PRIVATE>
+
: intersect ( seq1 seq2 -- newseq )
- unique [ key? ] curry filter ;
+ tester filter ;
+
+: intersects? ( seq1 seq2 -- ? )
+ tester contains? ;
: diff ( seq1 seq2 -- newseq )
- unique [ key? not ] curry filter ;
+ tester [ not ] compose filter ;
: union ( seq1 seq2 -- newseq )
append prune ;
: subset? ( seq1 seq2 -- ? )
- unique [ key? ] curry all? ;
+ tester all? ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;
HELP: sort
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
-{ $description "Sorts the elements into a new array." } ;
+{ $description "Sorts the elements into a new array using a stable sort." }
+{ $notes "The algorithm used is the merge sort." } ;
HELP: sort-keys
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup "\r\n" intersect empty? [
- 1array
- ] [
+ dup "\r\n" intersects? [
"\n" split [
but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat
+ ] [
+ 1array
] if ;
] times
.
] times
- ] with-null-stream
+ ] with-null-writer
] unit-test
[ t ] [
SYMBOL: load-help?
-ERROR: circular-dependency name ;
-
<PRIVATE
: load-source ( vocab -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
-: restore-turtle ( turtle -- turtle ) saved>> pop ;
+
+: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /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
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors specialized-arrays.double fry kernel locals make math
-math.constants math.functions math.vectors prettyprint
+USING: accessors specialized-arrays.double fry kernel locals math
+math.constants math.functions math.vectors prettyprint combinators.smart
sequences hints arrays ;
IN: benchmark.nbody
offset-momentum drop ; inline
: <nbody-system> ( -- system )
- [ <sun> , <jupiter> , <saturn> , <uranus> , <neptune> , ] { } make nbody-system boa
+ [ <sun> <jupiter> <saturn> <uranus> <neptune> ] output>array nbody-system boa
dup bodies>> init-bodies ; inline
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
USING: io io.files io.files.temp io.streams.duplex kernel
sequences sequences.private strings vectors words memoize
splitting grouping hints tr continuations io.encodings.ascii
-unicode.case ;
+ascii ;
IN: benchmark.reverse-complement
TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors curses kernel threads tools.test ;
+IN: curses.tests
+
+: hello-curses ( -- )
+ [
+ curses-window new
+ "mainwin" >>name
+ add-curses-window
+
+ "mainwin" "hi" curses-printf
+
+ 2000000 sleep
+ ] with-curses ;
+
+[
+] [ hello-curses ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings assocs byte-arrays
+combinators continuations destructors fry io.encodings.8-bit
+io io.encodings.string io.encodings.utf8 kernel math
+namespaces prettyprint sequences
+strings threads curses.ffi ;
+IN: curses
+
+SYMBOL: curses-windows
+SYMBOL: current-window
+
+: ERR -1 ; inline
+: FALSE 0 ; inline
+: TRUE 1 ; inline
+: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
+
+ERROR: duplicate-window window ;
+ERROR: unnamed-window window ;
+ERROR: window-not-found window ;
+ERROR: curses-failed ;
+
+: get-window ( string -- window )
+ dup curses-windows get at*
+ [ nip ] [ drop window-not-found ] if ;
+
+: window-ptr ( string -- window ) get-window ptr>> ;
+
+: curses-error ( n -- ) ERR = [ curses-failed ] when ;
+
+: with-curses ( quot -- )
+ H{ } clone curses-windows [
+ initscr curses-error
+ [
+ curses-windows get values [ dispose ] each
+ nocbreak curses-error
+ echo curses-error
+ endwin curses-error
+ ] [ ] cleanup
+ ] with-variable ; inline
+
+: with-window ( name quot -- )
+ [ window-ptr current-window ] dip with-variable ; inline
+
+TUPLE: curses-window
+ name
+ parent-name
+ ptr
+ { lines integer initial: 0 }
+ { columns integer initial: 0 }
+ { y integer initial: 0 }
+ { x integer initial: 0 }
+
+ { cbreak initial: t }
+ { echo initial: t }
+ { raw initial: f }
+
+ { scrollok initial: t }
+ { leaveok initial: f }
+
+ idcok idlok immedok
+ { keypad initial: f } ;
+
+M: curses-window dispose ( window -- )
+ ptr>> delwin curses-error ;
+
+<PRIVATE
+
+: add-window ( window -- )
+ dup name>> [ unnamed-window ] unless*
+ curses-windows get 2dup key?
+ [ duplicate-window ] [ set-at ] if ;
+
+: delete-window ( window -- )
+ curses-windows get 2dup key?
+ [ delete-at ] [ drop window-not-found ] if ;
+
+: window-params ( window -- lines columns y x )
+ { [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
+
+: setup-window ( window -- )
+ {
+ [
+ dup
+ dup parent-name>> [
+ window-ptr swap window-params derwin
+ ] [
+ window-params newwin
+ ] if* [ curses-error ] keep >>ptr drop
+ ]
+ [ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ]
+ [ echo>> [ echo ] [ noecho ] if curses-error ]
+ [ raw>> [ raw ] [ noraw ] if curses-error ]
+ [ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
+ [ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
+ [ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
+ [ add-window ]
+ } cleave ;
+
+PRIVATE>
+
+: add-curses-window ( window -- )
+ [ setup-window ] [ ] [ dispose ] cleanup ;
+
+: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ;
+: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ;
+: curses-refresh ( -- ) current-window get (curses-window-refresh) ;
+
+: (curses-wprint) ( window-ptr string -- )
+ waddstr curses-error ;
+
+: curses-nwrite ( window string -- )
+ [ window-ptr ] dip (curses-wprint) ;
+
+: curses-wprint ( window string -- )
+ [ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
+
+: curses-printf ( window string -- )
+ [ window-ptr dup dup ] dip (curses-wprint)
+ "\n" (curses-wprint)
+ (curses-window-refresh) ;
+
+: curses-writef ( window string -- )
+ [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
+
+: (curses-read) ( window-ptr n encoding -- string )
+ [ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
+
+: curses-read ( window n -- string )
+ utf8 [ window-ptr ] 2dip (curses-read) ;
+
+: curses-erase ( window -- ) window-ptr werase curses-error ;
+
+: move-cursor ( window-name y x -- )
+ [
+ window-ptr
+ {
+ [ ]
+ [ (curses-window-refresh) ]
+ [ c-window-_curx ]
+ [ c-window-_cury ]
+ } cleave
+ ] 2dip mvcur curses-error (curses-window-refresh) ;
+
+: delete-line ( window-name y -- )
+ [ window-ptr dup ] dip
+ 0 wmove curses-error wdeleteln curses-error ;
+
+: insert-blank-line ( window-name y -- )
+ [ window-ptr dup ] dip
+ 0 wmove curses-error winsertln curses-error ;
+
+: insert-line ( window-name y string -- )
+ [ dupd insert-blank-line ] dip
+ curses-writef ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.syntax combinators kernel system ;
+IN: curses.ffi
+
+<< "curses" {
+ { [ os winnt? ] [ "libcurses.dll" ] }
+ { [ os macosx? ] [ "libcurses.dylib" ] }
+ { [ os unix? ] [ "libcurses.so" ] }
+} cond "cdecl" add-library >>
+
+TYPEDEF: void* WINDOW*
+TYPEDEF: void* SCREEN*
+TYPEDEF: void* va_list
+
+TYPEDEF: uint chtype
+TYPEDEF: chtype attr_t
+TYPEDEF: short NCURSES_SIZE_T
+TYPEDEF: ushort wchar_t
+
+: CCHARW_MAX 5 ; inline
+
+C-STRUCT: cchar_t
+ { "attr_t" "attr" }
+ { { "wchar_t" CCHARW_MAX } "chars" } ;
+
+C-STRUCT: pdat
+ { "NCURSES_SIZE_T" "_pad_y" }
+ { "NCURSES_SIZE_T" "_pad_x" }
+ { "NCURSES_SIZE_T" "_pad_top" }
+ { "NCURSES_SIZE_T" "_pad_left" }
+ { "NCURSES_SIZE_T" "_pad_bottom" }
+ { "NCURSES_SIZE_T" "_pad_right" } ;
+
+C-STRUCT: c-window
+ { "NCURSES_SIZE_T" "_cury" }
+ { "NCURSES_SIZE_T" "_curx" }
+
+ { "NCURSES_SIZE_T" "_maxy" }
+ { "NCURSES_SIZE_T" "_maxx" }
+ { "NCURSES_SIZE_T" "_begy" }
+ { "NCURSES_SIZE_T" "_begx" }
+
+ { "short" " _flags" }
+
+ { "attr_t" "_attrs" }
+ { "chtype" "_bkgd" }
+
+ { "bool" "_notimeout" }
+ { "bool" "_clear" }
+ { "bool" "_leaveok" }
+ { "bool" "_scroll" }
+ { "bool" "_idlok" }
+ { "bool" "_idcok" }
+ { "bool" "_immed" }
+ { "bool" "_sync" }
+ { "bool" "_use_keypad" }
+ { "int" "_delay" }
+
+ { "char*" "_line" }
+ { "NCURSES_SIZE_T" "_regtop" }
+ { "NCURSES_SIZE_T" "_regbottom" }
+
+ { "int" "_parx" }
+ { "int" "_pary" }
+ { "WINDOW*" "_parent" }
+
+ { "pdat" "_pad" }
+
+ { "NCURSES_SIZE_T" "_yoffset" }
+
+ { "cchar_t" "_bkgrnd" } ;
+
+LIBRARY: curses
+
+: stdscr ( -- alien )
+ "stdscr" "curses" library dll>> dlsym ;
+
+FUNCTION: WINDOW* initscr ( ) ;
+FUNCTION: int endwin ( ) ;
+FUNCTION: bool isendwin ( ) ;
+FUNCTION: SCREEN* newterm ( char* type, FILE* outfd, FILE* infd ) ;
+FUNCTION: SCREEN* set_term ( SCREEN* new ) ;
+FUNCTION: void delscreen ( SCREEN* sp ) ;
+
+FUNCTION: int def_prog_mode ( ) ;
+FUNCTION: int def_shell_mode ( ) ;
+FUNCTION: int reset_prog_mode ( ) ;
+FUNCTION: int reset_shell_mode ( ) ;
+FUNCTION: int resetty ( ) ;
+FUNCTION: int savetty ( ) ;
+FUNCTION: int ripoffline ( int line, void* callback ) ;
+FUNCTION: int curs_set ( int visibility ) ;
+FUNCTION: int napms ( int ms ) ;
+
+FUNCTION: WINDOW* newwin ( int nlines, int ncols, int begin_y, int begin_x ) ;
+FUNCTION: int delwin ( WINDOW* win ) ;
+FUNCTION: int mvwin ( WINDOW* win, int y, int x ) ;
+FUNCTION: WINDOW* subwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
+FUNCTION: WINDOW* derwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
+FUNCTION: int mvderwin ( WINDOW* win, int par_y, int par_x ) ;
+FUNCTION: WINDOW* dupwin ( WINDOW* win ) ;
+FUNCTION: void wsyncup ( WINDOW* win ) ;
+FUNCTION: int syncok ( WINDOW* win, bool bf ) ;
+FUNCTION: void wcursyncup ( WINDOW* win ) ;
+FUNCTION: void wsyncdown ( WINDOW* win ) ;
+
+FUNCTION: int cbreak ( ) ;
+FUNCTION: int nocbreak ( ) ;
+FUNCTION: int echo ( ) ;
+FUNCTION: int noecho ( ) ;
+FUNCTION: int halfdelay ( int tenths ) ;
+FUNCTION: int intrflush ( WINDOW* win, bool bf ) ;
+FUNCTION: int keypad ( WINDOW* win, bool bf ) ;
+FUNCTION: int meta ( WINDOW* win, bool bf ) ;
+FUNCTION: int nodelay ( WINDOW* win, bool bf ) ;
+FUNCTION: int raw ( ) ;
+FUNCTION: int noraw ( ) ;
+FUNCTION: void noqiflush ( ) ;
+FUNCTION: void qiflush ( ) ;
+FUNCTION: int notimeout ( WINDOW* win, bool bf ) ;
+FUNCTION: void timeout ( int delay ) ;
+FUNCTION: void wtimeout ( WINDOW* win, int delay ) ;
+FUNCTION: int typeahead ( int fd ) ;
+
+FUNCTION: int clearok ( WINDOW* win, bool bf ) ;
+FUNCTION: int idlok ( WINDOW* win, bool bf ) ;
+FUNCTION: void idcok ( WINDOW* win, bool bf ) ;
+FUNCTION: void immedok ( WINDOW* win, bool bf ) ;
+FUNCTION: int leaveok ( WINDOW* win, bool bf ) ;
+FUNCTION: int setscrreg ( int top, int bot ) ;
+FUNCTION: int wsetscrreg ( WINDOW* win, int top, int bot ) ;
+FUNCTION: int scrollok ( WINDOW* win, bool bf ) ;
+FUNCTION: int nl ( ) ;
+FUNCTION: int nonl ( ) ;
+
+FUNCTION: int erase ( ) ;
+FUNCTION: int werase ( WINDOW* win ) ;
+FUNCTION: int clear ( ) ;
+FUNCTION: int wclear ( WINDOW* win ) ;
+FUNCTION: int clrtobot ( ) ;
+FUNCTION: int wclrtobot ( WINDOW* win ) ;
+FUNCTION: int clrtoeol ( ) ;
+FUNCTION: int wclrtoeol ( WINDOW* win ) ;
+
+FUNCTION: int refresh ( ) ;
+FUNCTION: int wrefresh ( WINDOW* win ) ;
+FUNCTION: int wnoutrefresh ( WINDOW* win ) ;
+FUNCTION: int doupdate ( ) ;
+FUNCTION: int redrawwin ( WINDOW* win ) ;
+FUNCTION: int wredrawln ( WINDOW* win, int beg_line, int num_lines ) ;
+
+FUNCTION: int getch ( ) ;
+FUNCTION: int wgetch ( WINDOW* win ) ;
+FUNCTION: int mvgetch ( int y, int x ) ;
+FUNCTION: int mvwgetch ( WINDOW* win, int y, int x ) ;
+FUNCTION: int ungetch ( int ch ) ;
+FUNCTION: int has_key ( int ch ) ;
+
+FUNCTION: int getstr ( char* str ) ;
+FUNCTION: int getnstr ( char* str, int n ) ;
+FUNCTION: int wgetstr ( WINDOW* win, char* str ) ;
+FUNCTION: int wgetnstr ( WINDOW* win, char* str, int n ) ;
+FUNCTION: int mvgetstr ( int y, int x, char* str ) ;
+FUNCTION: int mvwgetstr ( WINDOW* win, int y, int x, char* str ) ;
+FUNCTION: int mvgetnstr ( int y, int x, char* str, int n ) ;
+FUNCTION: int mvwgetnstr ( WINDOW* win, int y, int x, char* str, int n ) ;
+
+FUNCTION: int printw ( char* fmt, int lol ) ;
+FUNCTION: int wprintw ( WINDOW* win, char* fmt, int lol ) ;
+FUNCTION: int mvprintw ( int y, int x, char* fmt, int lol ) ;
+FUNCTION: int mvwprintw ( WINDOW* win, int y, int x, char* fmt, int lol ) ;
+FUNCTION: int vwprintw ( WINDOW* win, char* fmt, va_list varglist ) ;
+FUNCTION: int vw_printw ( WINDOW* win, char* fmt, va_list varglist ) ;
+
+FUNCTION: int move ( int y, int x ) ;
+FUNCTION: int wmove ( WINDOW* win, int y, int x ) ;
+
+
+FUNCTION: int scroll ( WINDOW* win ) ;
+FUNCTION: int scrl ( int n ) ;
+FUNCTION: int wscrl ( WINDOW* win, int n ) ;
+
+ ! int setupterm(char *term, int fildes, int *errret);
+ ! int setterm(char *term);
+ ! TERMINAL *set_curterm(TERMINAL *nterm);
+ ! int del_curterm(TERMINAL *oterm);
+ ! int restartterm(const char *term, int fildes, int *errret);
+ ! char *tparm(char *str, ...);
+ ! int tputs(const char *str, int affcnt, int (*putc)(int));
+ ! int putp(const char *str);
+ ! int vidputs(chtype attrs, int (*putc)(int));
+ ! int vidattr(chtype attrs);
+ ! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char));
+ ! int vid_attr(attr_t attrs, short pair, void *opts);
+FUNCTION: int mvcur ( int oldrow, int oldcol, int newrow, int newcol ) ;
+ ! int tigetflag(char *capname);
+ ! int tigetnum(char *capname);
+ ! char *tigetstr(char *capname);
+
+FUNCTION: int touchwin ( WINDOW* win ) ;
+FUNCTION: int touchline ( WINDOW* win, int start, int count ) ;
+FUNCTION: int untouchwin ( WINDOW* win ) ;
+FUNCTION: int wtouchln ( WINDOW* win, int y, int n, int changed ) ;
+FUNCTION: bool is_linetouched ( WINDOW* win, int line ) ;
+FUNCTION: bool is_wintouched ( WINDOW* win ) ;
+
+FUNCTION: int insch ( chtype ch ) ;
+FUNCTION: int winsch ( WINDOW* win, chtype ch ) ;
+FUNCTION: int mvinsch ( int y, int x, chtype ch ) ;
+FUNCTION: int mvwinsch ( WINDOW* win, int y, int x, chtype ch ) ;
+FUNCTION: int delch ( ) ;
+FUNCTION: int wdelch ( WINDOW* win ) ;
+FUNCTION: int mvdelch ( int y, int x ) ;
+FUNCTION: int mvwdelch ( WINDOW* win, int y, int x ) ;
+
+FUNCTION: int deleteln ( ) ;
+FUNCTION: int wdeleteln ( WINDOW* win ) ;
+FUNCTION: int insdelln ( int n ) ;
+FUNCTION: int winsdelln ( WINDOW* win, int n ) ;
+FUNCTION: int insertln ( ) ;
+FUNCTION: int winsertln ( WINDOW* win ) ;
+
+FUNCTION: int addstr ( char* str ) ;
+FUNCTION: int addnstr ( char* str, int n ) ;
+FUNCTION: int waddstr ( WINDOW* win, char* str ) ;
+FUNCTION: int waddnstr ( WINDOW* win, char* str, int n ) ;
+FUNCTION: int mvaddstr ( int y, int x, char* str ) ;
+FUNCTION: int mvaddnstr ( int y, int x, char* str, int n ) ;
+FUNCTION: int mvwaddstr ( WINDOW* win, int y, int x, char* str ) ;
+FUNCTION: int mvwaddnstr ( WINDOW* win, int y, int x, char* str, int n ) ;
--- /dev/null
+unportable
--- /dev/null
+ncurses binding
--- /dev/null
+unportable
Jose Antonio Ortega Ruiz
-Eduardo Cavazos
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fuel.eval ;
+IN: fuel.eval.tests
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays compiler.units continuations debugger
+fuel.pprint io io.streams.string kernel namespaces parser sequences
+vectors vocabs.parser ;
+
+IN: fuel.eval
+
+TUPLE: fuel-status in use restarts ;
+
+SYMBOL: fuel-status-stack
+V{ } clone fuel-status-stack set-global
+
+SYMBOL: fuel-eval-result
+f fuel-eval-result set-global
+
+SYMBOL: fuel-eval-output
+f fuel-eval-result set-global
+
+SYMBOL: fuel-eval-res-flag
+t fuel-eval-res-flag set-global
+
+: fuel-eval-restartable? ( -- ? )
+ fuel-eval-res-flag get-global ; inline
+
+: fuel-push-status ( -- )
+ in get use get clone restarts get-global clone
+ fuel-status boa
+ fuel-status-stack get push ;
+
+: fuel-pop-restarts ( restarts -- )
+ fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
+
+: fuel-pop-status ( -- )
+ fuel-status-stack get empty? [
+ fuel-status-stack get pop
+ [ in>> in set ]
+ [ use>> clone use set ]
+ [ restarts>> fuel-pop-restarts ] tri
+ ] unless ;
+
+: fuel-forget-error ( -- ) f error set-global ; inline
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+: fuel-forget-status ( -- )
+ fuel-forget-error fuel-forget-result fuel-forget-output ; inline
+
+: fuel-send-retort ( -- )
+ error get fuel-eval-result get-global fuel-eval-output get-global
+ 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
+
+: (fuel-begin-eval) ( -- )
+ fuel-push-status fuel-forget-status ; inline
+
+: (fuel-end-eval) ( output -- )
+ fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline
+
+: (fuel-eval) ( lines -- )
+ [ [ parse-lines ] with-compilation-unit call ] curry
+ [ print-error ] recover ; inline
+
+: (fuel-eval-each) ( lines -- )
+ [ 1vector (fuel-eval) ] each ; inline
+
+: (fuel-eval-usings) ( usings -- )
+ [ "USING: " prepend " ;" append ] map
+ (fuel-eval-each) fuel-forget-error fuel-forget-output ;
+
+: (fuel-eval-in) ( in -- )
+ [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+
+: (fuel-eval-in-context) ( lines in usings -- )
+ (fuel-begin-eval)
+ [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
+ (fuel-end-eval) ;
! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.tuple combinators
-compiler.units continuations debugger definitions help help.crossref
-help.markup help.topics io io.pathnames io.streams.string kernel lexer
-make math math.order memoize namespaces parser quotations prettyprint
-sequences sets sorting source-files strings summary tools.crossref
-tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ;
+USING: accessors arrays assocs compiler.units definitions fuel.eval
+fuel.help help.markup help.topics io.pathnames kernel math math.order
+memoize namespaces parser sequences sets sorting tools.crossref
+tools.scaffold tools.vocabs vocabs vocabs.loader vocabs.parser words ;
IN: fuel
-! Evaluation status:
-
-TUPLE: fuel-status in use restarts ;
-
-SYMBOL: fuel-status-stack
-V{ } clone fuel-status-stack set-global
-
-SYMBOL: fuel-eval-result
-f fuel-eval-result set-global
-
-SYMBOL: fuel-eval-output
-f fuel-eval-result set-global
-
-SYMBOL: fuel-eval-res-flag
-t fuel-eval-res-flag set-global
-
-: fuel-eval-restartable? ( -- ? )
- fuel-eval-res-flag get-global ; inline
+! Evaluation
: fuel-eval-restartable ( -- )
t fuel-eval-res-flag set-global ; inline
: fuel-eval-non-restartable ( -- )
f fuel-eval-res-flag set-global ; inline
-: fuel-push-status ( -- )
- in get use get clone restarts get-global clone
- fuel-status boa
- fuel-status-stack get push ;
-
-: fuel-pop-restarts ( restarts -- )
- fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
-
-: fuel-pop-status ( -- )
- fuel-status-stack get empty? [
- fuel-status-stack get pop
- [ in>> in set ]
- [ use>> clone use set ]
- [ restarts>> fuel-pop-restarts ] tri
- ] unless ;
-
-! Lispy pretty printing
-
-GENERIC: fuel-pprint ( obj -- )
-
-M: object fuel-pprint pprint ; inline
-
-: fuel-maybe-scape ( ch -- seq )
- dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
-
-M: word fuel-pprint
- name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
-
-M: f fuel-pprint drop "nil" write ; inline
-
-M: integer fuel-pprint pprint ; inline
-
-M: string fuel-pprint pprint ; inline
-
-M: sequence fuel-pprint
- "(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline
-
-M: tuple fuel-pprint tuple>array fuel-pprint ; inline
-
-M: quotation fuel-pprint pprint ; inline
-
-M: continuation fuel-pprint drop ":continuation" write ; inline
-
-M: restart fuel-pprint name>> fuel-pprint ; inline
-
-SYMBOL: :restarts
-
-: fuel-restarts ( obj -- seq )
- compute-restarts :restarts prefix ; inline
-
-M: condition fuel-pprint
- [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
-
-M: lexer-error fuel-pprint
- {
- [ line>> ]
- [ column>> ]
- [ line-text>> ]
- [ fuel-restarts ]
- } cleave 4array lexer-error prefix fuel-pprint ;
-
-M: source-file-error fuel-pprint
- [ file>> ] [ error>> ] bi 2array source-file-error prefix
- fuel-pprint ;
-
-M: source-file fuel-pprint path>> fuel-pprint ;
-
-! Evaluation vocabulary
+: fuel-eval-in-context ( lines in usings -- )
+ (fuel-eval-in-context) ;
: fuel-eval-set-result ( obj -- )
clone fuel-eval-result set-global ; inline
-: fuel-retort ( -- )
- error get fuel-eval-result get-global fuel-eval-output get-global
- 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
-
-: fuel-forget-error ( -- ) f error set-global ; inline
-: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
-: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
-: fuel-forget-status ( -- )
- fuel-forget-error fuel-forget-result fuel-forget-output ; inline
-
-: (fuel-begin-eval) ( -- )
- fuel-push-status fuel-forget-status ; inline
-
-: (fuel-end-eval) ( output -- )
- fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
-
-: (fuel-eval) ( lines -- )
- [ [ parse-lines ] with-compilation-unit call ] curry
- [ print-error ] recover ; inline
-
-: (fuel-eval-each) ( lines -- )
- [ 1vector (fuel-eval) ] each ; inline
-
-: (fuel-eval-usings) ( usings -- )
- [ "USING: " prepend " ;" append ] map
- (fuel-eval-each) fuel-forget-error fuel-forget-output ;
-
-: (fuel-eval-in) ( in -- )
- [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
-
-: fuel-eval-in-context ( lines in usings -- )
- (fuel-begin-eval)
- [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
- (fuel-end-eval) ;
+: fuel-retort ( -- ) fuel-send-retort ; inline
! Loading files
+<PRIVATE
+
SYMBOL: :uses
: fuel-set-use-hook ( -- )
[ amended-use get clone :uses prefix fuel-eval-set-result ]
print-use-hook set ;
+: (fuel-get-uses) ( lines -- )
+ [ parse-fresh drop ] curry with-compilation-unit ; inline
+
+PRIVATE>
+
: fuel-run-file ( path -- )
[ fuel-set-use-hook run-file ] curry with-scope ; inline
: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
-: (fuel-get-uses) ( lines -- )
- [ parse-fresh drop ] curry with-compilation-unit ; inline
-
: fuel-get-uses ( lines -- )
[ (fuel-get-uses) ] curry fuel-with-autouse ;
! Edit locations
+<PRIVATE
+
: fuel-normalize-loc ( seq -- path line )
[ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
-: fuel-get-edit-location ( word -- )
- where fuel-normalize-loc 2array fuel-eval-set-result ; inline
+: fuel-get-loc ( object -- )
+ fuel-normalize-loc 2array fuel-eval-set-result ;
+
+PRIVATE>
+
+: fuel-get-edit-location ( word -- ) where fuel-get-loc ; inline
: fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ; inline
-: fuel-get-doc-location ( word -- )
- props>> "help-loc" swap at
- fuel-normalize-loc 2array fuel-eval-set-result ;
+: fuel-get-doc-location ( word -- ) props>> "help-loc" swap at fuel-get-loc ;
-: fuel-get-article-location ( name -- )
- article loc>> fuel-normalize-loc 2array fuel-eval-set-result ;
+: fuel-get-article-location ( name -- ) article loc>> fuel-get-loc ;
! Cross-references
+<PRIVATE
+
: fuel-word>xref ( word -- xref )
[ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;
: fuel-format-xrefs ( seq -- seq' )
[ word? ] filter [ fuel-word>xref ] map ; inline
+: (fuel-index) ( seq -- seq )
+ [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
+
+PRIVATE>
+
: fuel-callers-xref ( word -- )
usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
: fuel-apropos-xref ( str -- )
words-matching fuel-format-xrefs fuel-eval-set-result ; inline
+: fuel-vocab-xref ( vocab -- )
+ words fuel-format-xrefs fuel-eval-set-result ; inline
+
+: fuel-index ( quot: ( -- seq ) -- )
+ call (fuel-index) fuel-eval-set-result ; inline
+
! Completion support
+<PRIVATE
+
: fuel-filter-prefix ( seq prefix -- seq )
[ drop-prefix nip length 0 = ] curry filter prune ; inline
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
-: fuel-get-vocabs ( -- )
- (fuel-get-vocabs) fuel-eval-set-result ; inline
-
-: fuel-get-vocabs/prefix ( prefix -- )
- (fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
-
-: fuel-vocab-summary ( name -- )
- >vocab-link summary fuel-eval-set-result ; inline
-
MEMO: (fuel-vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
swap fuel-filter-prefix ;
+PRIVATE>
+
+: fuel-get-vocabs ( -- )
+ (fuel-get-vocabs) fuel-eval-set-result ;
+
+: fuel-get-vocabs/prefix ( prefix -- )
+ (fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ;
+
: fuel-get-words ( prefix names -- )
- (fuel-get-words) fuel-eval-set-result ; inline
+ (fuel-get-words) fuel-eval-set-result ;
! Help support
-MEMO: fuel-articles-seq ( -- seq )
- articles get values ;
-
-: fuel-find-articles ( title -- seq )
- [ [ article-title ] dip = ] curry fuel-articles-seq swap filter ;
-
-MEMO: fuel-find-article ( title -- article/f )
- fuel-find-articles dup empty? [ drop f ] [ first ] if ;
-
-MEMO: fuel-article-title ( name -- title/f )
- articles get at [ article-title ] [ f ] if* ;
-
-: fuel-get-article ( name -- )
- article fuel-eval-set-result ;
-
-: fuel-value-str ( word -- str )
- [ pprint-short ] with-string-writer ; inline
-
-: fuel-definition-str ( word -- str )
- [ see ] with-string-writer ; inline
-
-: fuel-methods-str ( word -- str )
- methods dup empty? not [
- [ [ see nl ] each ] with-string-writer
- ] [ drop f ] if ; inline
-
-: fuel-related-words ( word -- seq )
- dup "related" word-prop remove ; inline
-
-: fuel-parent-topics ( word -- seq )
- help-path [ dup article-title swap 2array ] map ; inline
-
-: (fuel-word-help) ( word -- element )
- \ article swap dup article-title swap
- [
- {
- [ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
- [ \ $vocabulary swap vocabulary>> 2array , ]
- [ word-help % ]
- [ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
- [ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
- [ \ $definition swap fuel-definition-str 2array , ]
- [ fuel-methods-str [ \ $methods swap 2array , ] when* ]
- } cleave
- ] { } make 3array ;
-
-MEMO: fuel-find-word ( name -- word/f )
- [ [ name>> ] dip = ] curry all-words swap filter
- dup empty? not [ first ] [ drop f ] if ;
-
-: fuel-word-help ( name -- )
- fuel-find-word [ [ auto-use? on (fuel-word-help) ] with-scope ] [ f ] if*
- fuel-eval-set-result ; inline
-
-: (fuel-word-see) ( word -- elem )
- [ name>> \ article swap ]
- [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
-
-: fuel-word-see ( name -- )
- fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if*
- fuel-eval-set-result ; inline
-
-: fuel-vocab-help-row ( vocab -- element )
- [ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
-
-: fuel-vocab-help-root-heading ( root -- element )
- [ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
-
-SYMBOL: vocab-list
-
-: fuel-vocab-help-table ( vocabs -- element )
- [ fuel-vocab-help-row ] map vocab-list prefix ;
-
-: fuel-vocab-list ( assoc -- seq )
- [
- [ drop f ] [
- [ fuel-vocab-help-root-heading ]
- [ fuel-vocab-help-table ] bi*
- [ 2array ] [ drop f ] if*
- ] if-empty
- ] { } assoc>map [ ] filter ;
-
-: fuel-vocab-children-help ( name -- element )
- all-child-vocabs fuel-vocab-list ; inline
-
-: fuel-vocab-describe-words ( name -- element )
- [ describe-words ] with-string-writer \ describe-words swap 2array ; inline
-
-: (fuel-vocab-help) ( name -- element )
- \ article swap dup >vocab-link
- [
- {
- [ vocab-authors [ \ $authors prefix , ] when* ]
- [ vocab-tags [ \ $tags prefix , ] when* ]
- [ summary [ { $heading "Summary" } swap 2array , ] when* ]
- [ drop \ $nl , ]
- [ vocab-help [ article content>> % ] when* ]
- [ name>> fuel-vocab-describe-words , ]
- [ name>> fuel-vocab-children-help % ]
- } cleave
- ] { } make 3array ;
-
-: fuel-vocab-help ( name -- )
- dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-help) ] if
- fuel-eval-set-result ; inline
+: fuel-get-article ( name -- ) article fuel-eval-set-result ;
-: (fuel-index) ( seq -- seq )
- [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
+MEMO: fuel-get-article-title ( name -- )
+ articles get at [ article-title ] [ f ] if* fuel-eval-set-result ;
-: fuel-index ( quot: ( -- seq ) -- )
- call (fuel-index) fuel-eval-set-result ; inline
+: fuel-word-help ( name -- ) (fuel-word-help) fuel-eval-set-result ;
-MEMO: (fuel-get-vocabs/author) ( author -- element )
- [ "Vocabularies by " prepend \ $heading swap 2array ]
- [ authored fuel-vocab-list ] bi 2array ;
+: fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ;
-: fuel-get-vocabs/author ( author -- )
- (fuel-get-vocabs/author) fuel-eval-set-result ;
+: fuel-word-def ( name -- ) (fuel-word-def) fuel-eval-set-result ;
+
+: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
-MEMO: (fuel-get-vocabs/tag ( tag -- element )
- [ "Vocabularies tagged " prepend \ $heading swap 2array ]
- [ tagged fuel-vocab-list ] bi 2array ;
+: fuel-vocab-summary ( name -- )
+ (fuel-vocab-summary) fuel-eval-set-result ;
: fuel-get-vocabs/tag ( tag -- )
- (fuel-get-vocabs/tag fuel-eval-set-result ;
+ (fuel-get-vocabs/tag) fuel-eval-set-result ;
+
+: fuel-get-vocabs/author ( author -- )
+ (fuel-get-vocabs/author) fuel-eval-set-result ;
+
+! Scaffold support
+: fuel-scaffold-vocab ( root name devname -- )
+ developer-name set dup [ scaffold-vocab ] dip
+ dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
-! -run=fuel support
+: fuel-scaffold-help ( name devname -- )
+ developer-name set
+ dup require dup scaffold-help vocab-docs-path
+ (normalize-path) fuel-eval-set-result ;
-: fuel-startup ( -- ) "listener" run-file ; inline
+: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
-MAIN: fuel-startup
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fuel.help ;
+IN: fuel.help.tests
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors arrays assocs combinators help help.crossref
+help.markup help.topics io io.streams.string kernel make memoize
+namespaces parser prettyprint sequences summary tools.vocabs
+tools.vocabs.browser vocabs vocabs.loader words ;
+
+IN: fuel.help
+
+<PRIVATE
+
+MEMO: fuel-find-word ( name -- word/f )
+ [ [ name>> ] dip = ] curry all-words swap filter
+ dup empty? not [ first ] [ drop f ] if ;
+
+: fuel-value-str ( word -- str )
+ [ pprint-short ] with-string-writer ; inline
+
+: fuel-definition-str ( word -- str )
+ [ see ] with-string-writer ; inline
+
+: fuel-methods-str ( word -- str )
+ methods dup empty? not [
+ [ [ see nl ] each ] with-string-writer
+ ] [ drop f ] if ; inline
+
+: fuel-related-words ( word -- seq )
+ dup "related" word-prop remove ; inline
+
+: fuel-parent-topics ( word -- seq )
+ help-path [ dup article-title swap 2array ] map ; inline
+
+: (fuel-word-element) ( word -- element )
+ \ article swap dup article-title swap
+ [
+ {
+ [ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
+ [ \ $vocabulary swap vocabulary>> 2array , ]
+ [ word-help % ]
+ [ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
+ [ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
+ [ \ $definition swap fuel-definition-str 2array , ]
+ [ fuel-methods-str [ \ $methods swap 2array , ] when* ]
+ } cleave
+ ] { } make 3array ;
+
+: fuel-vocab-help-row ( vocab -- element )
+ [ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ;
+
+: fuel-vocab-help-root-heading ( root -- element )
+ [ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ;
+
+SYMBOL: vocab-list
+
+: fuel-vocab-help-table ( vocabs -- element )
+ [ fuel-vocab-help-row ] map vocab-list prefix ;
+
+: fuel-vocab-list ( assoc -- seq )
+ [
+ [ drop f ] [
+ [ fuel-vocab-help-root-heading ]
+ [ fuel-vocab-help-table ] bi*
+ [ 2array ] [ drop f ] if*
+ ] if-empty
+ ] { } assoc>map [ ] filter ;
+
+: fuel-vocab-children-help ( name -- element )
+ all-child-vocabs fuel-vocab-list ; inline
+
+: fuel-vocab-describe-words ( name -- element )
+ [ describe-words ] with-string-writer \ describe-words swap 2array ; inline
+
+: (fuel-vocab-element) ( name -- element )
+ dup require \ article swap dup >vocab-link
+ [
+ {
+ [ vocab-authors [ \ $authors prefix , ] when* ]
+ [ vocab-tags [ \ $tags prefix , ] when* ]
+ [ summary [ { $heading "Summary" } swap 2array , ] when* ]
+ [ drop \ $nl , ]
+ [ vocab-help [ article content>> % ] when* ]
+ [ name>> fuel-vocab-describe-words , ]
+ [ name>> fuel-vocab-children-help % ]
+ } cleave
+ ] { } make 3array ;
+
+PRIVATE>
+
+: (fuel-word-help) ( name -- elem )
+ fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
+
+: (fuel-word-see) ( word -- elem )
+ [ name>> \ article swap ]
+ [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
+
+: (fuel-word-def) ( name -- str )
+ fuel-find-word [ [ def>> pprint ] with-string-writer ] [ f ] if* ; inline
+
+: (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline
+
+: (fuel-vocab-help) ( name -- str )
+ dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-element) ] if ;
+
+MEMO: (fuel-get-vocabs/author) ( author -- element )
+ [ "Vocabularies by " prepend \ $heading swap 2array ]
+ [ authored fuel-vocab-list ] bi 2array ;
+
+MEMO: (fuel-get-vocabs/tag) ( tag -- element )
+ [ "Vocabularies tagged " prepend \ $heading swap 2array ]
+ [ tagged fuel-vocab-list ] bi 2array ;
--- /dev/null
+Jose Antonio Ortega Ruiz
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fuel.pprint ;
+IN: fuel.pprint.tests
--- /dev/null
+! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors arrays classes.tuple combinators continuations io
+kernel lexer math prettyprint quotations sequences source-files
+strings words ;
+
+IN: fuel.pprint
+
+GENERIC: fuel-pprint ( obj -- )
+
+<PRIVATE
+
+: fuel-maybe-scape ( ch -- seq )
+ dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
+
+SYMBOL: :restarts
+
+: fuel-restarts ( obj -- seq )
+ compute-restarts :restarts prefix ; inline
+
+: fuel-pprint-sequence ( seq open close -- )
+ [ write ] dip swap [ " " write ] [ fuel-pprint ] interleave write ; inline
+
+PRIVATE>
+
+M: object fuel-pprint pprint ; inline
+
+M: word fuel-pprint
+ name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
+
+M: f fuel-pprint drop "nil" write ; inline
+
+M: integer fuel-pprint pprint ; inline
+
+M: string fuel-pprint pprint ; inline
+
+M: sequence fuel-pprint "(" ")" fuel-pprint-sequence ; inline
+
+M: quotation fuel-pprint "[" "]" fuel-pprint-sequence ; inline
+
+M: tuple fuel-pprint tuple>array fuel-pprint ; inline
+
+M: continuation fuel-pprint drop ":continuation" write ; inline
+
+M: restart fuel-pprint name>> fuel-pprint ; inline
+
+M: condition fuel-pprint
+ [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
+
+M: lexer-error fuel-pprint
+ {
+ [ line>> ]
+ [ column>> ]
+ [ line-text>> ]
+ [ fuel-restarts ]
+ } cleave 4array lexer-error prefix fuel-pprint ;
+
+M: source-file-error fuel-pprint
+ [ file>> ] [ error>> ] bi 2array source-file-error prefix
+ fuel-pprint ;
+
+M: source-file fuel-pprint path>> fuel-pprint ;
io.pathnames io.encodings.ascii io.streams.string http.client
generalizations combinators math.parser math.vectors
math.intervals interval-maps memoize csv accessors assocs
-strings math splitting grouping arrays ;
+strings math splitting grouping arrays combinators.smart ;
IN: geo-ip
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
TUPLE: ip-entry from to registry assigned city cntry country ;
: parse-ip-entry ( row -- ip-entry )
- 7 firstn {
- [ string>number ]
- [ string>number ]
- [ ]
- [ ]
- [ ]
- [ ]
- [ ]
- } spread ip-entry boa ;
+ [
+ {
+ [ string>number ]
+ [ string>number ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ } spread
+ ] input<sequence ip-entry boa ;
MEMO: ip-db ( -- seq )
download-db ascii file-lines
--- /dev/null
+
+USING: accessors combinators.cleave combinators.short-circuit
+concurrency.combinators destructors fry io io.directories
+io.encodings io.encodings.utf8 io.launcher io.monitors
+io.pathnames io.pipes io.ports kernel locals math namespaces
+sequences splitting strings threads ui ui.gadgets
+ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.tracks ;
+
+IN: git-tool
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
+
+: tail** ( seq obj -- seq/f )
+ dup number?
+ [ tail ]
+ [ dupd find drop [ tail ] [ drop f ] if* ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: <process-stdout-stderr-reader> ( DESC -- process stream stream )
+ [
+ [let | STDOUT-PIPE [ (pipe) |dispose ]
+ STDERR-PIPE [ (pipe) |dispose ] |
+
+ [let | PROCESS [ DESC >process ] |
+
+ PROCESS
+ [ STDOUT-PIPE out>> or ] change-stdout
+ [ STDERR-PIPE out>> or ] change-stderr
+ run-detached
+
+ STDOUT-PIPE out>> dispose
+ STDERR-PIPE out>> dispose
+
+ STDOUT-PIPE in>> <input-port> utf8 <decoder>
+ STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
+ ]
+ with-destructors ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-process/result ( desc -- process )
+ <process-stdout-stderr-reader>
+ {
+ [ contents [ string-lines ] [ f ] if* ]
+ [ contents [ string-lines ] [ f ] if* ]
+ }
+ parallel-spread
+ [ >>stdout ] [ >>stderr ] bi*
+ dup wait-for-process >>status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! process popup windows
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: popup-window ( title contents -- )
+ dup string? [ ] [ "\n" join ] if
+ <editor> tuck set-editor-string swap open-window ;
+
+: popup-process-window ( process -- )
+ [ stdout>> [ "output" swap popup-window ] when* ]
+ [ stderr>> [ "error" swap popup-window ] when* ]
+ [
+ [ stdout>> ] [ stderr>> ] bi or not
+ [ "Process" "NO OUTPUT" popup-window ]
+ when
+ ]
+ tri ;
+
+: popup-if-error ( process -- )
+ { [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-process ( REPO DESC -- process )
+ REPO [ DESC run-process/result ] with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-status-section ( lines section -- lines/f )
+ '[ _ = ] tail**
+ [
+ [ "#\t" head? ] tail**
+ [ "#\t" head? not ] head**
+ [ 2 tail ] map
+ ]
+ [ f ]
+ if* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: colon ( -- ch ) CHAR: : ;
+: space ( -- ch ) 32 ;
+
+: git-status-line-file ( line -- file )
+ { [ colon = ] 1 [ space = not ] } [ tail** ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <git-status>
+ repository
+ to-commit-new
+ to-commit-modified
+ to-commit-deleted
+ modified
+ deleted
+ untracked ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-git-status ( STATUS -- STATUS )
+
+ [let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
+
+ STATUS
+
+ LINES "# Changes to be committed:" git-status-section
+ [ "new file:" head? ] filter
+ [ git-status-line-file ] map
+ check-empty
+ >>to-commit-new
+
+ LINES "# Changes to be committed:" git-status-section
+ [ "modified:" head? ] filter
+ [ git-status-line-file ] map
+ check-empty
+ >>to-commit-modified
+
+ LINES "# Changes to be committed:" git-status-section
+ [ "deleted:" head? ] filter
+ [ git-status-line-file ] map
+ check-empty
+ >>to-commit-deleted
+
+ LINES "# Changed but not updated:" git-status-section
+ [ "modified:" head? ] filter
+ [ git-status-line-file ] map
+ check-empty
+ >>modified
+
+ LINES "# Changed but not updated:" git-status-section
+ [ "deleted:" head? ] filter
+ [ git-status-line-file ] map
+ check-empty
+ >>deleted
+
+ LINES "# Untracked files:" git-status-section >>untracked ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-status ( REPO -- <git-status> )
+
+ <git-status> new REPO >>repository refresh-git-status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: factor-git-status ( -- <git-status> ) "resource:" git-status ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! git-tool
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: to-commit ( <git-status> -- seq )
+ { to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-status-pile ( STATUS PILE -- )
+
+ STATUS refresh-git-status drop
+
+ PILE clear-gadget
+
+ PILE
+
+ ! Commit section
+
+ [wlet | add-commit-path-button [| TEXT PATH |
+
+ { 1 0 } <track>
+
+ TEXT <label> 2/8 track-add
+ PATH <label> 6/8 track-add
+
+ "Reset"
+ [
+ drop
+
+ STATUS repository>>
+ { "git" "reset" "HEAD" PATH }
+ git-process
+ drop
+
+ STATUS PILE refresh-status-pile
+ ]
+ <bevel-button> f track-add
+
+ add-gadget ] |
+
+ STATUS to-commit
+ [
+ "Changes to be committed" <label> reverse-video-theme add-gadget
+
+ STATUS to-commit-new>>
+ [| PATH | "new file: " PATH add-commit-path-button ]
+ each
+
+ STATUS to-commit-modified>>
+ [| PATH | "modified: " PATH add-commit-path-button ]
+ each
+
+ STATUS to-commit-deleted>>
+ [| PATH | "deleted: " PATH add-commit-path-button ]
+ each
+
+ <pile> 1 >>fill
+
+ [let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
+
+ EDITOR add-gadget
+
+ "Commit"
+ [
+ drop
+ [let | MSG [ EDITOR editor-string ] |
+
+ STATUS repository>>
+ { "git" "commit" "-m" MSG } git-process
+ popup-if-error ]
+ STATUS PILE refresh-status-pile
+ ]
+ <bevel-button>
+ add-gadget ]
+
+ add-gadget
+
+ ]
+ when ]
+
+ ! Modified section
+
+ STATUS modified>>
+ [
+ "Modified but not updated" <label> reverse-video-theme add-gadget
+
+ STATUS modified>>
+ [| PATH |
+
+ <shelf>
+
+ PATH <label> add-gadget
+
+ "Add"
+ [
+ drop
+ STATUS repository>> { "git" "add" PATH } git-process popup-if-error
+ STATUS PILE refresh-status-pile
+ ]
+ <bevel-button> add-gadget
+
+ "Diff"
+ [
+ drop
+ STATUS repository>> { "git" "diff" PATH } git-process
+ popup-process-window
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ]
+ each
+
+ ]
+ when
+
+ ! Untracked section
+
+ STATUS untracked>>
+ [
+ "Untracked files" <label> reverse-video-theme add-gadget
+
+ STATUS untracked>>
+ [| PATH |
+
+ { 1 0 } <track>
+
+ PATH <label> f track-add
+
+ "Add"
+ [
+ drop
+ STATUS repository>> { "git" "add" PATH } git-process popup-if-error
+ STATUS PILE refresh-status-pile
+ ]
+ <bevel-button> f track-add
+
+ add-gadget
+
+ ]
+ each
+
+ ]
+ when
+
+ ! Refresh button
+
+ "Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-remote-branches ( REPO NAME -- seq )
+ REPO { "git" "remote" "show" NAME } git-process stdout>>
+ " Tracked remote branches" over index 1 + tail first " " split
+ [ empty? not ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-remotes-pile ( REPO PILE -- )
+
+ PILE clear-gadget
+
+ PILE
+
+ "Remotes" <label> reverse-video-theme add-gadget
+
+ REPO { "git" "remote" } git-process stdout>> [ empty? not ] filter
+
+ [| NAME |
+
+ [let | BRANCH! [ "master" ] |
+
+ { 1 0 } <track>
+
+ NAME <label> 1 track-add
+
+ [let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
+
+ BRANCH-BUTTON
+ [
+ drop
+
+ <pile>
+
+ 1 >>fill
+
+ REPO NAME git-remote-branches
+ [| OTHER-BRANCH |
+ OTHER-BRANCH
+ [
+ drop
+
+ OTHER-BRANCH BRANCH!
+
+ OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
+
+ ]
+ <bevel-button>
+ add-gadget
+ ]
+ each
+
+ "Select a branch" open-window
+ ]
+ >>quot
+
+ 1 track-add ]
+
+ "Fetch"
+ [ drop REPO { "git" "fetch" NAME } git-process popup-process-window ]
+ <bevel-button>
+ 1 track-add
+
+ "..remote/branch"
+ [
+ drop
+ [let | ARG [ { ".." NAME "/" BRANCH } concat ] |
+ REPO { "git" "log" ARG } git-process popup-process-window ]
+ ]
+ <bevel-button>
+ 1 track-add
+
+ "Merge"
+ [
+ drop
+ [let | ARG [ { NAME "/" BRANCH } concat ] |
+ REPO { "git" "merge" ARG } git-process popup-process-window ]
+ ]
+ <bevel-button>
+ 1 track-add
+
+ "remote/branch.."
+ [
+ drop
+ [let | ARG [ { NAME "/" BRANCH ".." } concat ] |
+ REPO { "git" "log" ARG } git-process popup-process-window ]
+ ]
+ <bevel-button>
+ 1 track-add
+
+ "Push"
+ [
+ drop
+ REPO { "git" "push" NAME "master" } git-process popup-process-window
+ ]
+ <bevel-button>
+ 1 track-add
+
+ add-gadget ]
+
+ ]
+ each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-tool ( REPO -- )
+
+ <pile> 1 >>fill
+
+ "Repository: " REPO [ current-directory get ] with-directory append
+ <label>
+ add-gadget
+
+ [let | STATUS [ REPO git-status ]
+ PILE [ <pile> 1 >>fill ] |
+
+ [
+ [
+ [let | MONITOR [ REPO t <monitor> ] |
+ [
+ [let | PATH [ MONITOR next-change drop ] |
+ ".git" PATH subseq? ! Ignore git internal operations
+ [ ]
+ [ STATUS PILE refresh-status-pile ]
+ if
+ t ]
+ ]
+ loop
+ ]
+ ]
+ with-monitors
+ ]
+ in-thread
+
+ STATUS PILE refresh-status-pile
+
+ PILE add-gadget ]
+
+ REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
+
+ "Git" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: factor-git-tool ( -- ) "resource:" git-tool ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: accessors calendar git-tool git-tool io.directories
+io.monitors io.pathnames kernel locals math namespaces
+sequences splitting system threads ui ui.gadgets
+ui.gadgets.buttons ui.gadgets.labels ui.gadgets.packs ;
+
+USING: git-tool ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: git-tool.remote
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <git-remote-gadget> < pack
+ repository
+ branch
+ remote
+ remote-branch
+ fetch-period
+ push
+ closed
+ last-refresh ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: current-branch ( REPO -- branch )
+ { "git" "branch" } git-process stdout>> [ "* " head? ] find nip 2 tail ;
+
+: list-branches ( REPO -- branches )
+ { "git" "branch" } git-process stdout>>
+ [ empty? not ] filter
+ [ 2 tail ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: list-remotes ( REPO -- remotes )
+ { "git" "remote" } git-process stdout>> [ empty? not ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: list-remote-branches ( REPO REMOTE -- branches )
+ [let | OUT [ REPO { "git" "remote" "show" REMOTE } git-process stdout>> ] |
+
+ " Tracked remote branches" OUT member?
+ [
+ OUT
+ " Tracked remote branches" OUT index 1 + tail first " " split
+ [ empty? not ] filter
+ ]
+ [
+ OUT
+ OUT [ " New remote branches" head? ] find drop
+ 1 + tail first " " split
+ [ empty? not ] filter
+ ]
+ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: refresh-git-remote-gadget ( GADGET -- )
+
+ [let | REPO [ GADGET repository>> ] |
+
+ GADGET clear-gadget
+
+ GADGET
+
+ ! Repository label
+
+ "Repository: " REPO [ current-directory get ] with-directory append
+ <label>
+ add-gadget
+
+ ! Branch button
+
+ <shelf>
+
+ "Branch: " <label> add-gadget
+
+ REPO current-branch
+ [
+ drop
+
+ <pile>
+ REPO list-branches
+
+ [| BRANCH |
+
+ BRANCH
+ [
+ drop
+ REPO { "git" "checkout" BRANCH } git-process popup-if-error
+ GADGET refresh-git-remote-gadget
+ ]
+ <bevel-button> add-gadget
+
+ ]
+ each
+
+ "Select a branch" open-window
+
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ! Remote button
+
+ <shelf>
+
+ "Remote: " <label> add-gadget
+
+ GADGET remote>>
+ [
+ drop
+
+ <pile>
+
+ REPO list-remotes
+
+ [| REMOTE |
+
+ REMOTE
+ [
+ drop
+ GADGET REMOTE >>remote drop
+ GADGET "master" >>remote-branch drop
+ GADGET refresh-git-remote-gadget
+ ]
+ <bevel-button> add-gadget
+
+ ]
+ each
+
+ "Select a remote" open-window
+
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ! Remote branch button
+
+ <shelf>
+
+ "Remote branch: " <label> add-gadget
+
+ GADGET remote-branch>>
+ [
+ drop
+
+ <pile>
+
+ REPO GADGET remote>> list-remote-branches
+
+ [| REMOTE-BRANCH |
+
+ REMOTE-BRANCH
+ [
+ drop
+ GADGET REMOTE-BRANCH >>remote-branch drop
+ GADGET refresh-git-remote-gadget
+ ]
+ <bevel-button> add-gadget
+ ]
+
+ each
+
+ "Select a remote branch" open-window
+
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ! Fetch button
+
+ "Fetch"
+ [
+ drop
+ [let | REMOTE [ GADGET remote>> ] |
+ REPO { "git" "fetch" REMOTE } git-process popup-if-error ]
+
+ GADGET refresh-git-remote-gadget
+ ]
+ <bevel-button> add-gadget
+
+ ! Available changes
+
+ [let | REMOTE [ GADGET remote>> ]
+ REMOTE-BRANCH [ GADGET remote-branch>> ] |
+
+ [let | ARG [ { ".." REMOTE "/" REMOTE-BRANCH } concat ] |
+
+ [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
+
+ PROCESS stdout>>
+ [
+ <shelf>
+
+ "Changes available:" <label> add-gadget
+
+ "View"
+ [
+ drop
+ PROCESS popup-process-window
+ ]
+ <bevel-button> add-gadget
+
+ "Merge"
+ [
+ drop
+
+ [let | ARG [ { REMOTE "/" REMOTE-BRANCH } concat ] |
+
+ REPO { "git" "merge" ARG } git-process popup-process-window
+
+ ]
+
+ GADGET refresh-git-remote-gadget
+
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ]
+ when
+
+ ] ] ]
+
+
+ ! Pushable changes
+
+ [let | REMOTE [ GADGET remote>> ]
+ REMOTE-BRANCH [ GADGET remote-branch>> ] |
+
+ [let | ARG [ { REMOTE "/" REMOTE-BRANCH ".." } concat ] |
+
+ [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
+
+ PROCESS stdout>>
+ [
+ <shelf>
+
+ "Pushable changes: " <label> add-gadget
+
+ "View"
+ [
+ drop
+ PROCESS popup-process-window
+ ]
+ <bevel-button> add-gadget
+
+ "Push"
+ [
+ drop
+
+ REPO { "git" "push" REMOTE REMOTE-BRANCH }
+ git-process
+ popup-process-window
+
+ GADGET refresh-git-remote-gadget
+
+ ]
+ <bevel-button> add-gadget
+
+ add-gadget
+
+ ]
+ when
+
+ ] ] ]
+
+ drop
+
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-fetch-thread ( GADGET -- )
+
+ GADGET f >>closed drop
+
+ [
+
+ [
+
+ GADGET closed>>
+ [ f ]
+ [
+ [let | REPO [ GADGET repository>> ]
+ REMOTE-BRANCH [ GADGET remote-branch>> ] |
+
+ REPO { "git" "fetch" REMOTE-BRANCH } git-process drop ]
+
+ GADGET fetch-period>> sleep
+
+ t
+ ]
+ if
+
+
+ ]
+ loop
+
+ ]
+
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-monitor-thread ( GADGET -- )
+
+ GADGET f >>closed drop
+
+ [
+ [
+ [let | MONITOR [ GADGET repository>> t <monitor> ] |
+
+ [
+ GADGET closed>>
+ [ f ]
+ [
+
+ [let | PATH [ MONITOR next-change drop ] |
+
+ ".git" PATH subseq?
+ [ ]
+ [
+ micros
+ GADGET last-refresh>> 0 or -
+ 1000000 >
+ [
+ GADGET micros >>last-refresh drop
+ GADGET refresh-git-remote-gadget
+ ]
+ when
+ ]
+ if ]
+
+ t
+
+ ]
+ if
+ ]
+ loop
+ ]
+ ]
+ with-monitors
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <git-remote-gadget> pref-dim* ( gadget -- dim ) drop { 500 500 } ;
+
+M:: <git-remote-gadget> graft* ( GADGET -- )
+ GADGET start-fetch-thread
+ GADGET start-monitor-thread ;
+
+M:: <git-remote-gadget> ungraft* ( GADGET -- ) GADGET t >>closed drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: git-remote-tool ( REPO -- )
+
+ <git-remote-gadget> new-gadget
+
+ { 0 1 } >>orientation
+ 1 >>fill
+
+ REPO >>repository
+
+ "origin" >>remote
+
+ "master" >>remote-branch
+
+ 5 minutes >>fetch-period
+
+ dup refresh-git-remote-gadget
+
+ "git-remote-tool" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: factor-git-remote-tool ( -- ) "resource:" git-remote-tool ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: factor-git-remote-tool
\ No newline at end of file
HELP: define-inverse
{ $values { "word" "a word" } { "quot" "the inverse" } }
{ $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." }
-{ $see-also define-pop-inverse } ;
+{ $see-also define-dual define-involution define-pop-inverse } ;
+
+HELP: define-dual
+{ $values { "word1" "a word" } { "word2" "a word" } }
+{ $description "Defines the inverse of each word as being the other one." }
+{ $see-also define-inverse define-involution } ;
+
+HELP: define-involution
+{ $values { "word" "a word" } }
+{ $description "Defines a word as being its own inverse." }
+{ $see-also define-dual define-inverse } ;
HELP: define-pop-inverse
{ $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } }
[ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
[ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
[ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail
+
+[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test
+[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
+[ [ not ] ] [ [ not ] [undo] ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test
: define-inverse ( word quot -- ) "inverse" set-word-prop ;
+: define-dual ( word1 word2 -- )
+ 2dup swap [ 1quotation define-inverse ] 2bi@ ;
+
+: define-involution ( word -- ) dup 1quotation define-inverse ;
+
: define-math-inverse ( word quot1 quot2 -- )
pick 1quotation 3array "math-inverse" set-word-prop ;
! Inverse of selected words
-\ swap [ swap ] define-inverse
+\ swap define-involution
\ dup [ [ =/fail ] keep ] define-inverse
\ 2dup [ over =/fail over =/fail ] define-inverse
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
\ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
-\ not [ not ] define-inverse
+\ not define-involution
\ >boolean [ { t f } memq? assure ] define-inverse
-\ tuple>array [ >tuple ] define-inverse
-\ >tuple [ tuple>array ] define-inverse
-\ reverse [ reverse ] define-inverse
+\ tuple>array \ >tuple define-dual
+\ reverse define-involution
\ undo 1 [ [ call ] curry ] define-pop-inverse
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
-\ exp [ log ] define-inverse
-\ log [ exp ] define-inverse
-\ not [ not ] define-inverse
-\ sq [ sqrt ] define-inverse
-\ sqrt [ sq ] define-inverse
+\ exp \ log define-dual
+\ sq \ sqrt define-dual
ERROR: missing-literal ;
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
-\ prefix [ unclip ] define-inverse
-\ unclip [ prefix ] define-inverse
+\ prefix \ unclip define-dual
\ suffix [ dup but-last swap peek ] define-inverse
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
namespaces parser lexer parser-combinators
parser-combinators.simple promises quotations sequences strings
math.order assocs prettyprint.backend prettyprint.custom memoize
-unicode.case unicode.categories combinators.short-circuit
+ascii unicode.categories combinators.short-circuit
accessors make io ;
IN: parser-combinators.regexp
{
{ [ os unix? ] [ "serial.unix" ] }
+ { [ os windows? ] [ "serial.windows" ] }
} cond require
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test serial.windows ;
+IN: serial.windows.tests
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files.windows io.streams.duplex kernel math
+math.bitwise windows.kernel32 accessors alien.c-types
+windows io.files.windows fry locals continuations ;
+IN: serial.windows
+
+: <serial-stream> ( path encoding -- duplex )
+ [ open-r/w dup ] dip <encoder-duplex> ;
+
+: get-comm-state ( duplex -- dcb )
+ in>> handle>>
+ "DCB" <c-object> tuck
+ GetCommState win32-error=0/f ;
+
+: set-comm-state ( duplex dcb -- )
+ [ in>> handle>> ] dip
+ SetCommState win32-error=0/f ;
+
+:: with-comm-state ( duplex quot: ( dcb -- ) -- )
+ duplex get-comm-state :> dcb
+ dcb clone quot curry [ dcb set-comm-state ] recover ; inline
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel tools.test usa-cities ;
+IN: usa-cities.tests
+
+[ t ] [ 55406 find-zip-code name>> "Minneapolis" = ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv summary
-words accessors math.order binary-search ;
+words accessors math.order binary-search combinators.smart ;
IN: usa-cities
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
MEMO: cities ( -- seq )
"resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
csv rest-slice [
- 7 firstn {
- [ string>number ]
- [ ]
- [ string>state ]
- [ string>number ]
- [ string>number ]
- [ string>number ]
- [ string>number ]
- } spread city boa
+ [
+ {
+ [ string>number ]
+ [ ]
+ [ string>state ]
+ [ string>number ]
+ [ string>number ]
+ [ string>number ]
+ [ string>number ]
+ } spread
+ ] input<sequence city boa
] map ;
MEMO: cities-named ( name -- cities )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: furnace.actions furnace.redirection
+USING: furnace furnace.actions furnace.redirection
http.server.dispatchers html.forms validators urls accessors
math ;
IN: webapps.calculator
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
<head> <title>Calculator</title> </head>
<body>
</t:form>
</body>
+</html>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
+<html>
<body>
<h1><t:label t:name="counter" /></h1>
<t:button t:action="$counter-app/inc">++</t:button>
<t:button t:action="$counter-app/dec">--</t:button>
</body>
+</html>
</t:chloe>
+++ /dev/null
-" Vim syntax file
-" Language: factor
-" Maintainer: Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2008 Apr 28
-
-" For version 5.x: Clear all syntax items
-" For version 6.x: Quit when a syntax file was already loaded
-if version < 600
- syntax clear
-elseif exists("b:current_syntax")
- finish
-endif
-
-" factor is case sensitive.
-syn case match
-
-" make all of these characters part of a word (useful for skipping over words with w, e, and b)
-if version >= 600
- setlocal iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
-else
- set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
-endif
-
-syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
-
-syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
-syn match factorComment /\<#! .*/ contains=factorTodo
-syn match factorComment /\<! .*/ contains=factorTodo
-
-syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
-
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
-syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
-syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
-syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
-syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
-syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
-syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-
-syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
-
-
-syn keyword factorBoolean boolean f general-t t
-syn keyword factorCompileDirective inline foldable parsing
-
-
-
-" kernel vocab keywords
-syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple
-syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
-syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot
-syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f
-syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
-syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
-syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
-syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
-syn keyword factorKeyword resize-string >string <string> 1string string string?
-syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
-syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts
-
-
-syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
-syn cluster factorNumber contains=@factorReal,factorComplex
-syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match factorInt /\<-\=\d\+\>/
-syn match factorFloat /\<-\=\d*\.\d\+\>/
-syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
-syn region factorComplex start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
-syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
-syn match factorBinary /\<BIN:\s\+[01]\+\>/
-syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
-syn match factorHex /\<HEX:\s\+\x\+\>/
-syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
-syn match factorOctal /\<OCT:\s\+\o\+\>/
-
-syn match factorIn /\<IN:\s\+\S\+\>/
-syn match factorUse /\<USE:\s\+\S\+\>/
-
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
-
-syn match factorBackslash /\<\\\>\s\+\S\+\>/
-
-syn region factorUsing start=/\<USING:\>/ end=/;/
-syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
-
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
-syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
-syn match factorDefer /\<DEFER:\s\+\S\+\>/
-syn match factorForget /\<FORGET:\s\+\S\+\>/
-syn match factorMixin /\<MIXIN:\s\+\S\+\>/
-syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
-syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
-syn match factorMain /\<MAIN:\s\+\S\+\>/
-syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
-
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-
-syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
-
-"TODO:
-"misc:
-" HELP:
-" ARTICLE:
-"literals:
-" PRIMITIVE:
-
-"C interface:
-" FIELD:
-" BEGIN-STRUCT:
-" C-ENUM:
-" FUNCTION:
-" END-STRUCT
-" DLL"
-" TYPEDEF:
-" LIBRARY:
-" C-UNION:
-
-syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
-syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
-
-syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
-syn match factorMultiStringContents /.*/ contained
-
-"syn match factorStackEffectErr /\<)\>/
-"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
-syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
-
-"adapted from lisp.vim
-if exists("g:factor_norainbow")
- syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
-else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
-endif
-
-if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
-else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
-endif
-
-syn match factorBracketErr /\<\]\>/
-syn match factorBracketErr /\<}\>/
-
-syn sync lines=100
-
-if version >= 508 || !exists("did_factor_syn_inits")
- if version <= 508
- let did_factor_syn_inits = 1
- command -nargs=+ HiLink hi link <args>
- else
- command -nargs=+ HiLink hi def link <args>
- endif
-
- HiLink factorComment Comment
- HiLink factorStackEffect Typedef
- HiLink factorTodo Todo
- HiLink factorInclude Include
- HiLink factorRepeat Repeat
- HiLink factorConditional Conditional
- HiLink factorKeyword Keyword
- HiLink factorOperator Operator
- HiLink factorBoolean Boolean
- HiLink factorDefnDelims Typedef
- HiLink factorMethodDelims Typedef
- HiLink factorGenericDelims Typedef
- HiLink factorGenericNDelims Typedef
- HiLink factorConstructor Typedef
- HiLink factorPrivate Special
- HiLink factorPrivateDefnDelims Special
- HiLink factorPrivateMethodDelims Special
- HiLink factorPGenericDelims Special
- HiLink factorPGenericNDelims Special
- HiLink factorString String
- HiLink factorSbuf String
- HiLink factorMultiStringContents String
- HiLink factorMultiStringDelims Typedef
- HiLink factorBracketErr Error
- HiLink factorComplex Number
- HiLink factorRatio Number
- HiLink factorBinary Number
- HiLink factorBinErr Error
- HiLink factorHex Number
- HiLink factorHexErr Error
- HiLink factorOctal Number
- HiLink factorOctErr Error
- HiLink factorFloat Float
- HiLink factorInt Number
- HiLink factorUsing Include
- HiLink factorUse Include
- HiLink factorRequires Include
- HiLink factorIn Define
- HiLink factorChar Character
- HiLink factorCharErr Error
- HiLink factorDelimiter Delimiter
- HiLink factorBackslash Special
- HiLink factorCompileDirective Typedef
- HiLink factorSymbol Define
- HiLink factorMixin Typedef
- HiLink factorInstance Typedef
- HiLink factorHook Typedef
- HiLink factorMain Define
- HiLink factorPostpone Define
- HiLink factorDefer Define
- HiLink factorForget Define
- HiLink factorAlien Define
- HiLink factorTuple Typedef
-
- if &bg == "dark"
- hi hlLevel0 ctermfg=red guifg=red1
- hi hlLevel1 ctermfg=yellow guifg=orange1
- hi hlLevel2 ctermfg=green guifg=yellow1
- hi hlLevel3 ctermfg=cyan guifg=greenyellow
- hi hlLevel4 ctermfg=magenta guifg=green1
- hi hlLevel5 ctermfg=red guifg=springgreen1
- hi hlLevel6 ctermfg=yellow guifg=cyan1
- hi hlLevel7 ctermfg=green guifg=slateblue1
- hi hlLevel8 ctermfg=cyan guifg=magenta1
- hi hlLevel9 ctermfg=magenta guifg=purple1
- else
- hi hlLevel0 ctermfg=red guifg=red3
- hi hlLevel1 ctermfg=darkyellow guifg=orangered3
- hi hlLevel2 ctermfg=darkgreen guifg=orange2
- hi hlLevel3 ctermfg=blue guifg=yellow3
- hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
- hi hlLevel5 ctermfg=red guifg=green4
- hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3
- hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4
- hi hlLevel8 ctermfg=blue guifg=darkslateblue
- hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet
- endif
-
- delcommand HiLink
-endif
-
-let b:current_syntax = "factor"
-
-set sw=4
-set ts=4
-set expandtab
-set autoindent " annoying?
-
-" vim: syntax=vim
-
(require 'factor-mode)
* Basic usage
+*** Running the listener
If you're using the default factor binary and images locations inside
the Factor's source tree, that should be enough to start using FUEL.
To start the listener, try M-x run-factor.
+ By default, FUEL will try to use the binary and image files in the
+ factor installation directory. You can customize them with:
+
+ (setq fuel-listener-factor-binary <full path to factor>)
+ (setq fuel-listener-factor-image <full path to factor image>)
+
Many aspects of the environment can be customized:
M-x customize-group fuel will show you how many.
+*** Faster listener startup
+
+ On startup, run-factor loads the fuel vocabulary, which can take a
+ while. If you want to speedup the load process, type 'save' in the
+ listener prompt just after invoking run-factor. This will save a
+ factor image (overwriting the current one) with all the needed
+ vocabs.
+
+*** Vocabulary creation
+
+ FUEL offers a basic interface with Factor's scaffolding utilities.
+ To create a new vocabulary directory and associated files:
+
+ M-x fuel-scaffold-vocab
+
+ and when in a vocab file, to create a docs file with boilerplate
+ for each word:
+
+ M-x fuel-scaffold-help
+
* Quick key reference
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- - M-. : edit word at point in Emacs
+ - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
+ - M-, : go back to where M-. was last invoked
- M-TAB : complete word at point
- C-cC-eu : update USING: line
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
- C-cC-ds : short help word at point
- C-cC-de : show stack effect of current sexp (with prefix, region)
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
+ - C-cC-dv : show words in current file (with prefix, ask for vocab)
- C-cM-<, C-cC-d< : show callers of word at point
- C-cM->, C-cC-d> : show callees of word at point
- - C-cC-xw : extract region as a separate word
+ - C-cC-xs : extract innermost sexp (up to point) as a separate word
+ - C-cC-xr : extract region as a separate word
+ - C-cC-xi : replace word at point by its definition
+ - C-cC-xv : extract region as a separate vocabulary
*** In the listener:
;;; factor-mode.el -- mode for editing Factor source
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
:group 'fuel
:group 'languages)
+(defcustom factor-mode-cycle-always-ask-p t
+ "Whether to always ask for file creation when cycling to a
+source/docs/tests file.
+
+When set to false, you'll be asked only once."
+ :type 'boolean
+ :group 'factor-mode)
+
(defcustom factor-mode-use-fuel t
"Whether to use the full FUEL facilities in factor mode.
(= (- be (point)) (current-indentation))
(= ln (line-number-at-pos be)))
(fuel-syntax--indentation-at bs))
- ((or (fuel-syntax--is-eol bs)
+ ((or (fuel-syntax--is-last-char bs)
(not (eq ?\ (char-after (1+ bs)))))
(fuel-syntax--increased-indentation
(fuel-syntax--indentation-at bs)))
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))
- ((and (fuel-syntax--at-begin-of-def)
- (not (fuel-syntax--at-using)))
+ ((fuel-syntax--at-begin-of-indent-def)
(fuel-syntax--increased-indentation))
(t (current-indentation)))))
(defconst factor-mode--cycle-endings
'(".factor" "-tests.factor" "-docs.factor"))
-(defconst factor-mode--regex-cycle-endings
- (format "\\(.*?\\)\\(%s\\)$"
- (regexp-opt factor-mode--cycle-endings)))
+(make-local-variable
+ (defvar factor-mode--cycling-no-ask nil))
-(defconst factor-mode--cycle-endings-ring
+(defvar factor-mode--cycle-ring
(let ((ring (make-ring (length factor-mode--cycle-endings))))
(dolist (e factor-mode--cycle-endings ring)
- (ring-insert ring e))))
+ (ring-insert ring e))
+ ring))
+
+(defconst factor-mode--cycle-basename-regex
+ (format "\\(.+?\\)\\(%s\\)$" (regexp-opt factor-mode--cycle-endings)))
+
+(defun factor-mode--cycle-split (basename)
+ (when (string-match factor-mode--cycle-basename-regex basename)
+ (cons (match-string 1 basename) (match-string 2 basename))))
(defun factor-mode--cycle-next (file)
- (let* ((match (string-match factor-mode--regex-cycle-endings file))
- (base (and match (match-string-no-properties 1 file)))
- (ending (and match (match-string-no-properties 2 file)))
- (idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
- (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
- (if (not idx) file
- (let ((l (length factor-mode--cycle-endings)) (i 1) next)
- (while (and (not next) (< i l))
- (when (file-exists-p (funcall gfl (+ idx i)))
- (setq next (+ idx i)))
- (setq i (1+ i)))
- (funcall gfl (or next idx))))))
+ (let* ((dir (file-name-directory file))
+ (basename (file-name-nondirectory file))
+ (p/s (factor-mode--cycle-split basename))
+ (prefix (car p/s))
+ (ring factor-mode--cycle-ring)
+ (idx (or (ring-member ring (cdr p/s)) 0))
+ (len (ring-size ring))
+ (i 1)
+ (result nil))
+ (while (and (< i len) (not result))
+ (let* ((suffix (ring-ref ring (+ i idx)))
+ (path (expand-file-name (concat prefix suffix) dir)))
+ (when (or (file-exists-p path)
+ (and (not (member suffix factor-mode--cycling-no-ask))
+ (y-or-n-p (format "Create %s? " path))))
+ (setq result path))
+ (when (and (not factor-mode-cycle-always-ask-p)
+ (not (member suffix factor-mode--cycling-no-ask)))
+ (setq factor-mode--cycling-no-ask
+ (cons name factor-mode--cycling-no-ask))))
+ (setq i (1+ i)))
+ result))
+
+(defsubst factor-mode--cycling-setup ()
+ (setq factor-mode--cycling-no-ask nil))
(defun factor-mode-visit-other-file (&optional file)
"Cycle between code, tests and docs factor files."
(interactive)
- (find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
+ (let ((file (factor-mode--cycle-next (or file (buffer-file-name)))))
+ (unless file (error "No other file found"))
+ (find-file file)
+ (unless (file-exists-p file)
+ (set-buffer-modified-p t)
+ (save-buffer))))
\f
;;; Keymap:
-(defun factor-mode-insert-and-indent (n)
- (interactive "p")
- (self-insert-command n)
- (indent-for-tab-command))
+(defun factor-mode--insert-and-indent (n)
+ (interactive "*p")
+ (let ((start (point)))
+ (self-insert-command n)
+ (save-excursion (font-lock-fontify-region start (point))))
+ (indent-according-to-mode))
(defvar factor-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [?\]] 'factor-mode-insert-and-indent)
- (define-key map [?}] 'factor-mode-insert-and-indent)
+ (define-key map [?\]] 'factor-mode--insert-and-indent)
+ (define-key map [?}] 'factor-mode--insert-and-indent)
(define-key map "\C-m" 'newline-and-indent)
(define-key map "\C-co" 'factor-mode-visit-other-file)
(define-key map "\C-c\C-o" 'factor-mode-visit-other-file)
(factor-mode--keymap-setup)
(factor-mode--indentation-setup)
(factor-mode--syntax-setup)
+ (factor-mode--cycling-setup)
(when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
(run-hooks 'factor-mode-hook))
;;; fu.el --- Startup file for FUEL
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
;;; Code:
-(add-to-list 'load-path (file-name-directory load-file-name))
+(setq fuel-factor-fuel-dir (file-name-directory load-file-name))
+
+(setq fuel-factor-root-dir (expand-file-name "../../" fuel-factor-fuel-dir))
+
+(add-to-list 'load-path fuel-factor-fuel-dir)
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
(autoload 'factor-mode "factor-mode.el"
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
t)
+(autoload 'fuel-scaffold-vocab "fuel-scaffold.el"
+ "Create a new Factor vocabulary." t)
+
+(autoload 'fuel-scaffold-help "fuel-scaffold.el"
+ "Create a Factor vocabulary help file." t)
\f
;;; fu.el ends here
(defun fuel-autodoc--eldoc-function ()
(or (and fuel-autodoc--fallback-function
(funcall fuel-autodoc--fallback-function))
- (fuel-autodoc--word-synopsis)))
+ (condition-case e
+ (fuel-autodoc--word-synopsis)
+ (error (format "Autodoc not available (%s)"
+ (error-message-string e))))))
\f
;;; Autodoc mode:
;;; fuel-base.el --- Basic FUEL support code
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
(defun fuel-con--get-connection (buffer/proc)
(if (processp buffer/proc)
(fuel-con--get-connection (process-buffer buffer/proc))
- (with-current-buffer buffer/proc
- (or fuel-con--connection
- (setq fuel-con--connection
- (fuel-con--setup-connection buffer/proc))))))
+ (with-current-buffer buffer/proc fuel-con--connection)))
\f
;;; Request and connection datatypes:
(defun fuel-con--setup-connection (buffer)
(set-buffer buffer)
(fuel-con--cleanup-connection fuel-con--connection)
+ (setq fuel-con--connection nil)
(let ((conn (fuel-con--make-connection buffer)))
(fuel-con--setup-comint)
- (prog1
- (setq fuel-con--connection conn)
- (fuel-con--connection-start-timer conn))))
+ (fuel-con--establish-connection conn buffer)))
(defconst fuel-con--prompt-regex "( .+ ) ")
(defconst fuel-con--eot-marker "<~FUEL~>")
(defconst fuel-con--init-stanza "USE: fuel fuel-retort")
-(defconst fuel-con--comint-finished-regex
+(defconst fuel-con--comint-finished-regex-connected
(format "^%s$" fuel-con--eot-marker))
+(defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
+
(defun fuel-con--setup-comint ()
(set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
(add-hook 'comint-redirect-filter-functions
(setq comint-redirect-finished-regexp fuel-con--prompt-regex))
str)
+(defun fuel-con--establish-connection (conn buffer)
+ (with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
+ (with-current-buffer buffer
+ (setq fuel-con--connection conn)
+ (setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
+ (fuel-con--send-string/wait buffer
+ fuel-con--init-stanza
+ 'fuel-con--establish-connection-cont
+ 60000)
+ conn))
+
+(defun fuel-con--establish-connection-cont (ignore)
+ (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
+ (if (string-match fuel-con--eot-marker str)
+ (progn
+ (setq fuel-con--comint-finished-regex
+ fuel-con--comint-finished-regex-connected)
+ (fuel-con--connection-start-timer conn)
+ (message "FUEL listener up and running!"))
+ (fuel-con--connection-clean-current-request fuel-con--connection)
+ (setq fuel-con--connection nil)
+ (message "An error occurred initialising FUEL's Factor library!")
+ (pop-to-buffer (fuel-con--comint-buffer)))))
+
\f
;;; Requests handling:
(defsubst fuel-con--comint-buffer ()
(get-buffer-create " *fuel connection retort*"))
-(defsubst fuel-con--comint-buffer-form ()
+(defun fuel-con--comint-buffer-form ()
(with-current-buffer (fuel-con--comint-buffer)
(goto-char (point-min))
(condition-case nil
- (read (current-buffer))
+ (let ((form (read (current-buffer))))
+ (if (listp form) form
+ (list 'fuel-con-error (buffer-string))))
(error (list 'fuel-con-error (buffer-string))))))
(defun fuel-con--process-next (con)
\f
;;; Message sending interface:
+(defconst fuel-con--error-message "FUEL connection not active")
+
(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
(save-current-buffer
(let ((con (fuel-con--get-connection buffer/proc)))
- (unless con
- (error "FUEL: couldn't find connection"))
+ (unless con (error fuel-con--error-message))
(let ((req (fuel-con--make-request str cont sender-buffer)))
(fuel-con--connection-queue-request con req)
(fuel-con--process-next con)
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
(save-current-buffer
- (let* ((con (fuel-con--get-connection buffer/proc))
- (req (fuel-con--send-string buffer/proc str cont sbuf))
- (id (and req (fuel-con--request-id req)))
- (time (or timeout fuel-connection-timeout))
- (step 100)
- (waitsecs (/ step 1000.0)))
- (when id
- (condition-case nil
- (while (and (> time 0)
- (not (fuel-con--connection-completed-p con id)))
- (accept-process-output nil waitsecs)
- (setq time (- time step)))
- (error (setq time 0)))
- (or (> time 0)
- (fuel-con--request-deactivate req)
- nil)))))
+ (let ((con (fuel-con--get-connection buffer/proc)))
+ (unless con (error fuel-con--error-message))
+ (let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
+ (id (and req (fuel-con--request-id req)))
+ (time (or timeout fuel-connection-timeout))
+ (step 100)
+ (waitsecs (/ step 1000.0)))
+ (when id
+ (condition-case nil
+ (while (and (> time 0)
+ (not (fuel-con--connection-completed-p con id)))
+ (accept-process-output nil waitsecs)
+ (setq time (- time step)))
+ (error (setq time 0)))
+ (or (> time 0)
+ (fuel-con--request-deactivate req)
+ nil))))))
\f
(provide 'fuel-connection)
;;; fuel-debug-uses.el -- retrieving USING: stanzas
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
\f
;;; Utility functions:
+(defsubst fuel-debug--chomp (s)
+ (replace-regexp-in-string "[\n\r\f]" "" s))
+
(defun fuel-debug--file-lines (file)
(when (file-readable-p file)
(with-current-buffer (find-file-noselect file)
(let ((lines) (in-usings))
(while (not (eobp))
(when (looking-at "^USING: ") (setq in-usings t))
- (let ((line (substring-no-properties (thing-at-point 'line) 0 -1)))
+ (let ((line (fuel-debug--chomp
+ (substring-no-properties (thing-at-point 'line)))))
(when in-usings (setq line (concat "! " line)))
(push line lines))
(when (and in-usings (looking-at ".*\\_<;\\_>")) (setq in-usings nil))
(defvar fuel-debug--uses-restarts nil))
(defsubst fuel-debug--uses-insert-title ()
- (insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
+ (insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n"))
(defun fuel-debug--uses-prepare (file)
(fuel--with-popup (fuel-debug--uses-buffer)
map))
(defconst fuel-debug--uses-header-regex
- (format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
+ (format "^%s.*$" (regexp-opt '("Inferring USING: stanza for "
"Current USING: is already fine!"
"Current vocabulary list:"
"Correct vocabulary list:"
(require 'fuel-eval)
(require 'fuel-base)
+(require 'etags)
+
+\f
+;;; Customization
+
+(defcustom fuel-edit-word-method nil
+ "How the new buffer is opened when invoking
+\\[fuel-edit-word-at-point]."
+ :group 'fuel
+ :type '(choice (const :tag "Other window" window)
+ (const :tag "Other frame" frame)
+ (const :tag "Current window" nil)))
+
\f
;;; Auxiliar functions:
(error "Couldn't find edit location"))
(unless (file-readable-p (car loc))
(error "Couldn't open '%s' for read" (car loc)))
- (find-file-other-window (car loc))
+ (cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
+ ((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
+ (t (find-file (car loc))))
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
(defun fuel-edit--read-vocabulary-name (refresh)
(defvar fuel-edit--word-history nil)
(defvar fuel-edit--vocab-history nil)
+(defvar fuel-edit--previous-location nil)
(defun fuel-edit-vocabulary (&optional refresh vocab)
"Visits vocabulary file in Emacs.
(interactive "P")
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
- (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
+ (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))
+ (marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
- (error (fuel-edit-vocabulary nil word)))))
+ (error (fuel-edit-vocabulary nil word)))
+ (when marker (ring-insert find-tag-marker-ring marker))))
(defun fuel-edit-word-doc-at-point (&optional arg word)
"Opens a new window visiting the documentation file for the word at point.
(let* ((word (or word
(and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
- (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
+ (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))
+ (marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
(error
(y-or-n-p (concat "No documentation found. "
"Do you want to open the vocab's "
"doc file? ")))
+ (when marker (ring-insert find-tag-marker-ring marker))
(find-file-other-window
(format "%s-docs.factor"
(file-name-sans-extension (buffer-file-name)))))))))
+(defun fuel-edit-pop-edit-word-stack ()
+ "Pop back to where \\[fuel-edit-word-at-point] or \\[fuel-edit-word-doc-at-point]
+was last invoked."
+ (interactive)
+ (condition-case nil
+ (pop-tag-mark)
+ (error "No previous location for find word or vocab invokation")))
+
\f
(provide 'fuel-edit)
;;; fuel-edit.el ends here
(factor (case sexp
(:rs 'fuel-eval-restartable)
(:nrs 'fuel-eval-non-restartable)
- (:in (fuel-syntax--current-vocab))
+ (:in (or (fuel-syntax--current-vocab) "fuel"))
(:usings `(:array ,@(fuel-syntax--usings)))
(:get 'fuel-eval-set-result)
(:end '\;)
(defsubst factor--fuel-in (in)
(cond ((or (eq in :in) (null in)) :in)
((eq in 'f) 'f)
- ((eq in 't) "fuel-scratchpad")
+ ((eq in 't) "fuel")
((stringp in) in)
(t (error "Invalid 'in' (%s)" in))))
factor-font-lock font-lock factor-mode
((comment comment "comments")
(constructor type "constructors (<foo>)")
+ (constant constant "constants and literal values")
+ (number constant "integers and floats")
+ (ratio constant "ratios")
(declaration keyword "declaration words")
(parsing-word keyword "parsing words")
(setter-word function-name "setter words (>>foo)")
(symbol variable-name "name of symbol being defined")
(type-name type "type names")
(vocabulary-name constant "vocabulary names")
- (word function-name "word, generic or method being defined")))
+ (word function-name "word, generic or method being defined")
+ (invalid-syntax warning "syntactically invalid constructs")))
\f
;;; Font lock:
(defconst fuel-font-lock--font-lock-keywords
- `((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
+ `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
+ (,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
- (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
+ (,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
+ (,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word)
+ (2 'factor-font-lock-word))
+ (,fuel-syntax--int-constant-def-regex 2 'factor-font-lock-constant)
+ (,fuel-syntax--integer-regex . 'factor-font-lock-number)
+ (,fuel-syntax--float-regex . 'factor-font-lock-number)
+ (,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
- (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name)
+ (,fuel-syntax--parent-type-regex 2 'factor-font-lock-type-name)
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
- (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
- "Font lock keywords definition for Factor mode.")
+ (,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
(set (make-local-variable 'comment-start) "! ")
(list (cons 'font-lock-syntactic-keywords
fuel-syntax--syntactic-keywords))))))
-\f
\f
;;; Fontify strings as Factor code:
"Interacting with a Factor listener inside Emacs."
:group 'fuel)
-(defcustom fuel-listener-factor-binary "~/factor/factor"
+(defcustom fuel-listener-factor-binary
+ (expand-file-name "factor" fuel-factor-root-dir)
"Full path to the factor executable to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
-(defcustom fuel-listener-factor-image "~/factor/factor.image"
+(defcustom fuel-listener-factor-image
+ (expand-file-name "factor.image" fuel-factor-root-dir)
"Full path to the factor image to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
(error "Could not run factor: %s is not executable" factor))
(unless (file-readable-p image)
(error "Could not run factor: image file %s not readable" image))
- (message "Starting FUEL listener ...")
+ (message "Starting FUEL listener (this may take a while) ...")
(pop-to-buffer (fuel-listener--buffer))
(make-comint-in-buffer "fuel listener" (current-buffer) factor nil
"-run=listener" (format "-i=%s" image))
(fuel-listener--wait-for-prompt 10000)
- (fuel-con--setup-connection (current-buffer))
- (fuel-con--send-string/wait (current-buffer)
- fuel-con--init-stanza
- '(lambda (s) (message "FUEL listener up and running!"))
- 20000)))
+ (fuel-con--setup-connection (current-buffer))))
(defun fuel-listener--process (&optional start)
(or (and (buffer-live-p (fuel-listener--buffer))
(defun fuel-listener-nuke ()
(interactive)
+ (goto-char (point-max))
+ (comint-kill-region comint-last-input-start (point))
(comint-redirect-cleanup)
(fuel-con--setup-connection fuel-listener--buffer))
(defun fuel-markup--article-title (name)
(fuel-eval--retort-result
- (fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel"))))
+ (fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel"))))
(defun fuel-markup--link-at-point ()
(let ((button (condition-case nil (forward-button 0) (error nil))))
(let ((heading `($heading ,(match-string-no-properties 0)))
(rows))
(forward-line)
- (when (looking-at "Word *Stack effect$")
- (push '("Word" "Stack effect") rows)
+ (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
+ (push (list "Word" (match-string-no-properties 1)) rows)
(forward-line))
- (while (looking-at "\\(.+?\\)\\( +\\(( .*\\)\\)?$")
+ (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
(let ((word `($link ,(match-string-no-properties 1)
,(match-string-no-properties 1)
word))
(let ((file (car (fuel-mode--read-file arg))))
(when file (fuel-debug--uses-for-file file))))
-(defvar fuel-mode--word-history nil)
-
-(defun fuel-show-callers (&optional arg)
- "Show a list of callers of word at point.
-With prefix argument, ask for word."
- (interactive "P")
- (let ((word (if arg (fuel-completion--read-word "Find callers for: "
- (fuel-syntax-symbol-at-point)
- fuel-mode--word-history)
- (fuel-syntax-symbol-at-point))))
- (when word
- (message "Looking up %s's callers ..." word)
- (fuel-xref--show-callers word))))
-
-(defun fuel-show-callees (&optional arg)
- "Show a list of callers of word at point.
-With prefix argument, ask for word."
- (interactive "P")
- (let ((word (if arg (fuel-completion--read-word "Find callees for: "
- (fuel-syntax-symbol-at-point)
- fuel-mode--word-history)
- (fuel-syntax-symbol-at-point))))
- (when word
- (message "Looking up %s's callees ..." word)
- (fuel-xref--show-callees word))))
-
-(defun fuel-apropos (str)
- "Show a list of words containing the given substring."
- (interactive "MFind words containing: ")
- (message "Looking up %s's references ..." str)
- (fuel-xref--apropos str))
\f
;;; Minor mode definition:
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-mode-map "\M-," 'fuel-edit-pop-edit-word-stack)
(define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers)
(define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees)
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
(fuel-mode--key ?e ?w 'fuel-edit-word)
(fuel-mode--key ?e ?x 'fuel-eval-definition)
-(fuel-mode--key ?x ?w 'fuel-refactor-extract-word)
+(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
+(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
+(fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab)
+(fuel-mode--key ?x ?i 'fuel-refactor-inline-word)
(fuel-mode--key ?d ?> 'fuel-show-callees)
(fuel-mode--key ?d ?< 'fuel-show-callers)
+(fuel-mode--key ?d ?v 'fuel-show-file-words)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?p 'fuel-apropos)
(fuel-mode--key ?d ?d 'fuel-help)
;;; Code:
+(require 'fuel-scaffold)
(require 'fuel-stack)
(require 'fuel-syntax)
(require 'fuel-base)
+\f
+;;; Word definitions in buffer
+
+(defconst fuel-refactor--next-defun-regex
+ (format "^\\(:\\|MEMO:\\|MACRO:\\):? +\\(\\w+\\)\\(%s\\)\\([^;]+?\\) ;\\_>"
+ fuel-syntax--stack-effect-regex))
+
+(defun fuel-refactor--previous-defun ()
+ (let ((pos) (result))
+ (while (and (not result)
+ (setq pos (fuel-syntax--beginning-of-defun)))
+ (setq result (looking-at fuel-refactor--next-defun-regex)))
+ (when (and result pos)
+ (let ((name (match-string-no-properties 2))
+ (body (match-string-no-properties 4))
+ (end (match-end 0)))
+ (list (split-string body nil t) name pos end)))))
+
+(defun fuel-refactor--find (code to)
+ (let ((candidate) (result))
+ (while (and (not result)
+ (setq candidate (fuel-refactor--previous-defun))
+ (> (point) to))
+ (when (equal (car candidate) code)
+ (setq result (cdr candidate))))
+ result))
+
+(defun fuel-refactor--reuse-p (word)
+ (save-excursion
+ (mark-defun)
+ (move-overlay fuel-stack--overlay (1+ (point)) (mark))
+ (unwind-protect
+ (and (y-or-n-p (format "Use existing word '%s'? " word)) word)
+ (delete-overlay fuel-stack--overlay))))
+
+(defun fuel-refactor--code-rx (code)
+ (let ((words (split-string code nil t)))
+ (mapconcat 'regexp-quote words "[ \n\f\r]+")))
+
\f
;;; Extract word:
-(defun fuel-refactor-extract-word (begin end)
- "Extracts current region as a separate word."
- (interactive "r")
- (let* ((word (read-string "New word name: "))
- (begin (save-excursion
- (goto-char begin)
- (when (zerop (skip-syntax-backward "w"))
- (skip-syntax-forward "-"))
- (point)))
- (end (save-excursion
- (goto-char end)
- (skip-syntax-forward "w")
- (point)))
- (code (buffer-substring begin end))
- (code-str (fuel--region-to-string begin end))
- (stack-effect (or (fuel-stack--infer-effect code-str)
- (read-string "Stack effect: "))))
+(defun fuel-refactor--reuse-existing (code)
+ (save-excursion
+ (mark-defun)
+ (let ((code (split-string (substring-no-properties code) nil t))
+ (down (mark))
+ (found)
+ (result))
+ (while (and (not result)
+ (setq found (fuel-refactor--find code (point-min))))
+ (when found (setq result (fuel-refactor--reuse-p (car found)))))
+ (goto-char (point-max))
+ (while (and (not result)
+ (setq found (fuel-refactor--find code down)))
+ (when found (setq result (fuel-refactor--reuse-p (car found)))))
+ (and result found))))
+
+(defun fuel-refactor--insert-word (word stack-effect code)
+ (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
+ (end (save-excursion
+ (re-search-backward fuel-syntax--end-of-def-regex nil t)
+ (forward-line 1)
+ (skip-syntax-forward "-"))))
+ (let ((start (goto-char (max beg end))))
+ (open-line 1)
+ (insert ": " word " " stack-effect "\n" code " ;\n")
+ (indent-region start (point))
+ (move-overlay fuel-stack--overlay start (point)))))
+
+(defun fuel-refactor--extract-other (start end code)
+ (unwind-protect
+ (when (y-or-n-p "Apply refactoring to rest of buffer? ")
+ (save-excursion
+ (let ((rx (fuel-refactor--code-rx code))
+ (end (point)))
+ (query-replace-regexp rx word t (point-min) start)
+ (query-replace-regexp rx word t end (point-max)))))
+ (delete-overlay fuel-stack--overlay)))
+
+(defun fuel-refactor--extract (begin end)
+ (unless (< begin end) (error "No proper region to extract"))
+ (let* ((code (buffer-substring begin end))
+ (existing (fuel-refactor--reuse-existing code))
+ (code-str (or existing (fuel--region-to-string begin end)))
+ (stack-effect (or existing
+ (fuel-stack--infer-effect code-str)
+ (read-string "Stack effect: ")))
+ (word (or (car existing) (read-string "New word name: "))))
(goto-char begin)
(delete-region begin end)
(insert word)
(indent-region begin (point))
- (set-mark (point))
- (fuel-syntax--beginning-of-defun)
- (open-line 1)
- (let ((start (point)))
- (insert ": " word " " stack-effect "\n" code " ;\n")
- (indent-region start (point))
- (move-overlay fuel-stack--overlay start (point))
- (goto-char (mark))
- (sit-for fuel-stack-highlight-period)
- (delete-overlay fuel-stack--overlay))))
+ (save-excursion
+ (let ((start (or (cadr existing) (point))))
+ (unless existing
+ (fuel-refactor--insert-word word stack-effect code))
+ (fuel-refactor--extract-other start
+ (or (car (cddr existing)) (point))
+ code)))))
+
+(defun fuel-refactor-extract-region (begin end)
+ "Extracts current region as a separate word."
+ (interactive "r")
+ (let ((begin (save-excursion
+ (goto-char begin)
+ (when (zerop (skip-syntax-backward "w"))
+ (skip-syntax-forward "-"))
+ (point)))
+ (end (save-excursion
+ (goto-char end)
+ (skip-syntax-forward "w")
+ (point))))
+ (fuel-refactor--extract begin end)))
+
+(defun fuel-refactor-extract-sexp ()
+ "Extracts current innermost sexp (up to point) as a separate
+word."
+ (interactive)
+ (fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos))
+ (if (looking-at-p ";") (point)
+ (fuel-syntax--end-of-symbol-pos))))
+
+\f
+;;; Inline word:
+(defun fuel-refactor--word-def (word)
+ (let ((def (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,word fuel-word-def) "fuel")))))
+ (when def
+ (substring (substring def 2) 0 -2))))
+
+(defun fuel-refactor-inline-word ()
+ "Inserts definition of word at point."
+ (interactive)
+ (let ((word (fuel-syntax-symbol-at-point)))
+ (unless word (error "No word at point"))
+ (let ((code (fuel-refactor--word-def word)))
+ (unless code (error "Word's definition not found"))
+ (fuel-syntax--beginning-of-symbol)
+ (kill-word 1)
+ (let ((start (point)))
+ (insert code)
+ (save-excursion (font-lock-fontify-region start (point)))
+ (indent-region start (point))))))
+
+\f
+;;; Extract vocab:
+
+(defun fuel-refactor--insert-using (vocab)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((usings (sort (cons vocab (fuel-syntax--usings)) 'string<)))
+ (fuel-debug--replace-usings (buffer-file-name) usings))))
+
+(defun fuel-refactor--vocab-root (vocab)
+ (let ((cmd `(:fuel* (,vocab fuel-scaffold-get-root) "fuel")))
+ (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+
+(defun fuel-refactor--extract-vocab (begin end)
+ (when (< begin end)
+ (let* ((str (buffer-substring begin end))
+ (buffer (current-buffer))
+ (vocab (fuel-syntax--current-vocab))
+ (vocab-hint (and vocab (format "%s." vocab)))
+ (root-hint (fuel-refactor--vocab-root vocab))
+ (vocab (fuel-scaffold-vocab t vocab-hint root-hint)))
+ (with-current-buffer buffer
+ (delete-region begin end)
+ (fuel-refactor--insert-using vocab))
+ (newline)
+ (insert str)
+ (newline)
+ (save-buffer)
+ (fuel-update-usings))))
+
+(defun fuel-refactor-extract-vocab (begin end)
+ "Creates a new vocab with the words in current region.
+The region is extended to the closest definition boundaries."
+ (interactive "r")
+ (fuel-refactor--extract-vocab (save-excursion (goto-char begin)
+ (mark-defun)
+ (point))
+ (save-excursion (goto-char end)
+ (mark-defun)
+ (mark))))
\f
(provide 'fuel-refactor)
;;; fuel-refactor.el ends here
--- /dev/null
+;;; fuel-scaffold.el -- interaction with tools.scaffold
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Jan 11, 2009 18:40
+
+;;; Comentary:
+
+;; Utilities for creating new vocabulary files and other boilerplate.
+;; Mainly, an interface to Factor's tools.scaffold.
+
+;;; Code:
+
+(require 'fuel-eval)
+(require 'fuel-edit)
+(require 'fuel-syntax)
+(require 'fuel-base)
+
+\f
+;;; Customisation:
+
+(defgroup fuel-scaffold nil
+ "Options for FUEL's scaffolding."
+ :group 'fuel)
+
+(defcustom fuel-scaffold-developer-name user-full-name
+ "The name to be inserted as yours in scaffold templates."
+ :type 'string
+ :group 'fuel-scaffold)
+
+\f
+;;; Auxiliary functions:
+
+(defun fuel-scaffold--vocab-roots ()
+ (let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
+ (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+
+\f
+;;; User interface:
+
+(defun fuel-scaffold-vocab (&optional other-window name-hint root-hint)
+ "Creates a directory in the given root for a new vocabulary and
+adds source, tests and authors.txt files.
+
+You can configure `fuel-scaffold-developer-name' (set by default to
+`user-full-name') for the name to be inserted in the generated files."
+ (interactive)
+ (let* ((name (read-string "Vocab name: " name-hint))
+ (root (completing-read "Vocab root: "
+ (fuel-scaffold--vocab-roots)
+ nil t (or root-hint "resource:")))
+ (cmd `(:fuel* ((,root ,name ,fuel-scaffold-developer-name)
+ (fuel-scaffold-vocab)) "fuel"))
+ (ret (fuel-eval--send/wait cmd))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating vocab (%s)" (car (fuel-eval--retort-error ret))))
+ (if other-window (find-file-other-window file) (find-file file))
+ (goto-char (point-max))
+ name))
+
+(defun fuel-scaffold-help (&optional arg)
+ "Creates, if it does not already exist, a help file with
+scaffolded help for each word in the current vocabulary.
+
+With prefix argument, ask for the vocabulary name.
+You can configure `fuel-scaffold-developer-name' (set by default to
+`user-full-name') for the name to be inserted in the generated file."
+ (interactive "P")
+ (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-edit--read-vocabulary-name nil)))
+ (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
+ "fuel"))
+ (ret (fuel-eval--send/wait cmd))
+ (file (fuel-eval--retort-result ret)))
+ (unless file
+ (error "Error creating help file" (car (fuel-eval--retort-error ret))))
+ (find-file file)))
+
+\f
+(provide 'fuel-scaffold)
+;;; fuel-scaffold.el ends here
(defconst fuel-syntax--parsing-words
'(":" "::" ";" "<<" "<PRIVATE" ">>"
- "B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:"
- "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
- "GENERIC#" "GENERIC:" "HEX:" "HOOK:"
- "IN:" "INSTANCE:" "INTERSECTION:"
+ "ABOUT:" "ALIAS:" "ARTICLE:"
+ "B" "BIN:"
+ "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
+ "DEFER:"
+ "ERROR:" "EXCLUDE:"
+ "f" "FORGET:" "FROM:"
+ "GENERIC#" "GENERIC:"
+ "HELP:" "HEX:" "HOOK:"
+ "IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
- "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
- "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+ "OCT:"
+ "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
+ "QUALIFIED-WITH:" "QUALIFIED:"
+ "read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
+ "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "t" "t?" "TYPEDEF:"
- "UNION:" "USE:" "USING:" "VARS:"
- "call-next-method" "delimiter" "f" "initial:" "read-only"))
-
-(defconst fuel-syntax--bracers
- '("B" "BV" "C" "CS" "H" "T" "V" "W"))
+ "UNION:" "USE:" "USING:"
+ "VARS:"))
(defconst fuel-syntax--parsing-words-regex
(regexp-opt fuel-syntax--parsing-words 'words))
+(defconst fuel-syntax--bracers
+ '("B" "BV" "C" "CS" "H" "T" "V" "W"))
+
(defconst fuel-syntax--brace-words-regex
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
(defconst fuel-syntax--declaration-words
- '("flushable" "foldable" "inline" "parsing" "recursive"))
+ '("flushable" "foldable" "inline" "parsing" "recursive" "delimiter"))
(defconst fuel-syntax--declaration-words-regex
(regexp-opt fuel-syntax--declaration-words 'words))
(defconst fuel-syntax--method-definition-regex
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
+(defconst fuel-syntax--integer-regex
+ "\\_<-?[0-9]+\\_>")
+
+(defconst fuel-syntax--ratio-regex
+ "\\_<-?\\([0-9]+\\+\\)?[0-9]+/-?[0-9]+\\_>")
+
+(defconst fuel-syntax--float-regex
+ "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
+
+(defconst fuel-syntax--bad-string-regex
+ "\"\\([^\"]\\|\\\\\"\\)*\n")
+
(defconst fuel-syntax--word-definition-regex
- (fuel-syntax--second-word-regex '(":" "::" "GENERIC:")))
+ (fuel-syntax--second-word-regex
+ '(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
+ "SYMBOL:" "RENAME:")))
+
+(defconst fuel-syntax--alias-definition-regex
+ "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
+
+(defconst fuel-syntax--vocab-ref-regexp
+ (fuel-syntax--second-word-regex
+ '("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))
+
+(defconst fuel-syntax--int-constant-def-regex
+ (fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:")))
(defconst fuel-syntax--type-definition-regex
- (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:")))
+ (fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
-(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
+(defconst fuel-syntax--parent-type-regex
+ "^\\(TUPLE\\|PREDICTE\\): +[^ ]+ +< +\\([^ ]+\\)")
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
-(defconst fuel-syntax--definition-starters-regex
- (regexp-opt
- '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" "")))
+(defconst fuel-syntax--indent-def-starts '("" ":"
+ "FROM"
+ "INTERSECTION:"
+ "M" "MACRO" "MACRO:"
+ "MEMO" "MEMO:" "METHOD"
+ "PREDICATE" "PRIMITIVE"
+ "UNION"))
+
+(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS"
+ "SYMBOLS"
+ "TUPLE"
+ "VARS"))
+
+(defconst fuel-syntax--indent-def-start-regex
+ (format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
+
+(defconst fuel-syntax--no-indent-def-start-regex
+ (format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
(defconst fuel-syntax--definition-start-regex
- (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
+ (format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts
+ fuel-syntax--indent-def-starts))))
(defconst fuel-syntax--definition-end-regex
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
fuel-syntax--declaration-words-regex))
(defconst fuel-syntax--single-liner-regex
- (format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:"
- "PRIVATE>" "<PRIVATE"
- "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
+ (format "^%s" (regexp-opt '("ABOUT:"
+ "ARTICLE:"
+ "ALIAS:"
+ "CONSTANT:" "C:"
+ "DEFER:"
+ "FORGET:"
+ "GENERIC:" "GENERIC#"
+ "HELP:" "HEX:" "HOOK:"
+ "IN:" "INSTANCE:"
+ "MAIN:" "MATH:" "MIXIN:"
+ "OCT:"
+ "POSTPONE:" "PRIVATE>" "<PRIVATE"
+ "QUALIFIED-WITH:" "QUALIFIED:"
+ "RENAME:"
+ "SINGLETON:" "SLOT:" "SYMBOL:"
+ "USE:"
+ "VAR:"))))
(defconst fuel-syntax--begin-of-def-regex
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
- ;; Strings
- (modify-syntax-entry ?\" "\"" table)
+ ;; Char quote
(modify-syntax-entry ?\\ "/" table)
table))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
+ ;; Strings
+ ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\""))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))
;; Opening brace words:
- (,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
- ("\\_<\\({\\)\\_>" (1 "(}"))
+ ("\\_<\\w*\\({\\)\\_>" (1 "(}"))
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
(defsubst fuel-syntax--at-begin-of-def ()
(looking-at fuel-syntax--begin-of-def-regex))
+(defsubst fuel-syntax--at-begin-of-indent-def ()
+ (looking-at fuel-syntax--indent-def-start-regex))
+
(defsubst fuel-syntax--at-end-of-def ()
(looking-at fuel-syntax--end-of-def-regex))
(defsubst fuel-syntax--looking-at-emptiness ()
(looking-at "^[ ]*$\\|$"))
-(defsubst fuel-syntax--is-eol (pos)
+(defsubst fuel-syntax--is-last-char (pos)
(save-excursion
(goto-char (1+ pos))
(fuel-syntax--looking-at-emptiness)))
(defsubst fuel-syntax--usings ()
(funcall fuel-syntax--usings-function))
+(defun fuel-syntax--file-has-private ()
+ (save-excursion
+ (goto-char (point-min))
+ (and (re-search-forward "\\_<<PRIVATE\\_>" nil t)
+ (re-search-forward "\\_<PRIVATE>\\_>" nil t))))
+
(defun fuel-syntax--find-usings (&optional no-private)
(save-excursion
(let ((usings))
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
(dolist (u (split-string (match-string-no-properties 1) nil t))
(push u usings)))
- (goto-char (point-min))
- (when (and (not no-private)
- (re-search-forward "\\_<<PRIVATE\\_>" nil t)
- (re-search-forward "\\_<PRIVATE>\\_>" nil t))
+ (when (and (not no-private) (fuel-syntax--file-has-private))
(goto-char (point-max))
(push (concat (fuel-syntax--find-in) ".private") usings))
usings)))
;;; Code:
+(require 'fuel-edit)
+(require 'fuel-completion)
(require 'fuel-help)
(require 'fuel-eval)
(require 'fuel-syntax)
((= 1 count) (format "1 word %s %s:" cc word))
(t (format "%s words %s %s:" count cc word))))
-(defun fuel-xref--insert-ref (ref)
+(defun fuel-xref--insert-ref (ref &optional no-vocab)
(when (and (stringp (first ref))
(stringp (third ref))
(numberp (fourth ref)))
(fourth ref))
'file (third ref)
'line (fourth ref))
- (when (stringp (second ref))
+ (when (and (not no-vocab) (stringp (second ref)))
(insert (format " (in %s)" (second ref))))
(newline)
t))
-(defun fuel-xref--fill-buffer (word cc refs)
+(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app)
(let ((inhibit-read-only t)
(count 0))
(with-current-buffer (fuel-xref--buffer)
- (erase-buffer)
- (dolist (ref refs)
- (when (fuel-xref--insert-ref ref) (setq count (1+ count))))
- (goto-char (point-min))
- (insert (fuel-xref--title word cc count) "\n\n")
- (when (> count 0)
- (setq fuel-xref--word (and cc word))
- (goto-char (point-max))
- (insert "\n" fuel-xref--help-string "\n"))
- (goto-char (point-min))
- count)))
-
-(defun fuel-xref--fill-and-display (word cc refs)
- (let ((count (fuel-xref--fill-buffer word cc refs)))
+ (let ((start (if app (goto-char (point-max))
+ (erase-buffer)
+ (point-min))))
+ (dolist (ref refs)
+ (when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count))))
+ (newline)
+ (goto-char start)
+ (save-excursion
+ (insert (fuel-xref--title word cc count) "\n\n"))
+ count))))
+
+(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab)
+ (let ((count (fuel-xref--fill-buffer word cc refs no-vocab)))
(if (zerop count)
(error (fuel-xref--title word cc 0))
(message "")
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
(fuel-xref--fill-and-display str "containing" res)))
+(defun fuel-xref--show-vocab (vocab &optional app)
+ (let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab))
+ (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
+ (fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
+
+(defun fuel-xref--show-vocab-words (vocab &optional private)
+ (fuel-xref--show-vocab vocab)
+ (when private
+ (fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab))
+ t))
+ (fuel-popup--display (fuel-xref--buffer))
+ (goto-char (point-min)))
+
+\f
+;;; User commands:
+
+(defvar fuel-xref--word-history nil)
+
+(defun fuel-show-callers (&optional arg)
+ "Show a list of callers of word at point.
+With prefix argument, ask for word."
+ (interactive "P")
+ (let ((word (if arg (fuel-completion--read-word "Find callers for: "
+ (fuel-syntax-symbol-at-point)
+ fuel-xref--word-history)
+ (fuel-syntax-symbol-at-point))))
+ (when word
+ (message "Looking up %s's callers ..." word)
+ (fuel-xref--show-callers word))))
+
+(defun fuel-show-callees (&optional arg)
+ "Show a list of callers of word at point.
+With prefix argument, ask for word."
+ (interactive "P")
+ (let ((word (if arg (fuel-completion--read-word "Find callees for: "
+ (fuel-syntax-symbol-at-point)
+ fuel-xref--word-history)
+ (fuel-syntax-symbol-at-point))))
+ (when word
+ (message "Looking up %s's callees ..." word)
+ (fuel-xref--show-callees word))))
+
+(defun fuel-apropos (str)
+ "Show a list of words containing the given substring."
+ (interactive "MFind words containing: ")
+ (message "Looking up %s's references ..." str)
+ (fuel-xref--apropos str))
+
+(defun fuel-show-file-words (&optional arg)
+ "Show a list of words in current file.
+With prefix argument, ask for the vocab."
+ (interactive "P")
+ (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
+ (fuel-edit--read-vocabulary-name))))
+ (when vocab
+ (fuel-xref--show-vocab-words vocab
+ (fuel-syntax--file-has-private)))))
+
+
\f
;;; Xref mode:
(kill-all-local-variables)
(buffer-disable-undo)
(use-local-map fuel-xref-mode-map)
+ (set-syntax-table fuel-syntax--syntax-table)
(setq mode-name "FUEL Xref")
(setq major-mode 'fuel-xref-mode)
(font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))
--- /dev/null
+Vim support for Factor
+----------------------
+
+This directory contains various support files that make editing Factor code
+more pleasant in Vim. The file-layout exactly matches the Vim runtime
+structure, so you can install them by copying the contents of this directory
+into ~/.vim/ or the equivalent path on other platforms (Open Vim and type
+":help 'runtimepath'" for details).
+
+The current set of files is as follows:
+
+ ftdetect/factor.vim
+ Teach Vim when to load Factor support files.
+ ftplugin/factor_settings.vim
+ Teach Vim to follow the Factor Coding Style guidelines.
+ syntax/factor.vim
+ Syntax highlighting for Factor code.
+
+Note: The syntax-highlighting file is automatically generated to include the
+names of all the vocabularies Factor knows about. To regenerate it manually,
+run the following code in the listener:
+
+ USE: editors.vim.generate-syntax
+
+ generate-vim-syntax
+
+...or run it from the command-line:
+
+ factor -run=editors.vim.generate-syntax
--- /dev/null
+autocmd BufRead,BufNewFile *.factor,{,.}factor*-rc set filetype=factor
--- /dev/null
+" Code formatting settings loosely adapted from:
+" http://concatenative.org/wiki/view/Factor/Coding%20Style
+
+" Tabs are not allowed in Factor source files; use four spaces instead.
+setlocal expandtab tabstop=4 shiftwidth=4 softtabstop=4
+
+" Try to limit lines to 64 characters, except for documentation, which can be
+" any length.
+if expand("%:t") !~ "-docs\.factor$"
+ setlocal textwidth=64
+
+ " Mark anything in column 64 or beyond as a syntax error.
+ match Error /\%>63v.\+/
+endif
+
+" Teach Vim what comments look like.
+setlocal comments+=b:!,b:#!
--- /dev/null
+" Vim syntax file
+" Language: factor
+" Maintainer: Alex Chapman <chapman.alex@gmail.com>
+" Last Change: 2008 Apr 28
+
+" For version 5.x: Clear all syntax items
+" For version 6.x: Quit when a syntax file was already loaded
+if version < 600
+ syntax clear
+elseif exists("b:current_syntax")
+ finish
+endif
+
+" factor is case sensitive.
+syn case match
+
+" make all of these characters part of a word (useful for skipping over words with w, e, and b)
+if version >= 600
+ setlocal iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
+else
+ set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
+endif
+
+syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
+
+syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
+syn match factorComment /\<#! .*/ contains=factorTodo
+syn match factorComment /\<! .*/ contains=factorTodo
+
+syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
+
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
+syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
+
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
+syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
+
+syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
+
+
+syn keyword factorBoolean boolean f general-t t
+syn keyword factorCompileDirective inline foldable parsing
+
+
+
+" kernel vocab keywords
+syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple
+syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
+syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot
+syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f
+syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
+syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
+syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
+syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
+syn keyword factorKeyword resize-string >string <string> 1string string string?
+syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
+syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts
+
+
+syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
+syn cluster factorNumber contains=@factorReal,factorComplex
+syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
+syn match factorInt /\<-\=\d\+\>/
+syn match factorFloat /\<-\=\d*\.\d\+\>/
+syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn region factorComplex start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
+syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
+syn match factorBinary /\<BIN:\s\+[01]\+\>/
+syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
+syn match factorHex /\<HEX:\s\+\x\+\>/
+syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
+syn match factorOctal /\<OCT:\s\+\o\+\>/
+
+syn match factorIn /\<IN:\s\+\S\+\>/
+syn match factorUse /\<USE:\s\+\S\+\>/
+
+syn match factorCharErr /\<CHAR:\s\+\S\+/
+syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+
+syn match factorBackslash /\<\\\>\s\+\S\+\>/
+
+syn region factorUsing start=/\<USING:\>/ end=/;/
+syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
+
+syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
+syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
+syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
+syn match factorDefer /\<DEFER:\s\+\S\+\>/
+syn match factorForget /\<FORGET:\s\+\S\+\>/
+syn match factorMixin /\<MIXIN:\s\+\S\+\>/
+syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
+syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
+syn match factorMain /\<MAIN:\s\+\S\+\>/
+syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+
+syn match factorAlien /\<ALIEN:\s\+\d\+\>/
+
+syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
+
+"TODO:
+"misc:
+" HELP:
+" ARTICLE:
+"literals:
+" PRIMITIVE:
+
+"C interface:
+" FIELD:
+" BEGIN-STRUCT:
+" C-ENUM:
+" FUNCTION:
+" END-STRUCT
+" DLL"
+" TYPEDEF:
+" LIBRARY:
+" C-UNION:
+
+syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
+syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
+
+syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
+syn match factorMultiStringContents /.*/ contained
+
+"syn match factorStackEffectErr /\<)\>/
+"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
+syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
+
+"adapted from lisp.vim
+if exists("g:factor_norainbow")
+ syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+else
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+endif
+
+if exists("g:factor_norainbow")
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+else
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+endif
+
+syn match factorBracketErr /\<\]\>/
+syn match factorBracketErr /\<}\>/
+
+syn sync lines=100
+
+if version >= 508 || !exists("did_factor_syn_inits")
+ if version <= 508
+ let did_factor_syn_inits = 1
+ command -nargs=+ HiLink hi link <args>
+ else
+ command -nargs=+ HiLink hi def link <args>
+ endif
+
+ HiLink factorComment Comment
+ HiLink factorStackEffect Typedef
+ HiLink factorTodo Todo
+ HiLink factorInclude Include
+ HiLink factorRepeat Repeat
+ HiLink factorConditional Conditional
+ HiLink factorKeyword Keyword
+ HiLink factorOperator Operator
+ HiLink factorBoolean Boolean
+ HiLink factorDefnDelims Typedef
+ HiLink factorMethodDelims Typedef
+ HiLink factorGenericDelims Typedef
+ HiLink factorGenericNDelims Typedef
+ HiLink factorConstructor Typedef
+ HiLink factorPrivate Special
+ HiLink factorPrivateDefnDelims Special
+ HiLink factorPrivateMethodDelims Special
+ HiLink factorPGenericDelims Special
+ HiLink factorPGenericNDelims Special
+ HiLink factorString String
+ HiLink factorSbuf String
+ HiLink factorMultiStringContents String
+ HiLink factorMultiStringDelims Typedef
+ HiLink factorBracketErr Error
+ HiLink factorComplex Number
+ HiLink factorRatio Number
+ HiLink factorBinary Number
+ HiLink factorBinErr Error
+ HiLink factorHex Number
+ HiLink factorHexErr Error
+ HiLink factorOctal Number
+ HiLink factorOctErr Error
+ HiLink factorFloat Float
+ HiLink factorInt Number
+ HiLink factorUsing Include
+ HiLink factorUse Include
+ HiLink factorRequires Include
+ HiLink factorIn Define
+ HiLink factorChar Character
+ HiLink factorCharErr Error
+ HiLink factorDelimiter Delimiter
+ HiLink factorBackslash Special
+ HiLink factorCompileDirective Typedef
+ HiLink factorSymbol Define
+ HiLink factorMixin Typedef
+ HiLink factorInstance Typedef
+ HiLink factorHook Typedef
+ HiLink factorMain Define
+ HiLink factorPostpone Define
+ HiLink factorDefer Define
+ HiLink factorForget Define
+ HiLink factorAlien Define
+ HiLink factorTuple Typedef
+
+ if &bg == "dark"
+ hi hlLevel0 ctermfg=red guifg=red1
+ hi hlLevel1 ctermfg=yellow guifg=orange1
+ hi hlLevel2 ctermfg=green guifg=yellow1
+ hi hlLevel3 ctermfg=cyan guifg=greenyellow
+ hi hlLevel4 ctermfg=magenta guifg=green1
+ hi hlLevel5 ctermfg=red guifg=springgreen1
+ hi hlLevel6 ctermfg=yellow guifg=cyan1
+ hi hlLevel7 ctermfg=green guifg=slateblue1
+ hi hlLevel8 ctermfg=cyan guifg=magenta1
+ hi hlLevel9 ctermfg=magenta guifg=purple1
+ else
+ hi hlLevel0 ctermfg=red guifg=red3
+ hi hlLevel1 ctermfg=darkyellow guifg=orangered3
+ hi hlLevel2 ctermfg=darkgreen guifg=orange2
+ hi hlLevel3 ctermfg=blue guifg=yellow3
+ hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
+ hi hlLevel5 ctermfg=red guifg=green4
+ hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3
+ hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4
+ hi hlLevel8 ctermfg=blue guifg=darkslateblue
+ hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet
+ endif
+
+ delcommand HiLink
+endif
+
+let b:current_syntax = "factor"
+
+set sw=4
+set ts=4
+set expandtab
+set autoindent " annoying?
+
+" vim: syntax=vim
+
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel sequences quotations assocs math math.parser
- combinators.lib vars lsys.strings combinators.short-circuit ;
-
-IN: lsys.strings.interpret
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: command-table
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exec-command ( string -- ) command-table> at >quotation call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: command ( string -- command ) 1 head ;
-
-: parameter ( string -- parameter )
- [ drop 2 ] [ length 1- ] [ ] tri subseq string>number ;
-
-: exec-command* ( string -- )
- [ parameter ] [ command ] bi
- command-table> at dup
- [ 1 tail* call ] [ 2drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (interpret) ( slice -- )
- { { [ empty? ] [ drop ] }
- { [ has-param? ] [ next+rest* [ exec-command* ] [ (interpret) ] bi* ] }
- { [ t ] [ next+rest [ exec-command ] [ (interpret) ] bi* ] } }
- switch ;
-
-: interpret ( string -- ) <flat-slice> (interpret) ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel sbufs strings sequences assocs math
- combinators.lib vars lsys.strings combinators.short-circuit ;
-
-IN: lsys.strings.rewrite
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: rules
-
-: lookup ( str -- str ) [ 1 head rules> at ] [ ] bi or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: accum
-
-: push-next ( next -- ) lookup accum> push-all ;
-
-: (rewrite) ( slice -- )
- { { [ empty? ] [ drop ] }
- { [ has-param? ] [ next+rest* [ push-next ] [ (rewrite) ] bi* ] }
- { [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } }
- switch ;
-
-: rewrite ( string -- string )
- dup length 10 * <sbuf> >accum
- <flat-slice> (rewrite)
- accum> >string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: result
-
-: iterate ( -- ) result> rewrite >result ;
-
-: iterations ( n -- ) [ iterate ] times ;
+++ /dev/null
-
-USING: kernel sequences math combinators.lib combinators.short-circuit ;
-
-IN: lsys.strings
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: has-param? ( slice -- ? ) { [ length 1 > ] [ second CHAR: ( = ] } 1&& ;
-
-: next+rest ( slice -- next rest ) [ 1 head ] [ 1 tail-slice ] bi ;
-
-: index-rest ( slice -- i ) CHAR: ) swap index 1+ ;
-
-: next+rest* ( slice -- next rest ) dup index-rest [ head ] [ tail-slice ] 2bi ;
+++ /dev/null
-Lindenmayer system explorer
+++ /dev/null
-applications
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math vectors sequences opengl.gl math.vectors math.order
- math.matrices vars opengl self pos ori turtle lsys.tortoise
-
- lsys.strings.interpret combinators.short-circuit ;
-
- ! lsys.strings
-
-IN: lsys.tortoise.graphics
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! (v0 - v1) x (v1 - v2)
-
-: polygon-normal ( {_v0_v1_v2_} -- normal ) first3 dupd v- -rot v- swap cross ;
-
-: (polygon) ( vertices -- )
-GL_POLYGON glBegin
-dup polygon-normal gl-normal [ gl-vertex ] each
-glEnd ;
-
-: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: vertices
-
-! : init-vertices ( -- ) 0 <vector> >vertices ;
-
-: start-polygon ( -- ) vertices> delete-all ;
-
-: finish-polygon ( -- ) vertices> polygon ;
-
-: polygon-vertex ( -- ) pos> vertices> push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-vertex ( -- ) pos> gl-vertex ;
-
-: draw-forward ( length -- )
-GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
-
-: move-forward ( length -- ) step-turtle polygon-vertex ;
-
-: sneak-forward ( length -- ) step-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scale-len ( m -- ) len> * >len ;
-
-: scale-angle ( m -- ) angle> * >angle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-thickness ( i -- ) dup >thickness glLineWidth ;
-
-: scale-thickness ( m -- ) thickness> * 0.5 max set-thickness ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: color-table
-
-: init-color-table ( -- )
-{ { 0 0 0 } ! black
- { 0.5 0.5 0.5 } ! grey
- { 1 0 0 } ! red
- { 1 1 0 } ! yellow
- { 0 1 0 } ! green
- { 0.25 0.88 0.82 } ! turquoise
- { 0 0 1 } ! blue
- { 0.63 0.13 0.94 } ! purple
- { 0.00 0.50 0.00 } ! dark green
- { 0.00 0.82 0.82 } ! dark turquoise
- { 0.00 0.00 0.50 } ! dark blue
- { 0.58 0.00 0.82 } ! dark purple
- { 0.50 0.00 0.00 } ! dark red
- { 0.25 0.25 0.25 } ! dark grey
- { 0.75 0.75 0.75 } ! medium grey
- { 1 1 1 } ! white
-} [ 1 suffix ] map >color-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: material-color ( color -- )
-GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
-
-: set-color ( i -- )
-dup >color color-table> nth dup gl-color material-color ;
-
-: inc-color ( -- ) color> 1+ set-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: tortoise-stack
-
-! : init-tortoise-stack ( -- ) V{ } clone >tortoise-stack ;
-
-! : save-tortoise ( -- ) self> tortoise-stack> push ;
-
-! : save-tortoise ( -- ) self> tortoise-stack> push self> clone >self ;
-
-: save-tortoise ( -- ) self> clone tortoise-stack> push ;
-
-: restore-tortoise ( -- )
-tortoise-stack> pop >self
-color> set-color
-thickness> set-thickness ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: default-values
-VAR: model-values
-
-: lparser-dialect ( -- )
-
-[ 1 >len 45 >angle 1 >thickness 2 >color ] >default-values
-
-H{ { "+" [ angle> turn-left ] }
- { "-" [ angle> turn-right ] }
- { "&" [ angle> pitch-down ] }
- { "^" [ angle> pitch-up ] }
- { "<" [ angle> roll-left ] }
- { ">" [ angle> roll-right ] }
-
- { "|" [ 180.0 rotate-y ] }
- { "%" [ 180.0 rotate-z ] }
- { "$" [ roll-until-horizontal ] }
-
- { "F" [ len> draw-forward ] }
- { "Z" [ len> 2 / draw-forward ] }
- { "f" [ len> move-forward ] }
- { "z" [ len> 2 / move-forward ] }
- { "g" [ len> sneak-forward ] }
- { "." [ polygon-vertex ] }
-
- { "[" [ save-tortoise ] }
- { "]" [ restore-tortoise ] }
- { "{" [ start-polygon ] }
- { "}" [ finish-polygon ] }
-
- { "/" [ 1.1 scale-len ] } ! double quote command in lparser
- { "'" [ 0.9 scale-len ] }
- { ";" [ 1.1 scale-angle ] }
- { ":" [ 0.9 scale-angle ] }
- { "?" [ 1.4 scale-thickness ] }
- { "!" [ 0.7 scale-thickness ] }
-
- { "c" [ color> 1 + color-table> length mod set-color ] }
-
-} >command-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel generic math arrays
- math.matrices generic.lib pos ori self turtle ;
-
-IN: lsys.tortoise
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tortoise angle len thickness color ;
-
-: <tortoise> ( -- tortoise )
- <turtle> tortoise construct-delegate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: angle> ( -- val ) self> tortoise-angle ;
-
-: >angle ( val -- ) self> set-tortoise-angle ;
-
-: len> ( -- val ) self> tortoise-len ;
-
-: >len ( val -- ) self> set-tortoise-len ;
-
-: thickness> ( -- val ) self> tortoise-thickness ;
-
-: >thickness ( val -- ) self> set-tortoise-thickness ;
-
-: color> ( -- val ) self> tortoise-color ;
-
-: >color ( val -- ) self> set-tortoise-color ;
-
+++ /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? t }
- { deploy-word-defs? t }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Lindenmayer System Explorer" }
-}
+++ /dev/null
-
-USING: kernel namespaces threads math math.order math.vectors
- quotations sequences
- opengl
- opengl.gl
- colors
- ui
- ui.gestures
- ui.gadgets
- ui.gadgets.packs
- ui.gadgets.labels
- ui.gadgets.buttons
- ui.gadgets.lib
- ui.gadgets.slate
- ui.gadgets.theme
- vars rewrite-closures
- self pos ori turtle opengl.camera
- lsys.tortoise lsys.tortoise.graphics
- lsys.strings.rewrite lsys.strings.interpret
- combinators.short-circuit accessors ;
-
- ! lsys.strings
- ! lsys.strings.rewrite
- ! lsys.strings.interpret
-
-IN: lsys.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: camera
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: model
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: display ( -- )
-
-black set-clear-color GL_COLOR_BUFFER_BIT glClear
-
-GL_FLAT glShadeModel
-
-GL_PROJECTION glMatrixMode
-glLoadIdentity
--1 1 -1 1 1.5 200 glFrustum
-
-GL_MODELVIEW glMatrixMode
-
-glLoadIdentity
-
-camera> do-look-at
-
-GL_FRONT_AND_BACK GL_LINE glPolygonMode
-
-white color>raw glColor4d
-
-! white set-color
-
-GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
-
-color> set-color
-
-model> glCallList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: result>model ( -- )
-slate> find-gl-context
-model> GL_COMPILE glNewList result> interpret glEndList ;
-
-: build-model ( -- )
-tortoise-stack> delete-all
-vertices> delete-all
-reset-turtle
-default-values> call
-model-values> call
-result>model
-[ display ] closed-quot slate> set-slate-action
-slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: hashtables namespaces.lib ui.gadgets.handler ;
-
-: camera-action ( quot -- quot )
-[ drop [ ] camera> with-self slate> relayout-1 ] make* closed-quot ;
-
-VAR: frame
-VAR: handler
-
-DEFER: model-chooser
-DEFER: scene-chooser
-DEFER: empty-model
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: lsys-controller ( -- )
-
-<pile>
-
-{
-
-[ "Load" <label> reverse-video-theme ]
-
-[ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
-[ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
-
-[ "Model" <label> reverse-video-theme ]
-
-[ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
-[ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
-
-[ "Camera" <label> reverse-video-theme ]
-
-[ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
-[ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]
-[ "Pitch down" <label> [ 5 pitch-down ] camera-action <bevel-button> ]
-[ "Pitch up" <label> [ 5 pitch-up ] camera-action <bevel-button> ]
-
-[ "Forward - a" <label> [ 1 step-turtle ] camera-action <bevel-button> ]
-[ "Backward - z" <label> [ -1 step-turtle ] camera-action <bevel-button> ]
-
-[ "Roll left - q" <label> [ 5 roll-left ] camera-action <bevel-button> ]
-[ "Roll right - w" <label> [ 5 roll-right ] camera-action <bevel-button> ]
-
-[ "Strafe left - (alt)" <label> [ 1 strafe-left ] camera-action <bevel-button> ]
-[ "Strafe right - (alt)" <label> [ 1 strafe-right ] camera-action <bevel-button> ]
-[ "Strafe down - (alt)" <label> [ 1 strafe-up ] camera-action <bevel-button> ]
-[ "Strafe up - (alt)" <label> [ 1 strafe-down ] camera-action <bevel-button> ]
-
-[ "View 1 - 1" <label>
- [ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
- camera-action <bevel-button> ]
-
-[ "View 2 - 2" <label>
- [ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
- camera-action <bevel-button> ]
-
-[ "View 3 - 3" <label>
- [ pos> norm reset-turtle step-turtle 180 turn-left ]
- camera-action <bevel-button> ]
-
-[ "View 4 - 4" <label>
- [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
- camera-action <bevel-button> ]
-
-}
-
-[ call add-gadget ] each
-1 >>fill
-"L-system control" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: lsys-viewer ( -- )
-
-[ ] <slate> >slate
-{ 400 400 } clone slate> set-slate-pdim
-
-slate> <handler>
-
-{
-
-{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] camera-action ] }
-{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] camera-action ] }
-{ T{ key-down f f "UP" } [ [ 5 pitch-down ] camera-action ] }
-{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] camera-action ] }
-
-{ T{ key-down f f "a" } [ [ 1 step-turtle ] camera-action ] }
-{ T{ key-down f f "z" } [ [ -1 step-turtle ] camera-action ] }
-
-{ T{ key-down f f "q" } [ [ 5 roll-left ] camera-action ] }
-{ T{ key-down f f "w" } [ [ 5 roll-right ] camera-action ] }
-
-{ T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] camera-action ] }
-{ T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] camera-action ] }
-{ T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] camera-action ] }
-{ T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] camera-action ] }
-
-{ T{ key-down f f "1" }
- [ [ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
- camera-action ] }
-
-{ T{ key-down f f "2" }
- [ [ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
- camera-action ] }
-
-{ T{ key-down f f "3" }
-[ [ pos> norm reset-turtle step-turtle 180 turn-left ]
- camera-action ] }
-
-{ T{ key-down f f "4" }
-[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
- camera-action ] }
-
-} [ make* ] map >hashtable >>table
-
-"L-system view" open-window
-
-500 sleep
-
-slate> find-gl-context
-1 glGenLists >model
-
-<turtle> >camera
-
-[ camera> >self
- reset-turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left
-] with-scope
-
-init-color-table
-
-<tortoise> >self
-
-V{ } clone >tortoise-stack
-
-V{ } clone >vertices
-
-empty-model
-
-build-model
-
-;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Examples
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: koch ( -- ) lparser-dialect [ 90 >angle ] >model-values
-
-H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
- { "k" "[ c'(0.5) K]" }
- { "a" "[d <(120) d <(120) d ]" }
- { "b" "e" }
- { "e" "[^ '(.2887)f'(3.4758) &(180) +z{.-(120)f-(120)f}]" }
- { "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
-} >rules
-
-"K" >result ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: spiral-0 ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
-
-"[P]|[P]" >result
-
-H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
- { "A" "F+;'A" }
- { "B" "F!+F+;'B" }
- { "C" "F!^+F^+;'C" }
- { "D" "F!>^+F>^+;'D" }
-} >rules ;
-
-: spiral-0-scene ( -- )
-spiral-0
-22 iterations
-build-model
-[ reset-turtle 90 turn-left 16 step-turtle 180 turn-left ]
-camera> with-self slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tree-5 ( -- ) lparser-dialect [ 5 >angle 1 >thickness ] >model-values
-
-"c(4)FFS" >result
-
-H{ { "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 ;
-
-: tree-5-scene ( -- )
-tree-5
-9 iterations
-build-model
-[ reset-turtle 90 pitch-down -70 step-turtle 50 strafe-up ] camera> with-self
-slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-1 ( -- ) lparser-dialect [ 45 >angle 5 >thickness ] >model-values
-
-H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
- { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
- { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
-
- { "L" "~c(8){+(30)f-(120)f-(120)f}" }
-} >rules
-
-"c(12)FFAL" >result ;
-
-: abop-1-scene ( -- )
-abop-1
-8 iterations
-build-model
-[ reset-turtle
- 90 pitch-up 7 step-turtle 90 pitch-down 4 step-turtle 90 pitch-down ]
-camera> with-self slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-2 ( -- ) lparser-dialect [ 30 >angle 5 >thickness ] >model-values
-
-H{ { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
- { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
- { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
-
- { "L" "~c(8){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
-
-} >rules
-
-"c(12)FAL" >result ;
-
-: abop-2-scene ( -- )
-abop-2
-7 iterations
-build-model
-[ reset-turtle { 0 4 4 } >pos 90 pitch-down ]
-camera> with-self slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-3 ( -- ) lparser-dialect [ 30 >angle 5 >thickness ] >model-values
-
-H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
- { "B" "[&t(.4)F$A]" }
- { "F" "'(1.25)F'(.8)" }
-} >rules
-
-"c(12)FA" >result ;
-
-: abop-3-scene ( -- )
-abop-3 11 iterations build-model
-[ reset-turtle { 0 47 29 } >pos 90 pitch-down ] camera> with-self
-slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-4 ( -- ) lparser-dialect [ 18 >angle 5 >thickness ] >model-values
-
-H{ { "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
-
-"c(12)&(20)N" >result ;
-
-: abop-4-scene ( -- )
-abop-4 21 iterations build-model
-[ reset-turtle
- { 53 25 36 } >pos
- { { 0.57 -0.14 -0.80 } { -0.81 -0.18 -0.54 } { -0.07 0.97 -0.22 } }
- >ori
-] camera> with-self slate> relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5 ( -- ) lparser-dialect [ 5 >angle 5 >thickness ] >model-values
-
-H{ { "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
-
-"&(90)+(90)a" >result ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-6 ( -- ) lparser-dialect [ 5 >angle 5 >thickness ] >model-values
-
-"&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" >result
-
-H{ { "a" "F[cdx][cex]F!(.9)a" }
- { "x" "a" }
-
- { "d" "+d" }
- { "e" "-e" }
-
- { "F" "'(1.25)F'(.8)" }
-} >rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: airhorse ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
-
-"C" >result
-
-H{ { "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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: empty-model ( -- )
-lparser-dialect
-[ ] >model-values
-" " >result
-H{ } >rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: model-chooser ( -- )
-<pile>
-{
-[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
-[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
-[ "abop-3" <label> [ drop abop-3 build-model ] closed-quot <bevel-button> ]
-[ "abop-4" <label> [ drop abop-4 build-model ] closed-quot <bevel-button> ]
-[ "abop-5" <label> [ drop abop-5 build-model ] closed-quot <bevel-button> ]
-[ "abop-6" <label> [ drop abop-6 build-model ] closed-quot <bevel-button> ]
-[ "tree-5" <label> [ drop tree-5 build-model ] closed-quot <bevel-button> ]
-[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
-[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
-[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
-}
-[ call add-gadget ] each
-1 >>fill
-"L-system models" open-window ;
-
-: scene-chooser ( -- )
-<pile>
-{
-[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
-[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
-[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
-}
-[ call add-gadget ] each
-1 >>fill
-"L-system scenes" open-window ;
-
-: lsys-window* ( -- )
-[ lsys-controller lsys-viewer ] with-ui ;
-
-MAIN: lsys-window*
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math arrays math.vectors math.matrices generic.lib pos ori ;
-
-IN: turtle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: turtle ;
-
-: <turtle> ( -- turtle )
-turtle new
-{ 0 0 0 } clone <pos>
-3 identity-matrix <ori>
-rot
-3array chain ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-turtle ( -- ) { 0 0 0 } >pos 3 identity-matrix >ori ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-vector ( length -- array ) { 0 0 1 } n*v ;
-
-: step-turtle ( length -- ) step-vector ori> swap m.v pos> v+ >pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: strafe-up ( length -- )
-90 pitch-up
-step-turtle
-90 pitch-down ;
-
-: strafe-down ( length -- )
-90 pitch-down
-step-turtle
-90 pitch-up ;
-
-: strafe-left ( length -- )
-90 turn-left
-step-turtle
-90 turn-right ;
-
-: strafe-right ( length -- )
-90 turn-right
-step-turtle
-90 turn-left ;
WINDRES=windres
include vm/Config.windows.nt
include vm/Config.x86.32
-#error "lolllll"
-#WIN64_PATH=/k/MinGW/win64/bin
-#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe
include vm/Config.windows.nt
projects / factor.git / commitdiff