Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-02-06 04:40:35 -06:00
commit 4e422afb92
67 changed files with 343 additions and 362 deletions

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml USING: farkup kernel peg peg.ebnf tools.test namespaces xml
urls.encoding assocs xml.utilities xml.data ; urls.encoding assocs xml.traversal xml.data ;
IN: farkup.tests IN: farkup.tests
relative-link-prefix off relative-link-prefix off

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io USING: accessors arrays combinators io
io.streams.string kernel math namespaces peg peg.ebnf io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities xml.literals sequences sequences.deep strings xml.entities xml.syntax
vectors splitting xmode.code2html urls.encoding xml.data vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ; xml.writer ;
IN: farkup IN: farkup

View File

@ -7,8 +7,8 @@ xml
xml.data xml.data
xml.entities xml.entities
xml.writer xml.writer
xml.utilities xml.traversal
xml.literals xml.syntax
html.components html.components
html.elements html.elements
html.forms html.forms

View File

@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger html xml.literals xml.writer ; sorting debugger html xml.syntax xml.writer ;
IN: help.html IN: help.html
: escape-char ( ch -- ) : escape-char ( ch -- )

View File

@ -100,6 +100,6 @@ $nl
{ $subsection farkup } { $subsection farkup }
"Creating custom components:" "Creating custom components:"
{ $subsection render* } { $subsection render* }
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; "Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ;
ABOUT: "html.components" ABOUT: "html.components"

View File

@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities xml.data fry locals calendar calendar.format xml.entities xml.data
validators urls present xml.writer xml.literals xml validators urls present xml.writer xml.syntax xml
xmode.code2html lcs.diff2html farkup io.streams.string xmode.code2html lcs.diff2html farkup io.streams.string
html html.streams html.forms ; html html.streams html.forms ;
IN: html.components IN: html.components

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.styles kernel namespaces prettyprint quotations USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects sequences strings words xml.entities compiler.units effects
xml.data xml.literals urls math math.parser combinators xml.data urls math math.parser combinators
present fry io.streams.string xml.writer html ; present fry io.streams.string xml.writer html ;
IN: html.elements IN: html.elements

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations mirrors math fry sequences words continuations
xml.entities xml.writer xml.literals ; xml.entities xml.writer xml.syntax ;
IN: html.forms IN: html.forms
TUPLE: form errors values validation-failed ; TUPLE: form errors values validation-failed ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, ! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
! Slava Pestov. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel xml.data xml.writer xml.literals urls.encoding ; USING: kernel xml.data xml.writer xml.syntax urls.encoding ;
IN: html IN: html
: simple-page ( title head body -- xml ) : simple-page ( title head body -- xml )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel assocs io io.styles math math.order math.parser USING: accessors kernel assocs io io.styles math math.order math.parser
sequences strings make words combinators macros xml.literals html fry sequences strings make words combinators macros xml.syntax html fry
destructors ; destructors ;
IN: html.streams IN: html.streams

View File

@ -5,7 +5,7 @@ namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml unicode.case mirrors math urls present multiline quotations xml
logging continuations logging continuations
xml.data xml.writer xml.literals strings xml.data xml.writer xml.syntax strings
html.forms html.forms
html html
html.elements html.elements

View File

@ -5,7 +5,7 @@ USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls unicode.case mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities multiline xml xml.data xml.writer xml.syntax
html.components html.components
html.templates ; html.templates ;

View File

@ -3,7 +3,7 @@
USING: accessors kernel fry io io.encodings.utf8 io.files USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string arrays strings html io.streams.string
quotations xml.data xml.writer xml.literals ; quotations xml.data xml.writer xml.syntax ;
IN: html.templates IN: html.templates
MIXIN: template MIXIN: template

View File

@ -299,7 +299,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.forms USING: html.components html.forms
xml xml.utilities validators xml xml.traversal validators
furnace furnace.conversations ; furnace furnace.conversations ;
SYMBOL: a SYMBOL: a

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math.parser http accessors kernel xml.literals xml.writer USING: math.parser http accessors kernel xml.syntax xml.writer
io io.streams.string io.encodings.utf8 ; io io.streams.string io.encodings.utf8 ;
IN: http.server.responses IN: http.server.responses

