Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
a6a1b56169
|
|
@ -22,3 +22,4 @@ work
|
|||
build-support/wordsize
|
||||
*.bak
|
||||
.#*
|
||||
*.swo
|
||||
|
|
|
|||
|
|
@ -1,28 +1,52 @@
|
|||
USING: help.syntax help.markup kernel prettyprint sequences ;
|
||||
USING: help.syntax help.markup kernel prettyprint sequences
|
||||
io.pathnames ;
|
||||
IN: csv
|
||||
|
||||
HELP: csv
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "rows" "an array of arrays of fields" } }
|
||||
{ $description "parses a csv stream into an array of row arrays"
|
||||
} ;
|
||||
{ $description "Parses a csv stream into an array of row arrays." } ;
|
||||
|
||||
HELP: file>csv
|
||||
{ $values
|
||||
{ "path" pathname } { "encoding" "an encoding descriptor" }
|
||||
{ "csv" "csv" }
|
||||
}
|
||||
{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ;
|
||||
|
||||
HELP: csv>file
|
||||
{ $values
|
||||
{ "rows" "a sequence of sequences of strings" }
|
||||
{ "path" pathname } { "encoding" "an encoding descriptor" }
|
||||
}
|
||||
{ $description "Writes a comma-separated-value structure to a file." } ;
|
||||
|
||||
HELP: csv-row
|
||||
{ $values { "stream" "an input stream" }
|
||||
{ "row" "an array of fields" } }
|
||||
{ $description "parses a row from a csv stream"
|
||||
} ;
|
||||
{ $description "parses a row from a csv stream" } ;
|
||||
|
||||
HELP: write-csv
|
||||
{ $values { "rows" "an sequence of sequences of strings" }
|
||||
{ $values { "rows" "a sequence of sequences of strings" }
|
||||
{ "stream" "an output stream" } }
|
||||
{ $description "writes csv to the output stream, escaping where necessary"
|
||||
} ;
|
||||
|
||||
{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ;
|
||||
|
||||
HELP: with-delimiter
|
||||
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
|
||||
{ $values { "ch" "field delimiter (e.g. CHAR: \t)" }
|
||||
{ "quot" "a quotation" } }
|
||||
{ $description "Sets the field delimiter for csv or csv-row words "
|
||||
} ;
|
||||
{ $description "Sets the field delimiter for csv or csv-row words." } ;
|
||||
|
||||
ARTICLE: "csv" "Comma-separated-values parsing and writing"
|
||||
"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl
|
||||
"Reading a csv file:"
|
||||
{ $subsection file>csv }
|
||||
"Writing a csv file:"
|
||||
{ $subsection csv>file }
|
||||
"Changing the delimiter from a comma:"
|
||||
{ $subsection with-delimiter }
|
||||
"Reading from a stream:"
|
||||
{ $subsection csv }
|
||||
"Writing to a stream:"
|
||||
{ $subsection write-csv } ;
|
||||
|
||||
ABOUT: "csv"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
USING: io.streams.string csv tools.test shuffle kernel strings
|
||||
io.pathnames io.files.unique io.encodings.utf8 io.files
|
||||
io.directories ;
|
||||
IN: csv.tests
|
||||
USING: io.streams.string csv tools.test shuffle kernel strings ;
|
||||
|
||||
! I like to name my unit tests
|
||||
: named-unit-test ( name output input -- )
|
||||
|
|
@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ;
|
|||
"escapes quotes commas and newlines when writing"
|
||||
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
|
||||
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
|
||||
|
||||
[ { { "writing" "some" "csv" "tests" } } ]
|
||||
[
|
||||
"writing,some,csv,tests"
|
||||
"csv-test1-" unique-file utf8
|
||||
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
{ { "writing,some,csv,tests" } } dup "csv-test2-"
|
||||
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,89 +1,100 @@
|
|||
! Copyright (C) 2007, 2008 Phil Dawes
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! Simple CSV Parser
|
||||
! Phil Dawes phil@phildawes.net
|
||||
|
||||
USING: kernel sequences io namespaces make
|
||||
combinators unicode.categories ;
|
||||
USING: kernel sequences io namespaces make combinators
|
||||
unicode.categories io.files combinators.short-circuit ;
|
||||
IN: csv
|
||||
|
||||
SYMBOL: delimiter
|
||||
|
||||
CHAR: , delimiter set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: delimiter> ( -- delimiter ) delimiter get ; inline
|
||||
|
||||
DEFER: quoted-field ( -- endchar )
|
||||
|
||||
! trims whitespace from either end of string
|
||||
: trim-whitespace ( str -- str )
|
||||
[ blank? ] trim ; inline
|
||||
[ blank? ] trim ; inline
|
||||
|
||||
: skip-to-field-end ( -- endchar )
|
||||
"\n" delimiter> suffix read-until nip ; inline
|
||||
|
||||
: not-quoted-field ( -- endchar )
|
||||
"\"\n" delimiter> suffix read-until ! "
|
||||
dup
|
||||
{ { CHAR: " [ drop drop quoted-field ] } ! "
|
||||
{ delimiter> [ swap trim-whitespace % ] }
|
||||
{ CHAR: \n [ swap trim-whitespace % ] }
|
||||
{ f [ swap trim-whitespace % ] } ! eof
|
||||
} case ;
|
||||
"\"\n" delimiter> suffix read-until
|
||||
dup {
|
||||
{ CHAR: " [ 2drop quoted-field ] }
|
||||
{ delimiter> [ swap trim-whitespace % ] }
|
||||
{ CHAR: \n [ swap trim-whitespace % ] }
|
||||
{ f [ swap trim-whitespace % ] }
|
||||
} case ;
|
||||
|
||||
: maybe-escaped-quote ( -- endchar )
|
||||
read1 dup
|
||||
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
|
||||
{ delimiter> [ ] } ! end of quoted field
|
||||
{ CHAR: \n [ ] }
|
||||
[ 2drop skip-to-field-end ] ! end of quoted field + padding
|
||||
} case ;
|
||||
read1 dup {
|
||||
{ CHAR: " [ , quoted-field ] }
|
||||
{ delimiter> [ ] }
|
||||
{ CHAR: \n [ ] }
|
||||
[ 2drop skip-to-field-end ]
|
||||
} case ;
|
||||
|
||||
: quoted-field ( -- endchar )
|
||||
"\"" read-until ! "
|
||||
drop % maybe-escaped-quote ;
|
||||
"\"" read-until
|
||||
drop % maybe-escaped-quote ;
|
||||
|
||||
: field ( -- sep string )
|
||||
[ not-quoted-field ] "" make ; ! trim-whitespace
|
||||
[ not-quoted-field ] "" make ;
|
||||
|
||||
: (row) ( -- sep )
|
||||
field ,
|
||||
dup delimiter get = [ drop (row) ] when ;
|
||||
field ,
|
||||
dup delimiter get = [ drop (row) ] when ;
|
||||
|
||||
: row ( -- eof? array[string] )
|
||||
[ (row) ] { } make ;
|
||||
|
||||
: append-if-row-not-empty ( row -- )
|
||||
dup { "" } = [ drop ] [ , ] if ;
|
||||
[ (row) ] { } make ;
|
||||
|
||||
: (csv) ( -- )
|
||||
row append-if-row-not-empty
|
||||
[ (csv) ] when ;
|
||||
row harvest [ , ] unless-empty [ (csv) ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: csv-row ( stream -- row )
|
||||
[ row nip ] with-input-stream ;
|
||||
[ row nip ] with-input-stream ;
|
||||
|
||||
: csv ( stream -- rows )
|
||||
[ [ (csv) ] { } make ] with-input-stream ;
|
||||
[ [ (csv) ] { } make ] with-input-stream ;
|
||||
|
||||
: with-delimiter ( char quot -- )
|
||||
delimiter swap with-variable ; inline
|
||||
: file>csv ( path encoding -- csv )
|
||||
<file-reader> csv ;
|
||||
|
||||
: with-delimiter ( ch quot -- )
|
||||
[ delimiter ] dip with-variable ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: needs-escaping? ( cell -- ? )
|
||||
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
|
||||
[ { [ "\n\"" member? ] [ delimiter get = ] } 1|| ] any? ; inline
|
||||
|
||||
: escape-quotes ( cell -- cell' )
|
||||
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
|
||||
[
|
||||
[
|
||||
[ , ]
|
||||
[ dup CHAR: " = [ , ] [ drop ] if ] bi
|
||||
] each
|
||||
] "" make ; inline
|
||||
|
||||
: enclose-in-quotes ( cell -- cell' )
|
||||
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
|
||||
"\"" dup surround ; inline
|
||||
|
||||
: escape-if-required ( cell -- cell' )
|
||||
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
|
||||
dup needs-escaping?
|
||||
[ escape-quotes enclose-in-quotes ] when ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: write-row ( row -- )
|
||||
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
|
||||
[ delimiter get write1 ]
|
||||
[ escape-if-required write ] interleave nl ; inline
|
||||
|
||||
: write-csv ( rows stream -- )
|
||||
[ [ write-row ] each ] with-output-stream ;
|
||||
[ [ write-row ] each ] with-output-stream ;
|
||||
|
||||
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@ HELP: with-db
|
|||
HELP: with-transaction
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "" } ;
|
||||
{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
|
||||
|
||||
ARTICLE: "db" "Database library"
|
||||
"Accessing a database:"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes hashtables help.markup help.syntax io.streams.string
|
||||
kernel sequences strings math ;
|
||||
kernel sequences strings math db.tuples db.tuples.private ;
|
||||
IN: db.types
|
||||
|
||||
HELP: +db-assigned-id+
|
||||
|
|
@ -27,15 +27,11 @@ HELP: +user-assigned-id+
|
|||
|
||||
HELP: <generator-bind>
|
||||
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
|
||||
{ $description "" } ;
|
||||
{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
|
||||
|
||||
HELP: <literal-bind>
|
||||
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: <low-level-binding>
|
||||
{ $values { "value" object } { "low-level-binding" low-level-binding } }
|
||||
{ $description "" } ;
|
||||
{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
|
||||
|
||||
HELP: BIG-INTEGER
|
||||
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
|
||||
|
|
@ -100,18 +96,12 @@ HELP: user-assigned-id-spec?
|
|||
HELP: bind#
|
||||
{ $values
|
||||
{ "spec" "a sql spec" } { "obj" object } }
|
||||
{ $description "" } ;
|
||||
{ $description "A generic word that lets a database construct a literal binding." } ;
|
||||
|
||||
HELP: bind%
|
||||
{ $values
|
||||
{ "spec" "a sql spec" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: compound
|
||||
{ $values
|
||||
{ "string" string } { "obj" object }
|
||||
{ "hash" hashtable } }
|
||||
{ $description "" } ;
|
||||
{ $description "A generic word that lets a database output a binding." } ;
|
||||
|
||||
HELP: db-assigned-id-spec?
|
||||
{ $values
|
||||
|
|
@ -126,45 +116,12 @@ HELP: find-primary-key
|
|||
{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
|
||||
{ $notes "This is a low-level word." } ;
|
||||
|
||||
HELP: generator-bind
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: get-slot-named
|
||||
{ $values
|
||||
{ "name" "a slot name" } { "tuple" tuple }
|
||||
{ "value" "the value stored in the slot" } }
|
||||
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
|
||||
|
||||
HELP: literal-bind
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: lookup-create-type
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "string" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: lookup-modifier
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "string" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: lookup-type
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "string" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: low-level-binding
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: modifiers
|
||||
{ $values
|
||||
{ "spec" "a sql spec" }
|
||||
{ "string" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: no-sql-type
|
||||
{ $values
|
||||
{ "type" "a sql type" } }
|
||||
|
|
@ -173,7 +130,7 @@ HELP: no-sql-type
|
|||
HELP: normalize-spec
|
||||
{ $values
|
||||
{ "spec" "a sql spec" } }
|
||||
{ $description "" } ;
|
||||
{ $description "Normalizes a sql spec." } ;
|
||||
|
||||
HELP: offset-of-slot
|
||||
{ $values
|
||||
|
|
@ -181,52 +138,20 @@ HELP: offset-of-slot
|
|||
{ "n" integer } }
|
||||
{ $description "Returns the offset of a tuple slot accessed by name." } ;
|
||||
|
||||
HELP: persistent-table
|
||||
{ $values
|
||||
|
||||
{ "hash" hashtable } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: primary-key?
|
||||
{ $values
|
||||
{ "spec" "a sql spec" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "" } ;
|
||||
{ $description "Returns true if a sql spec is a primary key." } ;
|
||||
|
||||
HELP: random-id-generator
|
||||
{ $description "" } ;
|
||||
{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
|
||||
|
||||
HELP: relation?
|
||||
{ $values
|
||||
{ "spec" "a sql spec" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: remove-db-assigned-id
|
||||
{ $values
|
||||
{ "specs" "a sequence of sql specs" }
|
||||
{ "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: remove-id
|
||||
{ $values
|
||||
{ "specs" "a sequence of sql specs" }
|
||||
{ "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-slot-named
|
||||
{ $values
|
||||
{ "value" object } { "name" string } { "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: spec>tuple
|
||||
{ $values
|
||||
{ "class" class } { "spec" "a sql spec" }
|
||||
{ "tuple" tuple } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: sql-spec
|
||||
{ $description "" } ;
|
||||
{ $description "Returns true if a sql spec is a relation." } ;
|
||||
|
||||
HELP: unknown-modifier
|
||||
{ $values { "modifier" string } }
|
||||
|
|
|
|||
|
|
@ -7,12 +7,14 @@ HELP: (os-envs)
|
|||
{ $values
|
||||
|
||||
{ "seq" sequence } }
|
||||
{ $description "" } ;
|
||||
{ $description "Returns a sequence of key/value pairs from the operating system." }
|
||||
{ $notes "In most cases, use " { $link os-envs } " instead." } ;
|
||||
|
||||
HELP: (set-os-envs)
|
||||
{ $values
|
||||
{ "seq" sequence } }
|
||||
{ $description "" } ;
|
||||
{ $description "Low-level word for replacing the current set of environment variables." }
|
||||
{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
|
||||
|
||||
|
||||
HELP: os-env ( key -- value )
|
||||
|
|
|
|||
|
|
@ -12,17 +12,19 @@ HELP: printf
|
|||
"specifying attributes for the result string, including such things as maximum width, "
|
||||
"padding, and decimals.\n"
|
||||
{ $table
|
||||
{ "%%" "Single %" "" }
|
||||
{ "%P.Ds" "String format" "string" }
|
||||
{ "%P.DS" "String format uppercase" "string" }
|
||||
{ "%c" "Character format" "char" }
|
||||
{ "%C" "Character format uppercase" "char" }
|
||||
{ "%+Pd" "Integer format" "fixnum" }
|
||||
{ "%+P.De" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.DE" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.Df" "Fixed format" "fixnum, float" }
|
||||
{ "%+Px" "Hexadecimal" "hex" }
|
||||
{ "%+PX" "Hexadecimal uppercase" "hex" }
|
||||
{ "%%" "Single %" "" }
|
||||
{ "%P.Ds" "String format" "string" }
|
||||
{ "%P.DS" "String format uppercase" "string" }
|
||||
{ "%c" "Character format" "char" }
|
||||
{ "%C" "Character format uppercase" "char" }
|
||||
{ "%+Pd" "Integer format" "fixnum" }
|
||||
{ "%+P.De" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.DE" "Scientific notation" "fixnum, float" }
|
||||
{ "%+P.Df" "Fixed format" "fixnum, float" }
|
||||
{ "%+Px" "Hexadecimal" "hex" }
|
||||
{ "%+PX" "Hexadecimal uppercase" "hex" }
|
||||
{ "%[%?, %]" "Sequence format" "sequence" }
|
||||
{ "%[%?: %? %]" "Assocs format" "assocs" }
|
||||
}
|
||||
$nl
|
||||
"A plus sign ('+') is used to optionally specify that the number should be "
|
||||
|
|
@ -72,6 +74,14 @@ HELP: printf
|
|||
"USING: formatting ;"
|
||||
"1234 \"%+d\" printf"
|
||||
"+1234" }
|
||||
{ $example
|
||||
"USING: formatting ;"
|
||||
"{ 1 2 3 } \"%[%d, %]\" printf"
|
||||
"{ 1, 2, 3 }" }
|
||||
{ $example
|
||||
"USING: formatting ;"
|
||||
"H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf"
|
||||
"{ 1:2, 3:4 }" }
|
||||
} ;
|
||||
|
||||
HELP: sprintf
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays ascii calendar combinators fry kernel
|
||||
USING: accessors arrays ascii assocs calendar combinators fry kernel
|
||||
generalizations io io.encodings.ascii io.files io.streams.string
|
||||
macros math math.functions math.parser peg.ebnf quotations
|
||||
sequences splitting strings unicode.case vectors ;
|
||||
|
|
@ -75,8 +75,8 @@ digits = (digits_)? => [[ 6 or ]]
|
|||
fmt-% = "%" => [[ [ "%" ] ]]
|
||||
fmt-c = "c" => [[ [ 1string ] ]]
|
||||
fmt-C = "C" => [[ [ 1string >upper ] ]]
|
||||
fmt-s = "s" => [[ [ ] ]]
|
||||
fmt-S = "S" => [[ [ >upper ] ]]
|
||||
fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
|
||||
fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
|
||||
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
|
||||
fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
|
||||
fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
|
||||
|
|
@ -91,7 +91,13 @@ strings = pad width strings_ => [[ reverse compose-all ]]
|
|||
numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
|
||||
numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
|
||||
|
||||
formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
|
||||
types = strings|numbers
|
||||
|
||||
lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]]
|
||||
|
||||
assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]]
|
||||
|
||||
formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]]
|
||||
|
||||
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ HELP: modify-redirect-query
|
|||
|
||||
HELP: nested-responders
|
||||
{ $values { "seq" "a sequence of responders" } }
|
||||
{ $description "" } ;
|
||||
{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ;
|
||||
|
||||
HELP: referrer
|
||||
{ $values { "referrer/f" { $maybe string } } }
|
||||
|
|
@ -69,11 +69,11 @@ HELP: request-params
|
|||
|
||||
HELP: resolve-base-path
|
||||
{ $values { "string" string } { "string'" string } }
|
||||
{ $description "" } ;
|
||||
{ $description "Resolves a responder-relative URL." } ;
|
||||
|
||||
HELP: resolve-template-path
|
||||
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
{ $description "Resolves a responder-relative template path." } ;
|
||||
|
||||
HELP: same-host?
|
||||
{ $values { "url" url } { "?" "a boolean" } }
|
||||
|
|
@ -85,7 +85,7 @@ HELP: user-agent
|
|||
|
||||
HELP: vocab-path
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
{ $description "Outputs the full pathname of the vocabulary's source directory." } ;
|
||||
|
||||
HELP: exit-with
|
||||
{ $values { "value" object } }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators generic assocs help http io io.styles
|
||||
USING: combinators generic assocs io io.styles
|
||||
io.files continuations io.streams.string kernel math math.order
|
||||
math.parser namespaces make quotations assocs sequences strings
|
||||
words html.elements xml.entities sbufs continuations destructors
|
||||
|
|
|
|||
|
|
@ -242,7 +242,7 @@ HELP: shift-mod
|
|||
{ "n" integer } { "s" integer } { "w" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
|
||||
|
||||
HELP: unmask
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -1,36 +1,43 @@
|
|||
USING: alien alien.c-types alien.syntax kernel system combinators ;
|
||||
IN: math.blas.cblas
|
||||
|
||||
<< "cblas" {
|
||||
<<
|
||||
: load-atlas ( -- )
|
||||
"atlas" "libatlas.so" "cdecl" add-library ;
|
||||
: load-blas ( -- )
|
||||
"blas" "libblas.so" "cdecl" add-library ;
|
||||
|
||||
"cblas" {
|
||||
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
|
||||
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
|
||||
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
|
||||
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
|
||||
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
|
||||
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
|
||||
[ "libblas.so" "cdecl" add-library ]
|
||||
} cond >>
|
||||
} cond
|
||||
>>
|
||||
|
||||
LIBRARY: cblas
|
||||
|
||||
TYPEDEF: int CBLAS_ORDER
|
||||
: CblasRowMajor 101 ; inline
|
||||
: CblasColMajor 102 ; inline
|
||||
CONSTANT: CblasRowMajor 101
|
||||
CONSTANT: CblasColMajor 102
|
||||
|
||||
TYPEDEF: int CBLAS_TRANSPOSE
|
||||
: CblasNoTrans 111 ; inline
|
||||
: CblasTrans 112 ; inline
|
||||
: CblasConjTrans 113 ; inline
|
||||
CONSTANT: CblasNoTrans 111
|
||||
CONSTANT: CblasTrans 112
|
||||
CONSTANT: CblasConjTrans 113
|
||||
|
||||
TYPEDEF: int CBLAS_UPLO
|
||||
: CblasUpper 121 ; inline
|
||||
: CblasLower 122 ; inline
|
||||
CONSTANT: CblasUpper 121
|
||||
CONSTANT: CblasLower 122
|
||||
|
||||
TYPEDEF: int CBLAS_DIAG
|
||||
: CblasNonUnit 131 ; inline
|
||||
: CblasUnit 132 ; inline
|
||||
CONSTANT: CblasNonUnit 131
|
||||
CONSTANT: CblasUnit 132
|
||||
|
||||
TYPEDEF: int CBLAS_SIDE
|
||||
: CblasLeft 141 ; inline
|
||||
: CblasRight 142 ; inline
|
||||
CONSTANT: CblasLeft 141
|
||||
CONSTANT: CblasRight 142
|
||||
|
||||
TYPEDEF: int CBLAS_INDEX
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
|
||||
USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
|
||||
IN: math.blas.matrices
|
||||
|
||||
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
|
||||
|
|
@ -21,8 +21,6 @@ ARTICLE: "math.blas-types" "BLAS interface types"
|
|||
{ $subsection double-blas-matrix }
|
||||
{ $subsection float-complex-blas-matrix }
|
||||
{ $subsection double-complex-blas-matrix }
|
||||
"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
|
||||
{ $subsection "math.blas.syntax" }
|
||||
"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
|
||||
{ $subsection <float-blas-vector> }
|
||||
{ $subsection <double-blas-vector> }
|
||||
|
|
@ -74,7 +72,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
|
|||
{ $subsection n*M! }
|
||||
{ $subsection n*M }
|
||||
{ $subsection M*n }
|
||||
{ $subsection M/n } ;
|
||||
{ $subsection M/n }
|
||||
"Literal syntax:"
|
||||
{ $subsection POSTPONE: smatrix{ }
|
||||
{ $subsection POSTPONE: dmatrix{ }
|
||||
{ $subsection POSTPONE: cmatrix{ }
|
||||
{ $subsection POSTPONE: zmatrix{ } ;
|
||||
|
||||
|
||||
ABOUT: "math.blas.matrices"
|
||||
|
||||
|
|
@ -243,3 +247,43 @@ HELP: <empty-vector>
|
|||
{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
|
||||
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
|
||||
|
||||
HELP: smatrix{
|
||||
{ $syntax <" smatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 1.0 0.0 2.0 }
|
||||
{ 0.0 0.0 1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 1.0 }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: dmatrix{
|
||||
{ $syntax <" dmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 1.0 0.0 2.0 }
|
||||
{ 0.0 0.0 1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 1.0 }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: cmatrix{
|
||||
{ $syntax <" cmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
|
||||
{ 0.0 0.0 -1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: zmatrix{
|
||||
{ $syntax <" zmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
|
||||
{ 0.0 0.0 -1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
{
|
||||
POSTPONE: smatrix{ POSTPONE: dmatrix{
|
||||
POSTPONE: cmatrix{ POSTPONE: zmatrix{
|
||||
} related-words
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
|
||||
USING: kernel math.blas.matrices math.blas.vectors
|
||||
sequences tools.test ;
|
||||
IN: math.blas.matrices.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ math math.blas.cblas math.blas.vectors math.blas.vectors.private
|
|||
math.complex math.functions math.order functors words
|
||||
sequences sequences.merged sequences.private shuffle
|
||||
specialized-arrays.direct.float specialized-arrays.direct.double
|
||||
specialized-arrays.float specialized-arrays.double ;
|
||||
specialized-arrays.float specialized-arrays.double
|
||||
parser prettyprint.backend prettyprint.custom ;
|
||||
IN: math.blas.matrices
|
||||
|
||||
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
|
||||
|
|
@ -258,6 +259,7 @@ XGERC IS cblas_${T}ger${C}
|
|||
MATRIX DEFINES ${TYPE}-blas-matrix
|
||||
<MATRIX> DEFINES <${TYPE}-blas-matrix>
|
||||
>MATRIX DEFINES >${TYPE}-blas-matrix
|
||||
XMATRIX{ DEFINES ${T}matrix{
|
||||
|
||||
WHERE
|
||||
|
||||
|
|
@ -291,6 +293,11 @@ M: MATRIX n*V(*)Vconj+M!
|
|||
[ TYPE>ARG ] (prepare-ger)
|
||||
[ XGERC ] dip ;
|
||||
|
||||
: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
|
||||
|
||||
M: MATRIX pprint-delims
|
||||
drop \ XMATRIX{ \ } ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
|
|
@ -305,3 +312,6 @@ M: MATRIX n*V(*)Vconj+M!
|
|||
"double-complex" "z" define-complex-blas-matrix
|
||||
|
||||
>>
|
||||
|
||||
M: blas-matrix-base >pprint-sequence Mrows ;
|
||||
M: blas-matrix-base pprint* pprint-object ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Literal syntax for BLAS vectors and matrices
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
|
||||
IN: math.blas.syntax
|
||||
|
||||
ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
|
||||
"Vectors:"
|
||||
{ $subsection POSTPONE: svector{ }
|
||||
{ $subsection POSTPONE: dvector{ }
|
||||
{ $subsection POSTPONE: cvector{ }
|
||||
{ $subsection POSTPONE: zvector{ }
|
||||
"Matrices:"
|
||||
{ $subsection POSTPONE: smatrix{ }
|
||||
{ $subsection POSTPONE: dmatrix{ }
|
||||
{ $subsection POSTPONE: cmatrix{ }
|
||||
{ $subsection POSTPONE: zmatrix{ } ;
|
||||
|
||||
ABOUT: "math.blas.syntax"
|
||||
|
||||
HELP: svector{
|
||||
{ $syntax "svector{ 1.0 -2.0 3.0 }" }
|
||||
{ $description "Construct a literal " { $link float-blas-vector } "." } ;
|
||||
|
||||
HELP: dvector{
|
||||
{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
|
||||
{ $description "Construct a literal " { $link double-blas-vector } "." } ;
|
||||
|
||||
HELP: cvector{
|
||||
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
|
||||
{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
|
||||
|
||||
HELP: zvector{
|
||||
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
|
||||
{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
|
||||
|
||||
{
|
||||
POSTPONE: svector{ POSTPONE: dvector{
|
||||
POSTPONE: cvector{ POSTPONE: zvector{
|
||||
} related-words
|
||||
|
||||
HELP: smatrix{
|
||||
{ $syntax <" smatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 1.0 0.0 2.0 }
|
||||
{ 0.0 0.0 1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 1.0 }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: dmatrix{
|
||||
{ $syntax <" dmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 1.0 0.0 2.0 }
|
||||
{ 0.0 0.0 1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 1.0 }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: cmatrix{
|
||||
{ $syntax <" cmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
|
||||
{ 0.0 0.0 -1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
HELP: zmatrix{
|
||||
{ $syntax <" zmatrix{
|
||||
{ 1.0 0.0 0.0 1.0 }
|
||||
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
|
||||
{ 0.0 0.0 -1.0 3.0 }
|
||||
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
|
||||
} "> }
|
||||
{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
|
||||
|
||||
{
|
||||
POSTPONE: smatrix{ POSTPONE: dmatrix{
|
||||
POSTPONE: cmatrix{ POSTPONE: zmatrix{
|
||||
} related-words
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
USING: kernel math.blas.vectors math.blas.matrices parser
|
||||
arrays prettyprint.backend prettyprint.custom sequences ;
|
||||
IN: math.blas.syntax
|
||||
|
||||
: svector{
|
||||
\ } [ >float-blas-vector ] parse-literal ; parsing
|
||||
: dvector{
|
||||
\ } [ >double-blas-vector ] parse-literal ; parsing
|
||||
: cvector{
|
||||
\ } [ >float-complex-blas-vector ] parse-literal ; parsing
|
||||
: zvector{
|
||||
\ } [ >double-complex-blas-vector ] parse-literal ; parsing
|
||||
|
||||
: smatrix{
|
||||
\ } [ >float-blas-matrix ] parse-literal ; parsing
|
||||
: dmatrix{
|
||||
\ } [ >double-blas-matrix ] parse-literal ; parsing
|
||||
: cmatrix{
|
||||
\ } [ >float-complex-blas-matrix ] parse-literal ; parsing
|
||||
: zmatrix{
|
||||
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
|
||||
|
||||
M: float-blas-vector pprint-delims
|
||||
drop \ svector{ \ } ;
|
||||
M: double-blas-vector pprint-delims
|
||||
drop \ dvector{ \ } ;
|
||||
M: float-complex-blas-vector pprint-delims
|
||||
drop \ cvector{ \ } ;
|
||||
M: double-complex-blas-vector pprint-delims
|
||||
drop \ zvector{ \ } ;
|
||||
|
||||
M: float-blas-matrix pprint-delims
|
||||
drop \ smatrix{ \ } ;
|
||||
M: double-blas-matrix pprint-delims
|
||||
drop \ dmatrix{ \ } ;
|
||||
M: float-complex-blas-matrix pprint-delims
|
||||
drop \ cmatrix{ \ } ;
|
||||
M: double-complex-blas-matrix pprint-delims
|
||||
drop \ zmatrix{ \ } ;
|
||||
|
||||
M: blas-vector-base >pprint-sequence ;
|
||||
M: blas-vector-base pprint* pprint-object ;
|
||||
M: blas-matrix-base >pprint-sequence Mrows ;
|
||||
M: blas-matrix-base pprint* pprint-object ;
|
||||
|
|
@ -23,7 +23,12 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
|
|||
{ $subsection V- }
|
||||
"Vector inner products:"
|
||||
{ $subsection V. }
|
||||
{ $subsection V.conj } ;
|
||||
{ $subsection V.conj }
|
||||
"Literal syntax:"
|
||||
{ $subsection POSTPONE: svector{ }
|
||||
{ $subsection POSTPONE: dvector{ }
|
||||
{ $subsection POSTPONE: cvector{ }
|
||||
{ $subsection POSTPONE: zvector{ } ;
|
||||
|
||||
ABOUT: "math.blas.vectors"
|
||||
|
||||
|
|
@ -129,3 +134,25 @@ HELP: V/n
|
|||
HELP: Vsub
|
||||
{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
|
||||
{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
|
||||
|
||||
HELP: svector{
|
||||
{ $syntax "svector{ 1.0 -2.0 3.0 }" }
|
||||
{ $description "Construct a literal " { $link float-blas-vector } "." } ;
|
||||
|
||||
HELP: dvector{
|
||||
{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
|
||||
{ $description "Construct a literal " { $link double-blas-vector } "." } ;
|
||||
|
||||
HELP: cvector{
|
||||
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
|
||||
{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
|
||||
|
||||
HELP: zvector{
|
||||
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
|
||||
{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
|
||||
|
||||
{
|
||||
POSTPONE: svector{ POSTPONE: dvector{
|
||||
POSTPONE: cvector{ POSTPONE: zvector{
|
||||
} related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
|
||||
USING: kernel math.blas.vectors sequences tools.test ;
|
||||
IN: math.blas.vectors.tests
|
||||
|
||||
! clone
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators
|
|||
combinators.short-circuit fry kernel math math.blas.cblas
|
||||
math.complex math.functions math.order sequences.complex
|
||||
sequences.complex-components sequences sequences.private
|
||||
functors words locals
|
||||
functors words locals parser prettyprint.backend prettyprint.custom
|
||||
specialized-arrays.float specialized-arrays.double
|
||||
specialized-arrays.direct.float specialized-arrays.direct.double ;
|
||||
IN: math.blas.vectors
|
||||
|
|
@ -138,6 +138,8 @@ VECTOR DEFINES ${TYPE}-blas-vector
|
|||
<VECTOR> DEFINES <${TYPE}-blas-vector>
|
||||
>VECTOR DEFINES >${TYPE}-blas-vector
|
||||
|
||||
XVECTOR{ DEFINES ${T}vector{
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: VECTOR < blas-vector-base ;
|
||||
|
|
@ -165,6 +167,11 @@ M: VECTOR (blas-direct-array)
|
|||
[ [ length>> ] [ inc>> ] bi * ] bi
|
||||
<DIRECT-ARRAY> ;
|
||||
|
||||
: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
|
||||
|
||||
M: VECTOR pprint-delims
|
||||
drop \ XVECTOR{ \ } ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
||||
|
|
@ -270,3 +277,5 @@ M: VECTOR n*V!
|
|||
|
||||
>>
|
||||
|
||||
M: blas-vector-base >pprint-sequence ;
|
||||
M: blas-vector-base pprint* pprint-object ;
|
||||
|
|
|
|||
|
|
@ -52,13 +52,10 @@ IN: uuid
|
|||
: string>uuid ( string -- n )
|
||||
[ CHAR: - = not ] filter 16 base> ;
|
||||
|
||||
: uuid>byte-array ( n -- byte-array )
|
||||
16 >be ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: uuid-parse ( string -- byte-array )
|
||||
string>uuid uuid>byte-array ;
|
||||
string>uuid 16 >be ;
|
||||
|
||||
: uuid-unparse ( byte-array -- string )
|
||||
be> uuid>string ;
|
||||
|
|
|
|||
|
|
@ -52,9 +52,15 @@ SYMBOL: rule-sets
|
|||
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
|
||||
dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
|
||||
|
||||
DEFER: finalize-rule-set
|
||||
|
||||
: resolve-delegate ( rule -- )
|
||||
dup delegate>> dup string?
|
||||
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
|
||||
dup delegate>> dup string? [
|
||||
get-rule-set
|
||||
dup rule-set? [ "not a rule set" throw ] unless
|
||||
swap rule-sets [ dup finalize-rule-set ] with-variable
|
||||
>>delegate drop
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: each-rule ( rule-set quot -- )
|
||||
[ rules>> values concat ] dip each ; inline
|
||||
|
|
@ -74,26 +80,22 @@ SYMBOL: rule-sets
|
|||
: resolve-imports ( ruleset -- )
|
||||
dup imports>> [
|
||||
get-rule-set swap rule-sets [
|
||||
dup resolve-delegates
|
||||
2dup import-keywords
|
||||
import-rules
|
||||
[ nip resolve-delegates ]
|
||||
[ import-keywords ]
|
||||
[ import-rules ]
|
||||
2tri
|
||||
] with-variable
|
||||
] with each ;
|
||||
|
||||
ERROR: mutually-recursive-rulesets ruleset ;
|
||||
|
||||
: finalize-rule-set ( ruleset -- )
|
||||
dup finalized?>> {
|
||||
{ f [
|
||||
{
|
||||
[ 1 >>finalized? drop ]
|
||||
[ resolve-imports ]
|
||||
[ resolve-delegates ]
|
||||
[ t >>finalized? drop ]
|
||||
} cleave
|
||||
] }
|
||||
{ t [ drop ] }
|
||||
{ 1 [ mutually-recursive-rulesets ] }
|
||||
} case ;
|
||||
dup finalized?>> [ drop ] [
|
||||
t >>finalized?
|
||||
[ resolve-imports ]
|
||||
[ resolve-delegates ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: finalize-mode ( rulesets -- )
|
||||
rule-sets [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: xmode.code2html.tests
|
||||
USING: xmode.code2html xmode.catalog
|
||||
tools.test multiline splitting memoize
|
||||
kernel ;
|
||||
kernel io.streams.string xml.writer ;
|
||||
|
||||
[ ] [ \ (load-mode) reset-memoized ] unit-test
|
||||
|
||||
|
|
@ -9,4 +9,11 @@ kernel ;
|
|||
<" <style type="text/css" media="screen" >
|
||||
* {margin:0; padding:0; border:0;} ">
|
||||
string-lines "html" htmlize-lines drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test.c"
|
||||
<" int x = "hi";
|
||||
/* a comment */ "> <string-reader> htmlize-stream
|
||||
write-xml
|
||||
] unit-test
|
||||
|
|
@ -8,14 +8,14 @@ IN: xmode.code2html
|
|||
[ str>> ] [ id>> ] bi [
|
||||
name>> swap
|
||||
[XML <span class=<->><-></span> XML]
|
||||
] [ ] if*
|
||||
] when*
|
||||
] map ;
|
||||
|
||||
: htmlize-line ( line-context line rules -- line-context' xml )
|
||||
tokenize-line htmlize-tokens ;
|
||||
|
||||
: htmlize-lines ( lines mode -- xml )
|
||||
[ f ] 2dip load-mode [ htmlize-line ] curry map nip ;
|
||||
[ f ] 2dip load-mode [ htmlize-line "\n" suffix ] curry map nip ;
|
||||
|
||||
: default-stylesheet ( -- xml )
|
||||
"resource:basis/xmode/code2html/stylesheet.css"
|
||||
|
|
@ -24,7 +24,7 @@ IN: xmode.code2html
|
|||
|
||||
:: htmlize-stream ( path stream -- xml )
|
||||
stream lines
|
||||
[ "" ] [ first find-mode path swap htmlize-lines ]
|
||||
[ "" ] [ path over first find-mode htmlize-lines ]
|
||||
if-empty :> input
|
||||
default-stylesheet :> stylesheet
|
||||
<XML <html>
|
||||
|
|
|
|||
|
|
@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
|
|||
shared-tag-attrs match-type-attr literal-start ;
|
||||
|
||||
TAG: KEYWORDS ( rule-set tag -- key value )
|
||||
ignore-case? get <keyword-map>
|
||||
rule-set get ignore-case?>> <keyword-map>
|
||||
swap child-tags [ over parse-keyword-tag ] each
|
||||
swap (>>keywords) ;
|
||||
|
||||
TAGS>
|
||||
|
||||
: ?<regexp> ( string/f -- regexp/f )
|
||||
dup [ ignore-case? get <regexp> ] when ;
|
||||
dup [ rule-set get ignore-case?>> <regexp> ] when ;
|
||||
|
||||
: (parse-rules-tag) ( tag -- rule-set )
|
||||
<rule-set>
|
||||
<rule-set> dup rule-set set
|
||||
{
|
||||
{ "SET" string>rule-set-name (>>name) }
|
||||
{ "IGNORE_CASE" string>boolean (>>ignore-case?) }
|
||||
|
|
@ -65,11 +65,11 @@ TAGS>
|
|||
} init-from-tag ;
|
||||
|
||||
: parse-rules-tag ( tag -- rule-set )
|
||||
dup (parse-rules-tag) [
|
||||
dup ignore-case?>> ignore-case? [
|
||||
swap child-tags [ parse-rule-tag ] with each
|
||||
] with-variable
|
||||
] keep ;
|
||||
[
|
||||
[ (parse-rules-tag) ] [ child-tags ] bi
|
||||
[ parse-rule-tag ] with each
|
||||
rule-set get
|
||||
] with-scope ;
|
||||
|
||||
: merge-rule-set-props ( props rule-set -- )
|
||||
[ assoc-union ] change-props drop ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
|
||||
xml.data xml.utilities xml assocs kernel combinators sequences
|
||||
math.parser namespaces make parser lexer xmode.utilities
|
||||
parser-combinators.regexp io.files ;
|
||||
parser-combinators.regexp io.files splitting arrays ;
|
||||
IN: xmode.loader.syntax
|
||||
|
||||
SYMBOL: ignore-case?
|
||||
|
||||
! Rule tag parsing utilities
|
||||
: (parse-rule-tag) ( rule-set tag specs class -- )
|
||||
new swap init-from-tag swap add-rule ; inline
|
||||
|
|
@ -44,16 +42,19 @@ SYMBOL: ignore-case?
|
|||
|
||||
: parse-literal-matcher ( tag -- matcher )
|
||||
dup children>string
|
||||
ignore-case? get <string-matcher>
|
||||
rule-set get ignore-case?>> <string-matcher>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
: parse-regexp-matcher ( tag -- matcher )
|
||||
dup children>string ignore-case? get <regexp>
|
||||
dup children>string rule-set get ignore-case?>> <regexp>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
: shared-tag-attrs ( -- )
|
||||
{ "TYPE" string>token (>>body-token) } , ; inline
|
||||
|
||||
: parse-delegate ( string -- pair )
|
||||
"::" split1 [ rule-set get swap ] unless* 2array ;
|
||||
|
||||
: delegate-attr ( -- )
|
||||
{ "DELEGATE" f (>>delegate) } , ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors kernel ;
|
||||
USING: accessors kernel xmode.rules ;
|
||||
IN: xmode.marker.context
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
|
||||
|
|
@ -10,7 +10,7 @@ end
|
|||
;
|
||||
|
||||
: <line-context> ( ruleset parent -- line-context )
|
||||
over [ "no context" throw ] unless
|
||||
over rule-set? [ "not a rule-set" throw ] unless
|
||||
line-context new
|
||||
swap >>parent
|
||||
swap >>in-rule-set ;
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ M: seq-rule handle-rule-start
|
|||
mark-token
|
||||
add-remaining-token
|
||||
tuck body-token>> next-token,
|
||||
delegate>> [ push-context ] when* ;
|
||||
get-delegate [ push-context ] when* ;
|
||||
|
||||
UNION: abstract-span-rule span-rule eol-span-rule ;
|
||||
|
||||
|
|
@ -168,7 +168,7 @@ M: abstract-span-rule handle-rule-start
|
|||
tuck rule-match-token* next-token,
|
||||
! ... end subst ...
|
||||
dup context get (>>in-rule)
|
||||
delegate>> push-context ;
|
||||
get-delegate push-context ;
|
||||
|
||||
M: span-rule handle-rule-end
|
||||
2drop ;
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ IN: benchmark.knucleotide
|
|||
tuck length
|
||||
small-groups H{ } tally
|
||||
at [ 0 ] unless*
|
||||
number>string 8 CHAR: \s pad-right write ;
|
||||
number>string 8 CHAR: \s pad-tail write ;
|
||||
|
||||
: process-input ( input -- )
|
||||
dup 1 handle-table nl
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test constructors calendar kernel accessors
|
||||
combinators.short-circuit ;
|
||||
IN: constructors.tests
|
||||
|
||||
TUPLE: stock-spread stock spread timestamp ;
|
||||
|
||||
CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
|
||||
now >>timestamp ;
|
||||
|
||||
SYMBOL: AAPL
|
||||
|
||||
[ t ] [
|
||||
AAPL 1234 <stock-spread>
|
||||
{
|
||||
[ stock>> AAPL eq? ]
|
||||
[ spread>> 1234 = ]
|
||||
[ timestamp>> timestamp? ]
|
||||
} 1&&
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: slots kernel sequences fry accessors parser lexer words
|
||||
effects.parser macros ;
|
||||
IN: constructors
|
||||
|
||||
! An experiment
|
||||
|
||||
MACRO: set-slots ( slots -- quot )
|
||||
<reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
|
||||
|
||||
: construct ( ... class slots -- instance )
|
||||
[ new ] dip set-slots ; inline
|
||||
|
||||
: define-constructor ( name class effect body -- )
|
||||
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
|
||||
define-declared ;
|
||||
|
||||
: CONSTRUCTOR:
|
||||
scan-word [ name>> "<" ">" surround create-in ] keep
|
||||
"(" expect ")" parse-effect
|
||||
parse-definition
|
||||
define-constructor ; parsing
|
||||
|
|
@ -2,15 +2,15 @@
|
|||
! 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 ;
|
||||
help.markup help.topics io io.streams.string kernel make 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 )
|
||||
: fuel-find-word ( name -- word/f )
|
||||
[ [ name>> ] dip = ] curry all-words swap filter
|
||||
dup empty? not [ first ] [ drop f ] if ;
|
||||
|
||||
|
|
@ -102,11 +102,11 @@ PRIVATE>
|
|||
: (fuel-vocab-help) ( name -- str )
|
||||
dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-element) ] if ;
|
||||
|
||||
MEMO: (fuel-get-vocabs/author) ( author -- element )
|
||||
: (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 )
|
||||
: (fuel-get-vocabs/tag) ( tag -- element )
|
||||
[ "Vocabularies tagged " prepend \ $heading swap 2array ]
|
||||
[ tagged fuel-vocab-list ] bi 2array ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ GENERIC: fuel-pprint ( obj -- )
|
|||
<PRIVATE
|
||||
|
||||
: fuel-maybe-scape ( ch -- seq )
|
||||
dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
dup "\\\"?#()[]'`;" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
|
||||
SYMBOL: :restarts
|
||||
|
||||
|
|
|
|||
|
|
@ -11,4 +11,10 @@ IN: literals.tests
|
|||
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
|
||||
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
|
||||
|
||||
[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
|
||||
|
||||
[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
|
||||
|
||||
[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
|
||||
|
||||
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! (c) Joe Groff, see license for details
|
||||
USING: continuations kernel parser words quotations ;
|
||||
USING: continuations kernel parser words quotations vectors ;
|
||||
IN: literals
|
||||
|
||||
: $ scan-word [ execute ] curry with-datastack ; parsing
|
||||
: $[ \ ] parse-until >quotation with-datastack ; parsing
|
||||
: $ scan-word [ execute ] curry with-datastack >vector ; parsing
|
||||
: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
! (c)2009 Joe Groff, see BSD license
|
||||
USING: arrays kernel literals tools.test math math.affine-transforms
|
||||
math.constants math.functions ;
|
||||
IN: math.affine-transforms.tests
|
||||
|
||||
[ { 7.25 4.25 } ] [
|
||||
{ 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } <affine-transform>
|
||||
{ 1.0 2.0 } a.v
|
||||
] unit-test
|
||||
|
||||
[ -1.125 ] [
|
||||
{ 0.75 0.75 } { 0.75 -0.75 } { 5.0 5.0 } <affine-transform>
|
||||
|a|
|
||||
] unit-test
|
||||
|
||||
{ 1.0 3.0 } { 2.0 4.0 } { 5.0 6.0 } <affine-transform> 1array [
|
||||
{ 1.0 2.0 } { 3.0 4.0 } { 5.0 6.0 } <affine-transform>
|
||||
transpose-axes
|
||||
] unit-test
|
||||
|
||||
{ 1.0 -1.0 } { 1.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
{ 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
|
||||
inverse-axes
|
||||
] unit-test
|
||||
|
||||
{ 1.0 -1.0 } { 1.0 1.0 } { -10.0 0.0 } <affine-transform> 1array [
|
||||
{ 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
|
||||
inverse-transform
|
||||
] unit-test
|
||||
|
||||
{ 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
{ 0.5 0.5 } { -0.5 0.5 } { 5.0 5.0 } <affine-transform>
|
||||
dup inverse-transform a.
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
{ 0.01 0.02 } { 0.03 0.04 } { 0.05 0.06 } <affine-transform>
|
||||
{ 0.011 0.021 } { 0.031 0.041 } { 0.051 0.061 } <affine-transform> 0.01 a~
|
||||
] unit-test
|
||||
|
||||
{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
|
||||
{ 5.0 10.0 } <translation>
|
||||
] unit-test
|
||||
|
||||
{ $[ pi 0.25 * cos ] $[ pi 0.25 * sin ] }
|
||||
{ $[ pi -0.25 * sin ] $[ pi 0.25 * cos ] }
|
||||
{ 0.0 0.0 } <affine-transform> 1array [
|
||||
pi 0.25 * <rotation>
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
! (c)2009 Joe Groff, see BSD license
|
||||
USING: accessors arrays combinators combinators.short-circuit kernel math math.vectors
|
||||
math.functions sequences ;
|
||||
IN: math.affine-transforms
|
||||
|
||||
TUPLE: affine-transform x y origin ;
|
||||
C: <affine-transform> affine-transform
|
||||
|
||||
CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } }
|
||||
|
||||
: a.v ( a v -- v )
|
||||
[ [ x>> ] [ first ] bi* v*n ]
|
||||
[ [ y>> ] [ second ] bi* v*n ]
|
||||
[ drop origin>> ] 2tri
|
||||
v+ v+ ;
|
||||
|
||||
: <translation> ( origin -- a )
|
||||
[ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
|
||||
: <rotation> ( theta -- transform )
|
||||
[ cos ] [ sin ] bi
|
||||
[ 2array ] [ neg swap 2array ] 2bi { 0.0 0.0 } <affine-transform> ;
|
||||
: <scale> ( x y -- transform )
|
||||
[ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } <affine-transform> ;
|
||||
|
||||
: center-rotation ( transform center -- transform )
|
||||
[ clone dup ] dip [ vneg a.v ] [ v+ ] bi >>origin ;
|
||||
|
||||
: flatten-transform ( transform -- array )
|
||||
[ x>> ] [ y>> ] [ origin>> ] tri 3append ;
|
||||
|
||||
: |a| ( a -- det )
|
||||
[ [ x>> first ] [ y>> second ] bi * ]
|
||||
[ [ x>> second ] [ y>> first ] bi * ] bi - ;
|
||||
|
||||
: (inverted-axes) ( a -- x y )
|
||||
[ [ y>> second ] [ x>> second neg ] bi 2array ]
|
||||
[ [ y>> first neg ] [ x>> first ] bi 2array ]
|
||||
[ |a| ] tri
|
||||
tuck [ v/n ] 2bi@ ;
|
||||
|
||||
: inverse-axes ( a -- a^-1 )
|
||||
(inverted-axes) { 0.0 0.0 } <affine-transform> ;
|
||||
|
||||
: inverse-transform ( a -- a^-1 )
|
||||
[ inverse-axes dup ] [ origin>> ] bi
|
||||
a.v vneg >>origin ;
|
||||
|
||||
: transpose-axes ( a -- a^T )
|
||||
[ [ x>> first ] [ y>> first ] bi 2array ]
|
||||
[ [ x>> second ] [ y>> second ] bi 2array ]
|
||||
[ origin>> ] tri <affine-transform> ;
|
||||
|
||||
: a. ( a a -- a )
|
||||
transpose-axes {
|
||||
[ [ x>> ] [ x>> ] bi* v. ]
|
||||
[ [ x>> ] [ y>> ] bi* v. ]
|
||||
[ [ y>> ] [ x>> ] bi* v. ]
|
||||
[ [ y>> ] [ y>> ] bi* v. ]
|
||||
[ origin>> a.v ]
|
||||
} 2cleave
|
||||
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
|
||||
|
||||
: v~ ( a b epsilon -- ? )
|
||||
[ ~ ] curry 2all? ;
|
||||
|
||||
: a~ ( a b epsilon -- ? )
|
||||
{
|
||||
[ [ [ x>> ] bi@ ] dip v~ ]
|
||||
[ [ [ y>> ] bi@ ] dip v~ ]
|
||||
[ [ [ origin>> ] bi@ ] dip v~ ]
|
||||
} 3&& ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Affine transforms for two-dimensional vectors
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
USING: arrays kernel sequences sequences.cartesian-product tools.test ;
|
||||
IN: sequences.product.tests
|
||||
|
||||
[
|
||||
{ { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
|
||||
] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
|
||||
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
|
||||
}
|
||||
] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
|
||||
|
||||
[
|
||||
{ "012012" "aaabbb" }
|
||||
] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Joe Groff
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! (c)2009 Slava Pestov & Joe Groff, see BSD license
|
||||
USING: kernel sequences sequences.squish tools.test vectors ;
|
||||
IN: sequences.squish.tests
|
||||
|
||||
[ { { 1 2 3 } { 4 } { 5 6 } } ] [
|
||||
V{ { 1 2 3 } V{ { 4 } { 5 6 } } }
|
||||
[ vector? ] { } squish
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
! (c)2009 Slava Pestov & Joe Groff, see BSD license
|
||||
USING: combinators.short-circuit fry make math kernel sequences ;
|
||||
IN: sequences.squish
|
||||
|
||||
: (squish) ( seq quot: ( obj -- ? ) -- )
|
||||
2dup call [ '[ _ (squish) ] each ] [ drop , ] if ; inline recursive
|
||||
|
||||
: squish ( seq quot exemplar -- seq' )
|
||||
[ [ (squish) ] ] dip make ; inline
|
||||
|
||||
: squish-strings ( seq -- seq' )
|
||||
[ { [ sequence? ] [ integer? not ] } 1&& ] "" squish ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sequence flattening with parameterized descent predicate
|
||||
|
|
@ -0,0 +1 @@
|
|||
sequences
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1 @@
|
|||
Parsers for SVG data
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
! (c)2009 Joe Groff, see BSD license
|
||||
USING: arrays literals math math.affine-transforms math.functions multiline
|
||||
svg tools.test ;
|
||||
IN: svg.tests
|
||||
|
||||
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
|
||||
"matrix ( 1 +2.25 -3 , 0.4e+1 ,5.5, 1e-6 )" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
|
||||
"translate(5.0, 1e1 )" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 1.0 0.0 } { 0.0 1.0 } { 5.0 10.0 } <affine-transform> 1array [
|
||||
"translate( 5.0 1e+1)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 2.0 0.0 } { 0.0 2.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"scale(2.0)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"scale(2.0 4.0)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 2.0 0.0 } { 0.0 4.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"scale(2.0 4.0)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 1.0 0.0 } { $[ 45 degrees tan ] 1.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"skewX(45)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ 1.0 $[ -45 degrees tan ] } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"skewY(-4.5e1)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
{ $[ 30 degrees cos ] $[ 30 degrees sin ] }
|
||||
{ $[ -30 degrees sin ] $[ 30 degrees cos ] } { 0.0 0.0 } <affine-transform> 1array [
|
||||
"rotate(30)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"rotate(30 1.0,2.0)" svg-transform>affine-transform
|
||||
{ $[ 30 degrees cos ] $[ 30 degrees sin ] }
|
||||
{ $[ -30 degrees sin ] $[ 30 degrees cos ] } {
|
||||
$[ 1.0 30 degrees cos 1.0 * - 30 degrees sin 2.0 * + ]
|
||||
$[ 2.0 30 degrees cos 2.0 * - 30 degrees sin 1.0 * - ]
|
||||
} <affine-transform> 0.001 a~
|
||||
] unit-test
|
||||
|
||||
{ $[ 30 degrees cos ] $[ 30 degrees sin ] }
|
||||
{ $[ -30 degrees sin ] $[ 30 degrees cos ] }
|
||||
{ 1.0 2.0 } <affine-transform> 1array [
|
||||
"translate(1 2) rotate(30)" svg-transform>affine-transform
|
||||
] unit-test
|
||||
|
||||
[ {
|
||||
T{ moveto f { 1.0 1.0 } f }
|
||||
T{ lineto f { 3.0 -1.0 } f }
|
||||
|
||||
T{ lineto f { 2.0 2.0 } t }
|
||||
T{ lineto f { 2.0 -2.0 } t }
|
||||
T{ lineto f { 2.0 2.0 } t }
|
||||
|
||||
T{ vertical-lineto f -9.0 t }
|
||||
T{ vertical-lineto f 1.0 t }
|
||||
T{ horizontal-lineto f 9.0 f }
|
||||
T{ horizontal-lineto f 8.0 f }
|
||||
|
||||
T{ closepath }
|
||||
|
||||
T{ moveto f { 0.0 0.0 } f }
|
||||
|
||||
T{ curveto f { -4.0 0.0 } { -8.0 4.0 } { -8.0 8.0 } f }
|
||||
T{ curveto f { -8.0 4.0 } { -12.0 8.0 } { -16.0 8.0 } f }
|
||||
|
||||
T{ smooth-curveto f { 0.0 2.0 } { 2.0 0.0 } t }
|
||||
|
||||
T{ quadratic-bezier-curveto f { -2.0 0.0 } { 0.0 -2.0 } f }
|
||||
T{ quadratic-bezier-curveto f { -3.0 0.0 } { 0.0 3.0 } f }
|
||||
|
||||
T{ smooth-quadratic-bezier-curveto f { 1.0 2.0 } t }
|
||||
T{ smooth-quadratic-bezier-curveto f { 3.0 4.0 } t }
|
||||
|
||||
T{ elliptical-arc f { 5.0 6.0 } 7.0 t f { 8.0 9.0 } f }
|
||||
} ] [
|
||||
<"
|
||||
M 1.0,+1 3,-10e-1 l 2 2, 2 -2, 2 2 v -9 1 H 9 8 z
|
||||
M 0 0 C -4.0 0.0 -8.0 4.0 -8.0 8.0 -8.0 4.0 -12.0 8.0 -16.0 8.0
|
||||
s 0.0,2.0 2.0,0.0
|
||||
Q -2 0 0 -2 -3. 0 0 3
|
||||
t 1 2 3 4
|
||||
A 5 6 7 1 0 8 9
|
||||
"> svg-path>array
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
! (c)2009 Joe Groff, see BSD license
|
||||
USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants
|
||||
math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish
|
||||
splitting strings xml.data xml.utilities ;
|
||||
IN: svg
|
||||
|
||||
XML-NS: svg-name http://www.w3.org/2000/svg
|
||||
XML-NS: xlink-name http://www.w3.org/1999/xlink
|
||||
XML-NS: sodipodi-name http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd
|
||||
XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape
|
||||
|
||||
: svg-string>number ( string -- number )
|
||||
{ { CHAR: E CHAR: e } } substitute "e" split1
|
||||
[ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* *
|
||||
>float ;
|
||||
|
||||
: degrees ( deg -- rad ) pi * 180.0 / ;
|
||||
|
||||
EBNF: svg-transform>affine-transform
|
||||
|
||||
transforms =
|
||||
transform:m comma-wsp+ transforms:n => [[ m n a. ]]
|
||||
| transform
|
||||
transform =
|
||||
matrix
|
||||
| translate
|
||||
| scale
|
||||
| rotate
|
||||
| skewX
|
||||
| skewY
|
||||
matrix =
|
||||
"matrix" wsp* "(" wsp*
|
||||
number:xx comma-wsp
|
||||
number:xy comma-wsp
|
||||
number:yx comma-wsp
|
||||
number:yy comma-wsp
|
||||
number:ox comma-wsp
|
||||
number:oy wsp* ")"
|
||||
=> [[ { xx xy } { yx yy } { ox oy } <affine-transform> ]]
|
||||
translate =
|
||||
"translate" wsp* "(" wsp* number:tx ( comma-wsp number:ty => [[ ty ]] )?:ty wsp* ")"
|
||||
=> [[ tx ty 0.0 or 2array <translation> ]]
|
||||
scale =
|
||||
"scale" wsp* "(" wsp* number:sx ( comma-wsp number:sy => [[ sy ]] )?:sy wsp* ")"
|
||||
=> [[ sx sy sx or <scale> ]]
|
||||
rotate =
|
||||
"rotate" wsp* "(" wsp* number:a ( comma-wsp number:cx comma-wsp number:cy => [[ cx cy 2array ]])?:c wsp* ")"
|
||||
=> [[ a degrees <rotation> c [ center-rotation ] when* ]]
|
||||
skewX =
|
||||
"skewX" wsp* "(" wsp* number:a wsp* ")"
|
||||
=> [[ { 1.0 0.0 } a degrees tan 1.0 2array { 0.0 0.0 } <affine-transform> ]]
|
||||
skewY =
|
||||
"skewY" wsp* "(" wsp* number:a wsp* ")"
|
||||
=> [[ 1.0 a degrees tan 2array { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ]]
|
||||
number =
|
||||
sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]]
|
||||
comma-wsp =
|
||||
(wsp+ comma? wsp*) | (comma wsp*)
|
||||
comma =
|
||||
","
|
||||
integer-constant =
|
||||
digit-sequence
|
||||
floating-point-constant =
|
||||
fractional-constant exponent?
|
||||
| digit-sequence exponent
|
||||
fractional-constant =
|
||||
digit-sequence? "." digit-sequence
|
||||
| digit-sequence "."
|
||||
exponent =
|
||||
( "e" | "E" ) sign? digit-sequence
|
||||
sign =
|
||||
"+" => [[ f ]] | "-"
|
||||
digit-sequence = [0-9]+ => [[ >string ]]
|
||||
wsp = (" " | "\t" | "\r" | "\n")
|
||||
|
||||
transform-list = wsp* transforms?:t wsp*
|
||||
=> [[ t [ identity-transform ] unless* ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
: tag-transform ( tag -- transform )
|
||||
"transform" svg-name swap at svg-transform>affine-transform ;
|
||||
|
||||
TUPLE: moveto p relative? ;
|
||||
TUPLE: closepath ;
|
||||
TUPLE: lineto p relative? ;
|
||||
TUPLE: horizontal-lineto x relative? ;
|
||||
TUPLE: vertical-lineto y relative? ;
|
||||
TUPLE: curveto p1 p2 p relative? ;
|
||||
TUPLE: smooth-curveto p2 p relative? ;
|
||||
TUPLE: quadratic-bezier-curveto p1 p relative? ;
|
||||
TUPLE: smooth-quadratic-bezier-curveto p relative? ;
|
||||
TUPLE: elliptical-arc radii x-axis-rotation large-arc? sweep? p relative? ;
|
||||
|
||||
: (set-relative) ( args rel -- args )
|
||||
'[ [ _ >>relative? drop ] each ] keep ;
|
||||
|
||||
EBNF: svg-path>array
|
||||
|
||||
moveto-drawto-command-groups =
|
||||
moveto-drawto-command-group:first wsp* moveto-drawto-command-groups:rest
|
||||
=> [[ first rest append ]]
|
||||
| moveto-drawto-command-group
|
||||
moveto-drawto-command-group =
|
||||
moveto:m wsp* drawto-commands?:d => [[ m d append ]]
|
||||
drawto-commands =
|
||||
drawto-command:first wsp* drawto-commands:rest => [[ first rest append ]]
|
||||
| drawto-command
|
||||
drawto-command =
|
||||
closepath
|
||||
| lineto
|
||||
| horizontal-lineto
|
||||
| vertical-lineto
|
||||
| curveto
|
||||
| smooth-curveto
|
||||
| quadratic-bezier-curveto
|
||||
| smooth-quadratic-bezier-curveto
|
||||
| elliptical-arc
|
||||
moveto =
|
||||
("M" => [[ f ]] | "m" => [[ t ]]):rel wsp* moveto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
moveto-argument = coordinate-pair => [[ f moveto boa ]]
|
||||
moveto-argument-sequence =
|
||||
moveto-argument:first comma-wsp? lineto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| moveto-argument => [[ 1array ]]
|
||||
closepath =
|
||||
("Z" | "z") => [[ drop closepath boa 1array ]]
|
||||
lineto =
|
||||
("L" => [[ f ]] | "l" => [[ t ]]):rel wsp* lineto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
lineto-argument = coordinate-pair => [[ f lineto boa ]]
|
||||
lineto-argument-sequence =
|
||||
lineto-argument:first comma-wsp? lineto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| lineto-argument => [[ 1array ]]
|
||||
horizontal-lineto =
|
||||
( "H" => [[ f ]] | "h" => [[ t ]]):rel wsp* horizontal-lineto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
horizontal-lineto-argument = coordinate => [[ f horizontal-lineto boa ]]
|
||||
horizontal-lineto-argument-sequence =
|
||||
horizontal-lineto-argument:first comma-wsp? horizontal-lineto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| horizontal-lineto-argument => [[ 1array ]]
|
||||
vertical-lineto =
|
||||
( "V" => [[ f ]] | "v" => [[ t ]]):rel wsp* vertical-lineto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
vertical-lineto-argument = coordinate => [[ f vertical-lineto boa ]]
|
||||
vertical-lineto-argument-sequence =
|
||||
vertical-lineto-argument:first comma-wsp? vertical-lineto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| vertical-lineto-argument => [[ 1array ]]
|
||||
curveto =
|
||||
( "C" => [[ f ]] | "c" => [[ t ]]):rel wsp* curveto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
curveto-argument-sequence =
|
||||
curveto-argument:first comma-wsp? curveto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| curveto-argument => [[ 1array ]]
|
||||
curveto-argument =
|
||||
coordinate-pair:pone comma-wsp? coordinate-pair:ptwo comma-wsp? coordinate-pair:p
|
||||
=> [[ pone ptwo p f curveto boa ]]
|
||||
smooth-curveto =
|
||||
( "S" => [[ f ]] | "s" => [[ t ]] ):rel wsp* smooth-curveto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
smooth-curveto-argument-sequence =
|
||||
smooth-curveto-argument:first comma-wsp? smooth-curveto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| smooth-curveto-argument => [[ 1array ]]
|
||||
smooth-curveto-argument =
|
||||
coordinate-pair:ptwo comma-wsp? coordinate-pair:p
|
||||
=> [[ ptwo p f smooth-curveto boa ]]
|
||||
quadratic-bezier-curveto =
|
||||
( "Q" => [[ f ]] | "q" => [[ t ]] ):rel wsp* quadratic-bezier-curveto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
quadratic-bezier-curveto-argument-sequence =
|
||||
quadratic-bezier-curveto-argument:first comma-wsp?
|
||||
quadratic-bezier-curveto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| quadratic-bezier-curveto-argument => [[ 1array ]]
|
||||
quadratic-bezier-curveto-argument =
|
||||
coordinate-pair:pone comma-wsp? coordinate-pair:p
|
||||
=> [[ pone p f quadratic-bezier-curveto boa ]]
|
||||
smooth-quadratic-bezier-curveto =
|
||||
( "T" => [[ f ]] | "t" => [[ t ]] ):rel wsp* smooth-quadratic-bezier-curveto-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
smooth-quadratic-bezier-curveto-argument-sequence =
|
||||
smooth-quadratic-bezier-curveto-argument:first comma-wsp? smooth-quadratic-bezier-curveto-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| smooth-quadratic-bezier-curveto-argument => [[ 1array ]]
|
||||
smooth-quadratic-bezier-curveto-argument = coordinate-pair => [[ f smooth-quadratic-bezier-curveto boa ]]
|
||||
elliptical-arc =
|
||||
( "A" => [[ f ]] | "a" => [[ t ]] ):rel wsp* elliptical-arc-argument-sequence:args
|
||||
=> [[ args rel (set-relative) ]]
|
||||
elliptical-arc-argument-sequence =
|
||||
elliptical-arc-argument:first comma-wsp? elliptical-arc-argument-sequence:rest
|
||||
=> [[ rest first prefix ]]
|
||||
| elliptical-arc-argument => [[ 1array ]]
|
||||
elliptical-arc-argument =
|
||||
nonnegative-number:radiix comma-wsp? nonnegative-number:radiiy comma-wsp?
|
||||
number:xrot comma-wsp flag:large comma-wsp flag:sweep
|
||||
comma-wsp coordinate-pair:p
|
||||
=> [[ radiix radiiy 2array xrot large sweep p f elliptical-arc boa ]]
|
||||
coordinate-pair = coordinate:x comma-wsp? coordinate:y => [[ x y 2array ]]
|
||||
coordinate = number
|
||||
nonnegative-number = (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]]
|
||||
number = sign? (floating-point-constant | integer-constant) => [[ squish-strings svg-string>number ]]
|
||||
flag = "0" => [[ f ]] | "1" => [[ t ]]
|
||||
comma-wsp = (wsp+ comma? wsp*) | (comma wsp*)
|
||||
comma = ","
|
||||
integer-constant = digit-sequence
|
||||
floating-point-constant = fractional-constant exponent? | digit-sequence exponent
|
||||
fractional-constant = digit-sequence? "." digit-sequence | digit-sequence "."
|
||||
exponent = ( "e" | "E" ) sign? digit-sequence
|
||||
sign = "+" => [[ drop f ]] | "-"
|
||||
digit-sequence = [0-9]+ => [[ >string ]]
|
||||
wsp = (" " | "\t" | "\r" | "\n")
|
||||
|
||||
svg-path = wsp* moveto-drawto-command-groups?:x wsp* => [[ x ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
: tag-d ( tag -- d )
|
||||
"d" svg-name swap at svg-path>array ;
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
xml
|
||||
graphics
|
||||
svg
|
||||
|
|
@ -53,6 +53,14 @@ beast.
|
|||
factor image (overwriting the current one) with all the needed
|
||||
vocabs.
|
||||
|
||||
Alternatively, you can add the following line to your
|
||||
.factor-boot-rc file:
|
||||
|
||||
"fuel" require
|
||||
|
||||
This will ensure that the image generated while bootstrapping
|
||||
Factor contains fuel and the vocabularies it depends on.
|
||||
|
||||
*** Connecting to a running Factor
|
||||
|
||||
'run-factor' starts a new factor listener process managed by Emacs.
|
||||
|
|
@ -129,6 +137,7 @@ beast.
|
|||
| | (fuel-refactor-extract-vocab) |
|
||||
| C-cC-xi | replace word by its definition (fuel-refactor-inline-word) |
|
||||
| C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) |
|
||||
| C-cC-xa | extract region as a separate ARTICLE: form |
|
||||
|-----------------+------------------------------------------------------------|
|
||||
|
||||
*** In the listener:
|
||||
|
|
|
|||
|
|
@ -323,7 +323,7 @@
|
|||
(sort-lines nil start (point))))))
|
||||
|
||||
(defun fuel-markup--vocab-link (e)
|
||||
(fuel-markup--insert-button (cadr e) (cadr e) 'vocab))
|
||||
(fuel-markup--insert-button (cadr e) (or (car (cddr e)) (cadr e)) 'vocab))
|
||||
|
||||
(defun fuel-markup--vocab-links (e)
|
||||
(dolist (link (cdr e))
|
||||
|
|
@ -583,19 +583,23 @@
|
|||
(defun fuel-markup--notes (e)
|
||||
(fuel-markup--elem-with-heading e "Notes"))
|
||||
|
||||
(defun fuel-markup--see (e)
|
||||
(defun fuel-markup--word-info (e s)
|
||||
(let* ((word (nth 1 e))
|
||||
(cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t)))
|
||||
(res (and cmd
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd 100)))))
|
||||
(cmd (and word `(:fuel* ((:quote ,(format "%s" word)) ,s) "fuel")))
|
||||
(ret (and cmd (fuel-eval--send/wait cmd)))
|
||||
(res (and (not (fuel-eval--retort-error ret))
|
||||
(fuel-eval--retort-output ret))))
|
||||
(if res
|
||||
(fuel-markup--code (list '$code res))
|
||||
(fuel-markup--snippet (list '$snippet word)))))
|
||||
(fuel-markup--snippet (list '$snippet " " word)))))
|
||||
|
||||
(defun fuel-markup--null (e))
|
||||
(defun fuel-markup--see (e)
|
||||
(fuel-markup--word-info e 'see))
|
||||
|
||||
(defun fuel-markup--synopsis (e)
|
||||
(insert (format " %S " e)))
|
||||
(fuel-markup--word-info e 'synopsis))
|
||||
|
||||
(defun fuel-markup--null (e))
|
||||
|
||||
|
||||
(provide 'fuel-markup)
|
||||
|
|
|
|||
|
|
@ -198,6 +198,7 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?e ?w 'fuel-edit-word)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
||||
(fuel-mode--key ?x ?a 'fuel-refactor-extract-article)
|
||||
(fuel-mode--key ?x ?i 'fuel-refactor-inline-word)
|
||||
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
|
||||
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
|
||||
|
|
|
|||
|
|
@ -78,17 +78,19 @@
|
|||
(when found (setq result (fuel-refactor--reuse-p (car found)))))
|
||||
(and result found))))
|
||||
|
||||
(defsubst fuel-refactor--insertion-point ()
|
||||
(max (save-excursion (fuel-syntax--beginning-of-defun) (point))
|
||||
(save-excursion
|
||||
(re-search-backward fuel-syntax--end-of-def-regex nil t)
|
||||
(forward-line 1)
|
||||
(skip-syntax-forward "-"))))
|
||||
|
||||
(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)))))
|
||||
(let ((start (goto-char (fuel-refactor--insertion-point))))
|
||||
(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
|
||||
|
|
@ -233,5 +235,30 @@ The region is extended to the closest definition boundaries."
|
|||
(mark-defun)
|
||||
(mark))))
|
||||
|
||||
;;; Extract article:
|
||||
|
||||
(defun fuel-refactor-extract-article (begin end)
|
||||
"Extracts region as a new ARTICLE form."
|
||||
(interactive "r")
|
||||
(let ((topic (read-string "Article topic: "))
|
||||
(title (read-string "Article title: ")))
|
||||
(kill-region begin end)
|
||||
(insert (format "{ $subsection %s }\n" topic))
|
||||
(end-of-line 0)
|
||||
(save-excursion
|
||||
(goto-char (fuel-refactor--insertion-point))
|
||||
(open-line 1)
|
||||
(let ((start (point)))
|
||||
(insert (format "ARTICLE: %S %S\n" topic title))
|
||||
(yank)
|
||||
(when (looking-at "^ *$") (end-of-line 0))
|
||||
(insert " ;")
|
||||
(unwind-protect
|
||||
(progn
|
||||
(move-overlay fuel-stack--overlay start (point))
|
||||
(sit-for fuel-stack-highlight-period))
|
||||
(delete-overlay fuel-stack--overlay))))))
|
||||
|
||||
|
||||
(provide 'fuel-refactor)
|
||||
;;; fuel-refactor.el ends here
|
||||
|
|
|
|||
|
|
@ -158,7 +158,9 @@
|
|||
"PREDICATE" "PRIMITIVE"
|
||||
"UNION"))
|
||||
|
||||
(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS"
|
||||
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
|
||||
"HELP"
|
||||
"SINGLETONS"
|
||||
"SYMBOLS"
|
||||
"TUPLE"
|
||||
"VARS"))
|
||||
|
|
@ -179,13 +181,12 @@
|
|||
|
||||
(defconst fuel-syntax--single-liner-regex
|
||||
(regexp-opt '("ABOUT:"
|
||||
"ARTICLE:"
|
||||
"ALIAS:"
|
||||
"CONSTANT:" "C:"
|
||||
"DEFER:"
|
||||
"FORGET:"
|
||||
"GENERIC:" "GENERIC#"
|
||||
"HELP:" "HEX:" "HOOK:"
|
||||
"HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:"
|
||||
"LIBRARY:"
|
||||
"MAIN:" "MATH:" "MIXIN:"
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ void init_ffi(void)
|
|||
|
||||
void ffi_dlopen(F_DLL *dll)
|
||||
{
|
||||
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
|
||||
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL);
|
||||
}
|
||||
|
||||
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
|
||||
|
|
|
|||
Loading…
Reference in New Issue