View File

@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces
parser sequences strings assocs hashtables debugger mime.types parser sequences strings assocs hashtables debugger mime.types
sorting logging calendar.format accessors splitting io io.files sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary io.files.info io.directories io.pathnames io.encodings.binary
fry xml.entities destructors urls html xml.literals fry xml.entities destructors urls html xml.syntax
html.templates.fhtml http http.server http.server.responses html.templates.fhtml http http.server http.server.responses
http.server.redirection xml.writer ; http.server.redirection xml.writer ;
IN: http.server.static IN: http.server.static

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lcs xml.literals xml.writer kernel strings ; USING: lcs xml.syntax xml.writer kernel strings ;
FROM: accessors => item>> ; FROM: accessors => item>> ;
FROM: io => write ; FROM: io => write ;
FROM: sequences => each if-empty when-empty map ; FROM: sequences => each if-empty when-empty map ;

View File

@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ;
dup name>> empty-name? [ dup name>> empty-name? [
drop drop
] [ ] [
[ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] [ name-content>> ]
[ name>> unquote ] [ name>> unquote ]
[ mime-parts>> set-at ] tri [ mime-parts>> set-at ] tri
] if ; ] if ;

View File

@ -1,5 +0,0 @@
USING: sequences.next tools.test arrays kernel math sequences ;
[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test
[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test

View File

@ -1,21 +0,0 @@
USING: kernel sequences sequences.private math ;
IN: sequences.next
<PRIVATE
: iterate-seq ( seq quot -- i seq quot )
[ [ length ] keep ] dip ; inline
: (map-next) ( i seq quot -- )
! this uses O(n) more bounds checks than is really necessary
[ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
PRIVATE>
: each-next ( seq quot: ( next-elt elt -- ) -- )
iterate-seq [ (map-next) ] 2curry each-integer ; inline
: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
over dup length swap new-sequence [
iterate-seq [ (map-next) ] 2curry
] dip [ collect ] keep ; inline

View File

@ -1 +0,0 @@
Iteration with access to next element

View File

@ -1 +0,0 @@
collections

View File

@ -1,10 +1,10 @@
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
! Portions copyright (C) 2008 Slava Pestov. ! Portions copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml.utilities kernel assocs math.order USING: xml.traversal kernel assocs math.order
strings sequences xml.data xml.writer strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities.html io.files io io.streams.string combinators xml xml.entities.html io.files io
http.client namespaces make xml.literals hashtables http.client namespaces make xml.syntax hashtables
calendar.format accessors continuations urls present ; calendar.format accessors continuations urls present ;
IN: syndication IN: syndication

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces USING: unicode.data sequences namespaces
sbufs make unicode.syntax unicode.normalize math hints sbufs make unicode.syntax unicode.normalize math hints
unicode.categories combinators unicode.syntax assocs unicode.categories combinators unicode.syntax assocs
strings splitting kernel accessors unicode.breaks fry locals ; strings splitting kernel accessors unicode.breaks fry locals ;

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel xml arrays math generic http.client USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings combinators hashtables namespaces io base64 sequences strings
calendar xml.data xml.writer xml.utilities assocs math.parser calendar xml.data xml.writer xml.traversal assocs math.parser
debugger calendar.format math.order xml.literals xml.dispatch ; debugger calendar.format math.order xml.syntax ;
IN: xml-rpc IN: xml-rpc
! * Sending RPC requests ! * Sending RPC requests

View File

@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types"
"Simple words for manipulating names:" "Simple words for manipulating names:"
{ $subsection names-match? } { $subsection names-match? }
{ $subsection assure-name } { $subsection assure-name }
"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; "For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ;
ARTICLE: { "xml.data" "classes" } "XML data classes" ARTICLE: { "xml.data" "classes" } "XML data classes"
"XML documents and chunks are made of the following classes:" "XML documents and chunks are made of the following classes:"

View File

@ -1,25 +0,0 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: xml.dispatch
ABOUT: "xml.dispatch"
ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
{ $subsection POSTPONE: TAGS: }
"and to define a new 'method' for this word, use"
{ $subsection POSTPONE: TAG: } ;
HELP: TAGS:
{ $syntax "TAGS: word" }
{ $values { "word" "a new word to define" } }
{ $description "Creates a new word to which dispatches on XML tag names." }
{ $see-also POSTPONE: TAG: } ;
HELP: TAG:
{ $syntax "TAG: tag word definition... ;" }
{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
{ $see-also POSTPONE: TAGS: } ;

View File

@ -1,33 +0,0 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml io kernel math sequences strings xml.utilities
tools.test math.parser xml.dispatch ;
IN: xml.dispatch.tests
TAGS: calculate ( tag -- n )
: calc-2children ( tag -- n n )
children-tags first2 [ calculate ] dip calculate ;
TAG: number calculate
children>string string>number ;
TAG: add calculate
calc-2children + ;
TAG: minus calculate
calc-2children - ;
TAG: times calculate
calc-2children * ;
TAG: divide calculate
calc-2children / ;
TAG: neg calculate
children-tags first calculate neg ;
: calc-arith ( string -- n )
string>xml first-child-tag calculate ;
[ 32 ] [
"<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
calc-arith
] unit-test
\ calc-arith must-infer

View File

@ -1,32 +0,0 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser sequences summary
lexer splitting fry combinators locals ;
IN: xml.dispatch
TUPLE: no-tag name word ;
M: no-tag summary
drop "The tag-dispatching word has no method for the given tag name" ;
<PRIVATE
: compile-tags ( word xtable -- quot )
>alist swap '[ _ no-tag boa throw ] suffix
'[ dup main>> _ case ] ;
PRIVATE>
: define-tags ( word -- )
dup dup "xtable" word-prop compile-tags define ;
:: define-tag ( string word quot -- )
quot string word "xtable" word-prop set-at
word define-tags ;
: TAGS:
CREATE
[ H{ } clone "xtable" set-word-prop ]
[ define-tags ] bi ; parsing
: TAG:
scan scan-word parse-definition define-tag ; parsing

View File

@ -1 +0,0 @@
Daniel Ehrenberg

View File

@ -1,60 +0,0 @@
USING: help.markup help.syntax present multiline xml.data ;
IN: xml.literals
ABOUT: "xml.literals"
ARTICLE: "xml.literals" "XML literals"
"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
{ $subsection POSTPONE: <XML }
{ $subsection POSTPONE: [XML }
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
{ $subsection { "xml.literals" "interpolation" } } ;
HELP: <XML
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
HELP: [XML
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax"
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
{" USING: splitting sequences xml.writer xml.literals ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
{" <?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
</item>
<item>
two
</item>
<item>
three
</item>
</doc>"} }
"Here is an example of the locals version:"
{ $example
{" USING: locals urls xml.literals xml.writer ;
[let |
number [ 3 ]
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
word [ \ drop ] |
<XML
<x
number=<-number->
false=<-false->
url=<-url->
string=<-string->
word=<-word-> />
XML> pprint-xml ] "}
{" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;

View File

@ -1 +0,0 @@
Syntax for XML interpolation

View File

@ -1,2 +0,0 @@
syntax
enterprise

View File

@ -0,0 +1,101 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax xml.data present multiline ;
IN: xml.syntax
ABOUT: "xml.syntax"
ARTICLE: "xml.syntax" "Syntax extensions for XML"
"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing."
{ $subsection { "xml.syntax" "tags" } }
{ $subsection { "xml.syntax" "literals" } }
{ $subsection POSTPONE: XML-NS: } ;
ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
{ $subsection POSTPONE: TAGS: }
"and to define a new 'method' for this word, use"
{ $subsection POSTPONE: TAG: } ;
HELP: TAGS:
{ $syntax "TAGS: word" }
{ $values { "word" "a new word to define" } }
{ $description "Creates a new word to which dispatches on XML tag names." }
{ $see-also POSTPONE: TAG: } ;
HELP: TAG:
{ $syntax "TAG: tag word definition... ;" }
{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
{ $see-also POSTPONE: TAGS: } ;
ARTICLE: { "xml.syntax" "literals" } "XML literals"
"The following words provide syntax for XML literals:"
{ $subsection POSTPONE: <XML }
{ $subsection POSTPONE: [XML }
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
{ $subsection { "xml.syntax" "interpolation" } } ;
HELP: <XML
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
HELP: [XML
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
{" USING: splitting sequences xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
{" <?xml version="1.0" encoding="UTF-8"?>
<doc>
<item>
one
</item>
<item>
two
</item>
<item>
three
</item>
</doc>"} }
"Here is an example of the locals version:"
{ $example
{" USING: locals urls xml.syntax xml.writer ;
[let |
number [ 3 ]
false [ f ]
url [ URL" http://factorcode.org/" ]
string [ "hello" ]
word [ \ drop ] |
<XML
<x
number=<-number->
false=<-false->
url=<-url->
string=<-string->
word=<-word-> />
XML> pprint-xml ] "}
{" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
{ $example {" USING: sequences xml.syntax inverse ;
: dispatch ( xml -- string )
{
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
{ [ [XML <b><-></b> XML] ] [ "b" prepend ] }
{ [ [XML <b val='yes'/> XML] ] [ "yes" ] }
{ [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
} switch ;
[XML <a>pple</a> XML] dispatch write "} "apple" } ;
HELP: XML-NS:
{ $syntax "XML-NS: name http://url" }
{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ;

View File

@ -1,9 +1,45 @@
! Copyright (C) 2009 Daniel Ehrenberg. ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.literals multiline kernel assocs USING: xml io kernel math sequences strings xml.traversal
sequences accessors xml.writer xml.literals.private tools.test math.parser xml.syntax xml.data xml.syntax.private
locals splitting urls xml.data classes ; accessors multiline locals inverse xml.writer splitting classes ;
IN: xml.literals.tests IN: xml.syntax.tests
! TAGS test
TAGS: calculate ( tag -- n )
: calc-2children ( tag -- n n )
children-tags first2 [ calculate ] dip calculate ;
TAG: number calculate
children>string string>number ;
TAG: add calculate
calc-2children + ;
TAG: minus calculate
calc-2children - ;
TAG: times calculate
calc-2children * ;
TAG: divide calculate
calc-2children / ;
TAG: neg calculate
children-tags first calculate neg ;
: calc-arith ( string -- n )
string>xml first-child-tag calculate ;
[ 32 ] [
"<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
calc-arith
] unit-test
\ calc-arith must-infer
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
! XML literals
[ "a" "c" { "a" "c" f } ] [ [ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>" "<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
@ -47,7 +83,7 @@ IN: xml.literals.tests
[ {" <?xml version="1.0" encoding="UTF-8"?> [ {" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ] <x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
[ 3 f URL" http://factorcode.org/" "hello" \ drop [ 3 f "http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML> <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test pprint-xml>string ] unit-test

View File

@ -1,11 +1,42 @@
! Copyright (C) 2009 Daniel Ehrenberg. ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.state kernel sequences fry assocs xml.data USING: words assocs kernel accessors parser sequences summary
accessors strings make multiline parser namespaces macros lexer splitting combinators locals xml.data memoize sequences.deep
sequences.deep generalizations words combinators xml.data xml.state xml namespaces present arrays generalizations strings
math present arrays unicode.categories locals.backend make math macros multiline inverse combinators.short-circuit
quotations ; sorting fry unicode.categories ;
IN: xml.literals IN: xml.syntax
<PRIVATE
TUPLE: no-tag name word ;
M: no-tag summary
drop "The tag-dispatching word has no method for the given tag name" ;
: compile-tags ( word xtable -- quot )
>alist swap '[ _ no-tag boa throw ] suffix
'[ dup main>> _ case ] ;
: define-tags ( word -- )
dup dup "xtable" word-prop compile-tags define ;
:: define-tag ( string word quot -- )
quot string word "xtable" word-prop set-at
word define-tags ;
PRIVATE>
: TAGS:
CREATE
[ H{ } clone "xtable" set-word-prop ]
[ define-tags ] bi ; parsing
: TAG:
scan scan-word parse-definition define-tag ; parsing
: XML-NS:
CREATE-WORD (( string -- name )) over set-stack-effect
scan '[ f swap _ <name> ] define-memoized ; parsing
<PRIVATE <PRIVATE
@ -143,8 +174,6 @@ PRIVATE>
: [XML : [XML
"XML]" [ string>chunk ] parse-def ; parsing "XML]" [ string>chunk ] parse-def ; parsing
USING: inverse sorting fry combinators.short-circuit ;
: remove-blanks ( seq -- newseq ) : remove-blanks ( seq -- newseq )
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;

View File

@ -1,4 +1,4 @@
USING: xml xml.data xml.utilities tools.test accessors kernel USING: xml xml.data xml.traversal tools.test accessors kernel
io.encodings.8-bit ; io.encodings.8-bit ;
[ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test [ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test

View File

@ -1,4 +1,4 @@
USING: sequences xml kernel arrays xml.utilities io.files tools.test ; USING: sequences xml kernel arrays xml.traversal io.files tools.test ;
IN: xml.tests IN: xml.tests
: assemble-data ( tag -- 3array ) : assemble-data ( tag -- 3array )

View File

@ -1,5 +1,5 @@
USING: kernel xml sequences assocs tools.test io arrays namespaces fry USING: kernel xml sequences assocs tools.test io arrays namespaces fry
accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ; accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
IN: xml.tests IN: xml.tests
: sub-tag : sub-tag

View File

@ -3,7 +3,7 @@
IN: xml.tests IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities.html parser strings xml.data io.files xml.errors xml.entities.html parser strings xml.data io.files
xml.utilities continuations assocs xml.traversal continuations assocs
sequences.deep accessors io.streams.string ; sequences.deep accessors io.streams.string ;
! This is insufficient ! This is insufficient

View File

@ -1,6 +1,6 @@
USING: accessors assocs combinators continuations fry generalizations USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml io.pathnames kernel macros sequences stack-checker tools.test xml
xml.utilities xml.writer arrays xml.data ; xml.traversal xml.writer arrays xml.data ;
IN: xml.tests.suite IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ; TUPLE: xml-test id uri sections description type ;

View File

View File

@ -0,0 +1 @@
Utilities for traversing an XML DOM tree

View File

@ -1,12 +1,12 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax xml.data sequences strings ; USING: help.markup help.syntax xml.data sequences strings ;
IN: xml.utilities IN: xml.traversal
ABOUT: "xml.utilities" ABOUT: "xml.traversal"
ARTICLE: "xml.utilities" "Utilities for processing XML" ARTICLE: "xml.traversal" "Utilities for traversing XML"
"Getting parts of an XML document or tag:" "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:"
$nl $nl
"Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
{ $subsection tag-named } { $subsection tag-named }

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.utilities tools.test xml.data sequences ; USING: xml xml.traversal tools.test xml.data sequences ;
IN: xml.utilities.tests IN: xml.traversal.tests
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test [ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@ -9,10 +9,6 @@ IN: xml.utilities.tests
[ "" ] [ "<foo/>" string>xml children>string ] unit-test [ "" ] [ "<foo/>" string>xml children>string ] unit-test
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test [ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test [ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test

View File

@ -3,7 +3,7 @@
USING: accessors kernel namespaces sequences words io assocs USING: accessors kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger quotations strings parser lexer arrays xml.data xml.writer debugger
splitting vectors sequences.deep combinators fry memoize ; splitting vectors sequences.deep combinators fry memoize ;
IN: xml.utilities IN: xml.traversal
: children>string ( tag -- string ) : children>string ( tag -- string )
children>> { children>> {
@ -66,14 +66,3 @@ PRIVATE>
: assert-tag ( name name -- ) : assert-tag ( name name -- )
names-match? [ "Unexpected XML tag found" throw ] unless ; names-match? [ "Unexpected XML tag found" throw ] unless ;
: insert-children ( children tag -- )
dup children>> [ push-all ]
[ swap V{ } like >>children drop ] if ;
: insert-child ( child tag -- )
[ 1vector ] dip insert-children ;
: XML-NS:
CREATE-WORD (( string -- name )) over set-stack-effect
scan '[ f swap _ <name> ] define-memoized ; parsing

View File

@ -1 +0,0 @@
Daniel Ehrenberg

View File

@ -1 +0,0 @@
Utilities for manipulating an XML DOM tree

View File

@ -41,7 +41,7 @@ HELP: pprint-xml
HELP: indenter HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } { $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
{ $example {" USING: xml.literals xml.writer namespaces ; { $example {" USING: xml.syntax xml.writer namespaces ;
[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" [XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
<foo> <foo>
%%%%bar %%%%bar
@ -49,7 +49,7 @@ HELP: indenter
HELP: sensitive-tags HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } { $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
{ $example {" USING: xml.literals xml.writer namespaces ; { $example {" USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing [XML <html> <head> <title> something</title></head><body><pre>bing
bang bang
bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline USING: xml.data xml.writer tools.test fry xml kernel multiline
xml.writer.private io.streams.string xml.utilities sequences xml.writer.private io.streams.string xml.traversal sequences
io.encodings.utf8 io.files accessors io.directories ; io.encodings.utf8 io.files accessors io.directories ;
IN: xml.writer.tests IN: xml.writer.tests

View File

@ -93,7 +93,7 @@ ARTICLE: "xml" "XML parser"
{ $vocab-subsection "XML parsing errors" "xml.errors" } { $vocab-subsection "XML parsing errors" "xml.errors" }
{ $vocab-subsection "XML entities" "xml.entities" } { $vocab-subsection "XML entities" "xml.entities" }
{ $vocab-subsection "XML data types" "xml.data" } { $vocab-subsection "XML data types" "xml.data" }
{ $vocab-subsection "Utilities for processing XML" "xml.utilities" } { $vocab-subsection "Utilities for traversing XML" "xml.traversal" }
{ $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ; { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ;
ABOUT: "xml" ABOUT: "xml"

View File

@ -1,6 +1,6 @@
USING: xmode.tokens xmode.marker xmode.catalog kernel locals USING: xmode.tokens xmode.marker xmode.catalog kernel locals
io io.files sequences words io.encodings.utf8 io io.files sequences words io.encodings.utf8
namespaces xml.entities accessors xml.literals locals xml.writer ; namespaces xml.entities accessors xml.syntax locals xml.writer ;
IN: xmode.code2html IN: xmode.code2html
: htmlize-tokens ( tokens -- xml ) : htmlize-tokens ( tokens -- xml )

View File

@ -1,5 +1,5 @@
USING: xmode.loader.syntax xmode.tokens xmode.rules USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.utilities xml assocs kernel xmode.keyword-map xml.data xml.traversal xml assocs kernel
combinators sequences math.parser namespaces parser combinators sequences math.parser namespaces parser
xmode.utilities parser-combinators.regexp io.files accessors ; xmode.utilities parser-combinators.regexp io.files accessors ;
IN: xmode.loader IN: xmode.loader

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.utilities xml assocs kernel combinators sequences xml.data xml.traversal xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files splitting arrays ; parser-combinators.regexp io.files splitting arrays ;
IN: xmode.loader.syntax IN: xmode.loader.syntax

View File

@ -1,5 +1,5 @@
USING: accessors sequences assocs kernel quotations namespaces USING: accessors sequences assocs kernel quotations namespaces
xml.data xml.utilities combinators macros parser lexer words fry ; xml.data xml.traversal combinators macros parser lexer words fry ;
IN: xmode.utilities IN: xmode.utilities
: implies ( x y -- z ) [ not ] dip or ; inline : implies ( x y -- z ) [ not ] dip or ; inline

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Jeff Bigot ! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: adsoda xml xml.utilities xml.dispatch accessors USING: adsoda xml xml.traversal xml.syntax accessors
combinators sequences math.parser kernel splitting values combinators sequences math.parser kernel splitting values
continuations ; continuations ;
IN: 4DNav.space-file-decoder IN: 4DNav.space-file-decoder

View File

@ -0,0 +1,15 @@
USING: graphics.bitmap ;
IN: graphics.bitmap.tests
: test-bitmap24 ( -- )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
: test-bitmap8 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
: test-bitmap4 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
: test-bitmap1 ( -- )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary USING: alien arrays byte-arrays combinators summary
graphics.viewer io io.binary io.files kernel libc math io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes fry prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ; io.encodings.binary accessors grouping macros alien.c-types ;
@ -13,9 +13,10 @@ IN: graphics.bitmap
TUPLE: bitmap magic size reserved offset header-length width TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index array ; x-pels y-pels color-used color-important rgb-quads color-index
array ;
: (array-copy) ( bitmap array -- bitmap array' ) : array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ; over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- ) MACRO: (nbits>bitmap) ( bits -- )
@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- )
2over * _ * >>size-image 2over * _ * >>size-image
swap >>height swap >>height
swap >>width swap >>width
swap (array-copy) [ >>array ] [ >>color-index ] bi swap array-copy [ >>array ] [ >>color-index ] bi
_ >>bit-count _ >>bit-count
] ; ] ;
@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- )
: raw-bitmap>array ( bitmap -- array ) : raw-bitmap>array ( bitmap -- array )
dup bit-count>> dup bit-count>>
{ {
{ 32 [ "32bit" throw ] } { 32 [ color-index>> ] }
{ 24 [ color-index>> ] } { 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] } { 16 [ "16bit" throw ] }
{ 8 [ 8bit>array ] } { 8 [ 8bit>array ] }
@ -59,107 +60,75 @@ ERROR: bitmap-magic ;
M: bitmap-magic summary M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ; drop "First two bytes of bitmap stream must be 'BM'" ;
: parse-file-header ( bitmap -- ) : read2 ( -- n ) 2 read le> ;
2 read >string dup "BM" = [ bitmap-magic ] unless >>magic : read4 ( -- n ) 4 read le> ;
4 read le> >>size
4 read le> >>reserved
4 read le> >>offset drop ;
: parse-bitmap-header ( bitmap -- ) : parse-file-header ( bitmap -- bitmap )
4 read le> >>header-length 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
4 read signed-le> >>width read4 >>size
4 read signed-le> >>height read4 >>reserved
2 read le> >>planes read4 >>offset ;
2 read le> >>bit-count
4 read le> >>compression : parse-bitmap-header ( bitmap -- bitmap )
4 read le> >>size-image read4 >>header-length
4 read le> >>x-pels read4 >>width
4 read le> >>y-pels read4 >>height
4 read le> >>color-used read2 >>planes
4 read le> >>color-important drop ; read2 >>bit-count
read4 >>compression
read4 >>size-image
read4 >>x-pels
read4 >>y-pels
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( bitmap -- n ) : rgb-quads-length ( bitmap -- n )
[ offset>> 14 - ] keep header-length>> - ; [ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n ) : color-index-length ( bitmap -- n )
[ width>> ] keep [ planes>> * ] keep {
[ bit-count>> * 31 + 32 /i 4 * ] keep [ width>> ]
height>> abs * ; [ planes>> * ]
[ bit-count>> * 31 + 32 /i 4 * ]
[ height>> abs * ]
} cleave ;
: parse-bitmap ( bitmap -- ) : parse-bitmap ( bitmap -- bitmap )
dup rgb-quads-length read >>rgb-quads dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index drop ; dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
binary [ binary [
bitmap new bitmap new
dup parse-file-header parse-file-header parse-bitmap-header parse-bitmap
dup parse-bitmap-header
dup parse-bitmap
] with-file-reader ] with-file-reader
dup raw-bitmap>array >>array ; dup raw-bitmap>array >>array ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
: save-bitmap ( bitmap path -- ) : save-bitmap ( bitmap path -- )
binary [ binary [
"BM" >byte-array write B{ CHAR: B CHAR: M } write
dup array>> length 14 + 40 + 4 >le write [
0 4 >le write array>> length 14 + 40 + write4
54 4 >le write 0 write4
54 write4
40 4 >le write 40 write4
] [
{ {
[ width>> 4 >le write ] [ width>> write4 ]
[ height>> 4 >le write ] [ height>> write4 ]
[ planes>> 1 or 2 >le write ] [ planes>> 1 or write2 ]
[ bit-count>> 24 or 2 >le write ] [ bit-count>> 24 or write2 ]
[ compression>> 0 or 4 >le write ] [ compression>> 0 or write4 ]
[ size-image>> 4 >le write ] [ size-image>> write4 ]
[ x-pels>> 0 or 4 >le write ] [ x-pels>> 0 or write4 ]
[ y-pels>> 0 or 4 >le write ] [ y-pels>> 0 or write4 ]
[ color-used>> 0 or 4 >le write ] [ color-used>> 0 or write4 ]
[ color-important>> 0 or 4 >le write ] [ color-important>> 0 or write4 ]
[ rgb-quads>> write ] [ rgb-quads>> write ]
[ color-index>> write ] [ color-index>> write ]
} cleave } cleave
] bi
] with-file-writer ; ] with-file-writer ;
M: bitmap draw-image ( bitmap -- )
dup height>> 0 < [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
] [
0 over height>> abs glRasterPos2i
1.0 1.0 glPixelZoom
] if
[ width>> ] keep
[
[ height>> abs ] keep
bit-count>> {
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
M: bitmap width ( bitmap -- ) width>> ;
M: bitmap height ( bitmap -- ) height>> ;
: bitmap. ( path -- )
load-bitmap <graphics-gadget> gadget. ;
: bitmap-window ( path -- gadget )
load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
: test-bitmap24 ( -- )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
: test-bitmap8 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
: test-bitmap4 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
: test-bitmap1 ( -- )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;

View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces opengl USING: accessors arrays combinators graphics.bitmap kernel math
ui.gadgets ui.render accessors ; math.functions namespaces opengl opengl.gl ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: graphics.viewer IN: graphics.viewer
TUPLE: graphics-gadget < gadget image ; TUPLE: graphics-gadget < gadget image ;
@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- )
: <graphics-gadget> ( bitmap -- gadget ) : <graphics-gadget> ( bitmap -- gadget )
\ graphics-gadget new-gadget \ graphics-gadget new-gadget
swap >>image ; swap >>image ;
M: bitmap draw-image ( bitmap -- )
dup height>> 0 < [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
] [
0 over height>> abs glRasterPos2i
1.0 1.0 glPixelZoom
] if
[ width>> ] keep
[
[ height>> abs ] keep
bit-count>> {
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
M: bitmap width ( bitmap -- ) width>> ;
M: bitmap height ( bitmap -- ) height>> ;
: bitmap. ( path -- )
load-bitmap <graphics-gadget> gadget. ;
: bitmap-window ( path -- gadget )
load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;

View File

@ -1,4 +1,4 @@
USING: io io.files sequences xml xml.utilities USING: io io.files sequences xml xml.traversal
io.encodings.ascii kernel ; io.encodings.ascii kernel ;
IN: msxml-to-csv IN: msxml-to-csv

View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff, see BSD license ! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms USING: accessors arrays literals math math.affine-transforms
math.functions multiline sequences svg tools.test xml xml.utilities ; math.functions multiline sequences svg tools.test xml xml.traversal ;
IN: svg.tests IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [ { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [

View File

@ -1,7 +1,7 @@
! (c)2009 Joe Groff, see BSD license ! (c)2009 Joe Groff, see BSD license
USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants
math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish
splitting strings xml.data xml.utilities ; splitting strings xml.data xml.syntax ;
IN: svg IN: svg
XML-NS: svg-name http://www.w3.org/2000/svg XML-NS: svg-name http://www.w3.org/2000/svg

View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: http.client xml xml.utilities kernel sequences USING: http.client xml xml.traversal kernel sequences
math.parser urls accessors locals ; math.parser urls accessors locals ;
IN: yahoo IN: yahoo