Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
9e882b693a
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators html.elements io
|
||||
io.streams.string kernel math namespaces peg peg.ebnf
|
||||
sequences sequences.deep strings xml.entities xml.interpolate
|
||||
sequences sequences.deep strings xml.entities xml.literals
|
||||
vectors splitting xmode.code2html urls.encoding xml.data
|
||||
xml.writer ;
|
||||
IN: farkup
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces io math.parser assocs classes
|
||||
classes.tuple words arrays sequences splitting mirrors
|
||||
hashtables combinators continuations math strings inspector
|
||||
fry locals calendar calendar.format xml.entities xml.data
|
||||
validators urls present xml.writer xml.interpolate xml
|
||||
validators urls present xml.writer xml.literals xml
|
||||
xmode.code2html lcs.diff2html farkup io.streams.string
|
||||
html.elements html.streams html.forms ;
|
||||
IN: html.components
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.styles kernel namespaces prettyprint quotations
|
||||
sequences strings words xml.entities compiler.units effects
|
||||
xml.data xml.interpolate urls math math.parser combinators
|
||||
xml.data xml.literals urls math math.parser combinators
|
||||
present fry io.streams.string xml.writer ;
|
||||
|
||||
IN: html.elements
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lcs xml.interpolate xml.writer kernel strings ;
|
||||
USING: lcs xml.literals xml.writer kernel strings ;
|
||||
FROM: accessors => item>> ;
|
||||
FROM: io => write ;
|
||||
FROM: sequences => each if-empty when-empty map ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: xml.utilities kernel assocs math.order
|
||||
strings sequences xml.data xml.writer
|
||||
io.streams.string combinators xml xml.entities.html io.files io
|
||||
http.client namespaces make xml.interpolate hashtables
|
||||
http.client namespaces make xml.literals hashtables
|
||||
calendar.format accessors continuations urls present ;
|
||||
IN: syndication
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel xml arrays math generic http.client
|
||||
combinators hashtables namespaces io base64 sequences strings
|
||||
calendar xml.data xml.writer xml.utilities assocs math.parser
|
||||
debugger calendar.format math.order xml.interpolate xml.dispatch ;
|
||||
debugger calendar.format math.order xml.literals xml.dispatch ;
|
||||
IN: xml-rpc
|
||||
|
||||
! * Sending RPC requests
|
||||
|
|
|
|||
|
|
@ -6,11 +6,14 @@ io.encodings.string io.encodings combinators accessors
|
|||
xml.data io.encodings.iana ;
|
||||
IN: xml.autoencoding
|
||||
|
||||
: decode-stream ( encoding -- )
|
||||
spot get [ swap re-decode ] change-stream drop ;
|
||||
|
||||
: continue-make-tag ( str -- tag )
|
||||
parse-name-starting middle-tag end-tag ;
|
||||
|
||||
: start-utf16le ( -- tag )
|
||||
utf16le decode-input
|
||||
utf16le decode-stream
|
||||
"?\0" expect
|
||||
check instruct ;
|
||||
|
||||
|
|
@ -22,25 +25,25 @@ IN: xml.autoencoding
|
|||
! that the first letter of the document is < and second is
|
||||
! not ASCII
|
||||
ascii?
|
||||
[ utf8 decode-input next make-tag ] [
|
||||
[ utf8 decode-stream next make-tag ] [
|
||||
next
|
||||
[ get-next 10xxxxxx? not ] take-until
|
||||
get-char suffix utf8 decode
|
||||
utf8 decode-input next
|
||||
utf8 decode-stream next
|
||||
continue-make-tag
|
||||
] if ;
|
||||
|
||||
: prolog-encoding ( prolog -- )
|
||||
encoding>> dup "UTF-16" =
|
||||
[ drop ] [ name>encoding [ decode-input ] when* ] if ;
|
||||
[ drop ] [ name>encoding [ decode-stream ] when* ] if ;
|
||||
|
||||
: instruct-encoding ( instruct/prolog -- )
|
||||
dup prolog?
|
||||
[ prolog-encoding ]
|
||||
[ drop utf8 decode-input ] if ;
|
||||
[ drop utf8 decode-stream ] if ;
|
||||
|
||||
: go-utf8 ( -- )
|
||||
check utf8 decode-input next next ;
|
||||
check utf8 decode-stream next next ;
|
||||
|
||||
: start< ( -- tag )
|
||||
! What if first letter of processing instruction is non-ASCII?
|
||||
|
|
@ -52,11 +55,11 @@ IN: xml.autoencoding
|
|||
} case ;
|
||||
|
||||
: skip-utf8-bom ( -- tag )
|
||||
"\u0000bb\u0000bf" expect utf8 decode-input
|
||||
"\u0000bb\u0000bf" expect utf8 decode-stream
|
||||
"<" expect check make-tag ;
|
||||
|
||||
: decode-expecting ( encoding string -- tag )
|
||||
[ decode-input next ] [ expect ] bi* check make-tag ;
|
||||
[ decode-stream next ] [ expect ] bi* check make-tag ;
|
||||
|
||||
: start-utf16be ( -- tag )
|
||||
utf16be "<" decode-expecting ;
|
||||
|
|
@ -74,6 +77,6 @@ IN: xml.autoencoding
|
|||
{ HEX: EF [ skip-utf8-bom ] }
|
||||
{ HEX: FF [ skip-utf16le-bom ] }
|
||||
{ HEX: FE [ skip-utf16be-bom ] }
|
||||
[ drop utf8 decode-input check f ]
|
||||
[ drop utf8 decode-stream check f ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Daniel Ehrenberg
|
||||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences unicode.syntax math math.order combinators ;
|
||||
USING: kernel sequences unicode.syntax math math.order combinators
|
||||
hints ;
|
||||
IN: xml.char-classes
|
||||
|
||||
CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ;
|
||||
|
|
@ -31,3 +32,5 @@ CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ;
|
|||
{ [ dup HEX: E000 < ] [ drop f ] }
|
||||
[ { HEX: FFFE HEX: FFFF } member? not ]
|
||||
} cond ;
|
||||
|
||||
HINTS: text? { object fixnum } ;
|
||||
|
|
|
|||
|
|
@ -6,11 +6,11 @@ IN: xml.errors.tests
|
|||
'[ _ string>xml ] swap '[ _ = ] must-fail-with ;
|
||||
|
||||
T{ no-entity f 1 10 "nbsp" } "<x> </x>" xml-error-test
|
||||
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
|
||||
T{ mismatched f 1 7 T{ name f "" "x" "" } T{ name f "" "y" "" } }
|
||||
"<x></y>" xml-error-test
|
||||
T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
|
||||
T{ unclosed f 1 3 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
|
||||
T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
|
||||
T{ unopened f 1 5 } "</x>" xml-error-test
|
||||
T{ unopened f 1 4 } "</x>" xml-error-test
|
||||
T{ not-yes/no f 1 41 "maybe" }
|
||||
"<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
|
||||
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
|
||||
|
|
@ -19,13 +19,13 @@ T{ bad-version f 1 28 "5 million" }
|
|||
"<?xml version='5 million'?><x/>" xml-error-test
|
||||
T{ notags f } "" xml-error-test
|
||||
T{ multitags } "<x/><y/>" xml-error-test
|
||||
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } }
|
||||
T{ bad-prolog f 1 25 T{ prolog f "1.0" "UTF-8" f } }
|
||||
"<x/><?xml version='1.0'?>" xml-error-test
|
||||
T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
|
||||
xml-error-test
|
||||
T{ pre/post-content f "x" t } "x<y/>" xml-error-test
|
||||
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
|
||||
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
|
||||
T{ unclosed-quote f 1 12 } "<x value='/>" xml-error-test
|
||||
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
|
||||
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
|
||||
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
|
||||
|
|
@ -37,6 +37,6 @@ T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
|||
T{ pre/post-content f "&" t } " <x/>" xml-error-test
|
||||
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
|
||||
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
|
||||
T{ disallowed-char f 1 3 1 } "<x>\u000001</x>" xml-error-test
|
||||
T{ missing-close f 1 9 } "<!-- foo" xml-error-test
|
||||
T{ disallowed-char f 1 4 1 } "<x>\u000001</x>" xml-error-test
|
||||
T{ missing-close f 1 8 } "<!-- foo" xml-error-test
|
||||
T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test
|
||||
|
|
|
|||
|
|
@ -1,29 +1,29 @@
|
|||
USING: help.markup help.syntax present multiline ;
|
||||
IN: xml.interpolate
|
||||
USING: help.markup help.syntax present multiline xml.data ;
|
||||
IN: xml.literals
|
||||
|
||||
ABOUT: "xml.interpolate"
|
||||
ABOUT: "xml.literals"
|
||||
|
||||
ARTICLE: "xml.interpolate" "XML literal interpolation"
|
||||
"The " { $vocab-link "xml.interpolate" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
|
||||
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 }
|
||||
"For a description of the common syntax of these two, see"
|
||||
{ $subsection { "xml.interpolate" "in-depth" } } ;
|
||||
"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 syntax allows the interpolation of XML documents. When evaluated, there is an XML document on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
|
||||
{ $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 syntax allows the interpolation of XML chunks. When evaluated, there is a sequence of XML elements (tags, strings, comments, etc) on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
|
||||
{ $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.interpolate" "in-depth" } "XML interpolation syntax"
|
||||
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.interpolate ;
|
||||
{" USING: splitting sequences xml.writer xml.literals ;
|
||||
"one two three" " " split
|
||||
[ [XML <item><-></item> XML] ] map
|
||||
<XML <doc><-></doc> XML> pprint-xml"}
|
||||
|
|
@ -41,7 +41,7 @@ $nl
|
|||
</doc>"} }
|
||||
"Here is an example of the locals version:"
|
||||
{ $example
|
||||
{" USING: locals urls xml.interpolate xml.writer ;
|
||||
{" USING: locals urls xml.literals xml.writer ;
|
||||
[let |
|
||||
number [ 3 ]
|
||||
false [ f ]
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test xml.interpolate multiline kernel assocs
|
||||
sequences accessors xml.writer xml.interpolate.private
|
||||
USING: tools.test xml.literals multiline kernel assocs
|
||||
sequences accessors xml.writer xml.literals.private
|
||||
locals splitting urls xml.data classes ;
|
||||
IN: xml.interpolate.tests
|
||||
IN: xml.literals.tests
|
||||
|
||||
[ "a" "c" { "a" "c" f } ] [
|
||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||
|
|
@ -4,7 +4,7 @@ USING: xml xml.state kernel sequences fry assocs xml.data
|
|||
accessors strings make multiline parser namespaces macros
|
||||
sequences.deep generalizations words combinators
|
||||
math present arrays unicode.categories ;
|
||||
IN: xml.interpolate
|
||||
IN: xml.literals
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces io ;
|
||||
USING: accessors kernel namespaces io math ;
|
||||
IN: xml.state
|
||||
|
||||
TUPLE: spot char line column next check version-1.0? ;
|
||||
TUPLE: spot
|
||||
char line column next check version-1.0? stream ;
|
||||
|
||||
C: <spot> spot
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: xml.test.state
|
|||
1string take-to ;
|
||||
|
||||
[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
|
||||
[ 2 4 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test
|
||||
[ 2 3 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test
|
||||
[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
|
||||
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
|
||||
[ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,112 +2,144 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces xml.state kernel sequences accessors
|
||||
xml.char-classes xml.errors math io sbufs fry strings ascii
|
||||
circular xml.entities assocs make splitting math.parser
|
||||
locals combinators arrays ;
|
||||
circular xml.entities assocs splitting math.parser
|
||||
locals combinators arrays hints ;
|
||||
IN: xml.tokenize
|
||||
|
||||
: assure-good-char ( ch -- ch )
|
||||
[
|
||||
version-1.0? over text? not get-check and
|
||||
[ disallowed-char ] when
|
||||
] [ f ] if* ;
|
||||
|
||||
! * Basic utility words
|
||||
|
||||
: record ( char -- )
|
||||
CHAR: \n =
|
||||
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if
|
||||
set-column ;
|
||||
: assure-good-char ( spot ch -- )
|
||||
[
|
||||
swap
|
||||
[ version-1.0?>> over text? not ]
|
||||
[ check>> ] bi and [
|
||||
spot get [ 1+ ] change-column drop
|
||||
disallowed-char
|
||||
] [ drop ] if
|
||||
] [ drop ] if* ;
|
||||
|
||||
! (next) normalizes \r\n and \r
|
||||
: (next) ( -- char )
|
||||
get-next read1
|
||||
2dup swap CHAR: \r = [
|
||||
HINTS: assure-good-char { spot fixnum } ;
|
||||
|
||||
: record ( spot char -- spot )
|
||||
over char>> [
|
||||
CHAR: \n =
|
||||
[ nip read1 ] [ nip CHAR: \n swap ] if
|
||||
] [ drop ] if
|
||||
set-next dup set-char assure-good-char ;
|
||||
[ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if
|
||||
>>column
|
||||
] [ drop ] if ;
|
||||
|
||||
HINTS: record { spot fixnum } ;
|
||||
|
||||
:: (next) ( spot -- spot char )
|
||||
spot next>> :> old-next
|
||||
spot stream>> stream-read1 :> new-next
|
||||
old-next CHAR: \r = [
|
||||
spot CHAR: \n >>char
|
||||
new-next CHAR: \n =
|
||||
[ spot stream>> stream-read1 >>next ]
|
||||
[ new-next >>next ] if
|
||||
] [ spot old-next >>char new-next >>next ] if
|
||||
spot next>> ; inline
|
||||
|
||||
: next* ( spot -- )
|
||||
dup char>> [ unexpected-end ] unless
|
||||
(next) [ record ] keep assure-good-char ;
|
||||
|
||||
HINTS: next* { spot } ;
|
||||
|
||||
: next ( -- )
|
||||
#! Increment spot.
|
||||
get-char [ unexpected-end ] unless (next) record ;
|
||||
spot get next* ;
|
||||
|
||||
: init-parser ( -- )
|
||||
0 1 0 f f t <spot> spot set
|
||||
0 1 0 0 f t f <spot>
|
||||
input-stream get >>stream
|
||||
spot set
|
||||
read1 set-next next ;
|
||||
|
||||
: with-state ( stream quot -- )
|
||||
! with-input-stream implicitly creates a new scope which we use
|
||||
swap [ init-parser call ] with-input-stream ; inline
|
||||
|
||||
:: (skip-until) ( quot: ( -- ? ) spot -- )
|
||||
spot char>> [
|
||||
quot call [
|
||||
spot next* quot spot (skip-until)
|
||||
] unless
|
||||
] when ; inline recursive
|
||||
|
||||
: skip-until ( quot: ( -- ? ) -- )
|
||||
get-char [
|
||||
[ call ] keep swap [ drop ] [
|
||||
next skip-until
|
||||
] if
|
||||
] [ drop ] if ; inline recursive
|
||||
spot get (skip-until) ; inline
|
||||
|
||||
: take-until ( quot -- string )
|
||||
#! Take the substring of a string starting at spot
|
||||
#! from code until the quotation given is true and
|
||||
#! advance spot to after the substring.
|
||||
10 <sbuf> [
|
||||
'[ @ [ t ] [ get-char _ push f ] if ] skip-until
|
||||
spot get swap
|
||||
'[ @ [ t ] [ _ char>> _ push f ] if ] skip-until
|
||||
] keep >string ; inline
|
||||
|
||||
: take-to ( seq -- string )
|
||||
'[ get-char _ member? ] take-until ;
|
||||
spot get swap '[ _ char>> _ member? ] take-until ;
|
||||
|
||||
: pass-blank ( -- )
|
||||
#! Advance code past any whitespace, including newlines
|
||||
[ get-char blank? not ] skip-until ;
|
||||
spot get '[ _ char>> blank? not ] skip-until ;
|
||||
|
||||
: string-matches? ( string circular -- ? )
|
||||
get-char over push-circular
|
||||
sequence= ;
|
||||
: string-matches? ( string circular spot -- ? )
|
||||
char>> over push-circular sequence= ;
|
||||
|
||||
: take-string ( match -- string )
|
||||
dup length <circular-string>
|
||||
[ 2dup string-matches? ] take-until nip
|
||||
spot get '[ 2dup _ string-matches? ] take-until nip
|
||||
dup length rot length 1- - head
|
||||
get-char [ missing-close ] unless next ;
|
||||
|
||||
: expect ( string -- )
|
||||
dup [ get-char next ] replicate 2dup =
|
||||
[ 2drop ] [ expected ] if ;
|
||||
dup spot get '[ _ [ char>> ] keep next* ] replicate
|
||||
2dup = [ 2drop ] [ expected ] if ;
|
||||
|
||||
! Suddenly XML-specific
|
||||
|
||||
: parse-named-entity ( string -- )
|
||||
dup entities at [ , ] [
|
||||
: parse-named-entity ( accum string -- )
|
||||
dup entities at [ swap push ] [
|
||||
dup extra-entities get at
|
||||
[ % ] [ no-entity ] ?if
|
||||
[ swap push-all ] [ no-entity ] ?if
|
||||
] ?if ;
|
||||
|
||||
: take-; ( -- string )
|
||||
next ";" take-to next ;
|
||||
|
||||
: parse-entity ( -- )
|
||||
: parse-entity ( accum -- )
|
||||
take-; "#" ?head [
|
||||
"x" ?head 16 10 ? base> ,
|
||||
"x" ?head 16 10 ? base> swap push
|
||||
] [ parse-named-entity ] if ;
|
||||
|
||||
: parse-pe ( -- )
|
||||
: parse-pe ( accum -- )
|
||||
take-; dup pe-table get at
|
||||
[ % ] [ no-entity ] ?if ;
|
||||
[ swap push-all ] [ no-entity ] ?if ;
|
||||
|
||||
:: (parse-char) ( quot: ( ch -- ? ) -- )
|
||||
get-char :> char
|
||||
:: (parse-char) ( quot: ( ch -- ? ) accum spot -- )
|
||||
spot char>> :> char
|
||||
{
|
||||
{ [ char not ] [ ] }
|
||||
{ [ char quot call ] [ next ] }
|
||||
{ [ char CHAR: & = ] [ parse-entity quot (parse-char) ] }
|
||||
{ [ in-dtd? get char CHAR: % = and ] [ parse-pe quot (parse-char) ] }
|
||||
[ char , next quot (parse-char) ]
|
||||
{ [ char quot call ] [ spot next* ] }
|
||||
{ [ char CHAR: & = ] [
|
||||
accum parse-entity
|
||||
quot accum spot (parse-char)
|
||||
] }
|
||||
{ [ in-dtd? get char CHAR: % = and ] [
|
||||
accum parse-pe
|
||||
quot accum spot (parse-char)
|
||||
] }
|
||||
[
|
||||
char accum push
|
||||
spot next*
|
||||
quot accum spot (parse-char)
|
||||
]
|
||||
} cond ; inline recursive
|
||||
|
||||
: parse-char ( quot: ( ch -- ? ) -- seq )
|
||||
[ (parse-char) ] "" make ; inline
|
||||
1024 <sbuf> [ spot get (parse-char) ] keep >string ; inline
|
||||
|
||||
: assure-no-]]> ( circular -- )
|
||||
"]]>" sequence= [ text-w/]]> ] when ;
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ HELP: pprint-xml
|
|||
|
||||
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:" }
|
||||
{ $example {" USING: xml.interpolate xml.writer namespaces ;
|
||||
{ $example {" USING: xml.literals xml.writer namespaces ;
|
||||
[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
|
||||
<foo>
|
||||
%%%%bar
|
||||
|
|
@ -49,7 +49,7 @@ HELP: indenter
|
|||
|
||||
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:" }
|
||||
{ $example {" USING: xml.interpolate xml.writer namespaces ;
|
||||
{ $example {" USING: xml.literals xml.writer namespaces ;
|
||||
[XML <html> <head> <title> something</title></head><body><pre>bing
|
||||
bang
|
||||
bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: xmode.tokens xmode.marker xmode.catalog kernel locals
|
||||
html.elements io io.files sequences words io.encodings.utf8
|
||||
namespaces xml.entities accessors xml.interpolate locals xml.writer ;
|
||||
namespaces xml.entities accessors xml.literals locals xml.writer ;
|
||||
IN: xmode.code2html
|
||||
|
||||
: htmlize-tokens ( tokens -- xml )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,198 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations strings multiline ;
|
||||
IN: 4DNav
|
||||
|
||||
|
||||
HELP: menu-3D
|
||||
{ $values
|
||||
{ "gadget" "gadget" }
|
||||
}
|
||||
{ $description "The menu dedicated to 3D movements of the camera" } ;
|
||||
|
||||
HELP: menu-4D
|
||||
{ $values
|
||||
|
||||
{ "gadget" "gadget" }
|
||||
}
|
||||
{ $description "The menu dedicated to 4D movements of space" } ;
|
||||
|
||||
HELP: menu-bar
|
||||
{ $values
|
||||
|
||||
{ "gadget" "gadget" }
|
||||
}
|
||||
{ $description "return gadget containing menu buttons" } ;
|
||||
|
||||
HELP: model-projection
|
||||
{ $values
|
||||
{ "x" "interger" }
|
||||
{ "space" "space" }
|
||||
}
|
||||
{ $description "Project space following coordinate x" } ;
|
||||
|
||||
HELP: mvt-3D-1
|
||||
{ $values
|
||||
|
||||
{ "quot" "quotation" }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: mvt-3D-2
|
||||
{ $values
|
||||
|
||||
{ "quot" "quotation" }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from second point of view" } ;
|
||||
|
||||
HELP: mvt-3D-3
|
||||
{ $values
|
||||
|
||||
{ "quot" "quotation" }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from third point of view" } ;
|
||||
|
||||
HELP: mvt-3D-4
|
||||
{ $values
|
||||
|
||||
{ "quot" "quotation" }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: load-model-file
|
||||
{ $description "load space from file" } ;
|
||||
|
||||
HELP: rotation-4D
|
||||
{ $values
|
||||
{ "m" "a rotation matrix" }
|
||||
}
|
||||
{ $description "Apply a 4D rotation matrix" } ;
|
||||
|
||||
HELP: translation-4D
|
||||
{ $values
|
||||
{ "v" "vector" }
|
||||
}
|
||||
{ $description "Apply a 4D translation" } ;
|
||||
|
||||
|
||||
ARTICLE: "implementation details" "How 4DNav is done"
|
||||
"4DNav is build using :"
|
||||
|
||||
{ $subsection "4DNav.camera" }
|
||||
{ $subsection "adsoda-main-page" }
|
||||
;
|
||||
|
||||
ARTICLE: "Space file" "Create a new space file"
|
||||
"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
|
||||
|
||||
$nl
|
||||
"An example is:"
|
||||
{ $code <"
|
||||
<model>
|
||||
<space>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>4cube1</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,100</face>
|
||||
<face>-1,0,0,0,-150</face>
|
||||
<face>0,1,0,0,100</face>
|
||||
<face>0,-1,0,0,-150</face>
|
||||
<face>0,0,1,0,100</face>
|
||||
<face>0,0,-1,0,-150</face>
|
||||
<face>0,0,0,1,100</face>
|
||||
<face>0,0,0,-1,-150</face>
|
||||
<color>1,0,0</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>4triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,160</face>
|
||||
<face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
|
||||
<face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
|
||||
<face>0,0,1,0,140</face>
|
||||
<face>0,0,-1,0,-180</face>
|
||||
<face>0,0,0,1,110</face>
|
||||
<face>0,0,0,-1,-180</face>
|
||||
<color>0,1,0</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>triangone</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,60</face>
|
||||
<face>0.5,0.8660254037844386,0,0,60</face>
|
||||
<face>-0.5,0.8660254037844387,0,0,-20</face>
|
||||
<face>-1.0,0,0,0,-100</face>
|
||||
<face>-0.5,-0.8660254037844384,0,0,-100</face>
|
||||
<face>0.5,-0.8660254037844387,0,0,-20</face>
|
||||
<face>0,0,1,0,120</face>
|
||||
<face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
|
||||
<face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
|
||||
<color>0,1,1</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,1,1,1</direction>
|
||||
<color>0.2,0.2,0.6</color>
|
||||
</light>
|
||||
<color>0.8,0.9,0.9</color>
|
||||
</space>
|
||||
</model> "> } ;
|
||||
|
||||
ARTICLE: "TODO" "Todo"
|
||||
{ $list
|
||||
"A vocab to initialize parameters"
|
||||
"an editor mode"
|
||||
{ $list "add a face to a solid"
|
||||
"add a solid to the space"
|
||||
"move a face"
|
||||
"move a solid"
|
||||
"select a solid in a list"
|
||||
"select a face"
|
||||
"display selected face"
|
||||
"edit a solid color"
|
||||
"add a light"
|
||||
"edit a light color"
|
||||
"move a light"
|
||||
}
|
||||
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
|
||||
"decorrelate 3D camera and activate them with select buttons"
|
||||
|
||||
} ;
|
||||
|
||||
|
||||
ARTICLE: "4DNav" "The 4DNav app"
|
||||
{ $vocab-link "4DNav" }
|
||||
$nl
|
||||
{ $heading "4D Navigator" }
|
||||
"4DNav is a simple tool to visualize 4 dimensionnal objects."
|
||||
$nl
|
||||
"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
|
||||
$nl
|
||||
"It will display:"
|
||||
{ $list
|
||||
{ "a menu window" }
|
||||
{ "4 visualization windows" }
|
||||
}
|
||||
"Each visualization window represents the projection of the 4D space on a particular 3D space."
|
||||
|
||||
{ $heading "Start" }
|
||||
"type:" { $code "\"4DNav\" run" }
|
||||
|
||||
{ $heading "Navigation" }
|
||||
"Menu window is divided in 4 areas"
|
||||
{ $list
|
||||
{ "a space-file chooser to select the file to display" }
|
||||
{ "a parametrization area to select the projection mode" }
|
||||
{ "4D submenu to translate and rotate the 4D space" }
|
||||
{ "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
|
||||
}
|
||||
|
||||
{ $heading "Links" }
|
||||
{ $subsection "Space file" }
|
||||
|
||||
{ $subsection "TODO" }
|
||||
{ $subsection "implementation details" }
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "4DNav"
|
||||
|
|
@ -109,34 +109,36 @@ VAR: present-space
|
|||
[ dup cos , 0.0 , dup sin neg , 0.0 ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
dup sin , 0.0 , dup cos , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rzw ( angle -- Rz ) deg>rad
|
||||
[ dup cos , dup sin neg , 0.0 , 0.0 ,
|
||||
dup sin , dup cos , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! UI
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: button* ( string quot -- button ) closed-quot <repeat-button> ;
|
||||
: button* ( string quot -- button )
|
||||
closed-quot <repeat-button> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: model-projection-chooser ( -- gadget )
|
||||
observer3d> projection-mode>>
|
||||
{ { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;
|
||||
{ { 1 "perspective" } { 0 "orthogonal" } }
|
||||
<toggle-buttons> ;
|
||||
|
||||
: collision-detection-chooser ( -- gadget )
|
||||
observer3d> collision-mode>>
|
||||
{ { t "on" } { f "off" } } <toggle-buttons>
|
||||
;
|
||||
{ { t "on" } { f "off" } } <toggle-buttons> ;
|
||||
|
||||
: model-projection ( x -- space ) present-space> swap space-project ;
|
||||
: model-projection ( x -- space )
|
||||
present-space> swap space-project ;
|
||||
|
||||
: update-observer-projections ( -- )
|
||||
view1> relayout-1
|
||||
|
|
@ -151,14 +153,16 @@ VAR: present-space
|
|||
3 model-projection <model> view4> (>>model) ;
|
||||
|
||||
: camera-action ( quot -- quot )
|
||||
[ drop [ ] observer3d> with-self update-observer-projections ]
|
||||
[ drop [ ] observer3d>
|
||||
with-self update-observer-projections ]
|
||||
make* closed-quot ;
|
||||
|
||||
: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;
|
||||
: win3D ( text gadget -- )
|
||||
"navigateur 4D : " rot append open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 4D object manipulation
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (mvt-4D) ( quot -- )
|
||||
present-space>
|
||||
|
|
@ -168,42 +172,55 @@ VAR: present-space
|
|||
update-observer-projections ;
|
||||
|
||||
: rotation-4D ( m -- )
|
||||
'[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip
|
||||
'[ _ [ [ middle-of-space dup vneg ] keep
|
||||
swap space-translate ] dip
|
||||
space-transform
|
||||
swap space-translate
|
||||
] (mvt-4D) ;
|
||||
|
||||
: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! menu
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: menu-rotations-4D ( -- gadget )
|
||||
<frame>
|
||||
<pile> 1 >>fill
|
||||
"XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget
|
||||
"XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget
|
||||
"XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
|
||||
button* add-gadget
|
||||
"XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ]
|
||||
button* add-gadget
|
||||
@top-left grid-add
|
||||
<pile> 1 >>fill
|
||||
"XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget
|
||||
"XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget
|
||||
"XZ +" [ drop rotation-step 4D-Rxz rotation-4D ]
|
||||
button* add-gadget
|
||||
"XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ]
|
||||
button* add-gadget
|
||||
@top grid-add
|
||||
<pile> 1 >>fill
|
||||
"YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget
|
||||
"YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget
|
||||
"YZ +" [ drop rotation-step 4D-Ryz rotation-4D ]
|
||||
button* add-gadget
|
||||
"YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ]
|
||||
button* add-gadget
|
||||
@center grid-add
|
||||
<pile> 1 >>fill
|
||||
"XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget
|
||||
"XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget
|
||||
"XW +" [ drop rotation-step 4D-Rxw rotation-4D ]
|
||||
button* add-gadget
|
||||
"XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ]
|
||||
button* add-gadget
|
||||
@top-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget
|
||||
"YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget
|
||||
"YW +" [ drop rotation-step 4D-Ryw rotation-4D ]
|
||||
button* add-gadget
|
||||
"YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ]
|
||||
button* add-gadget
|
||||
@right grid-add
|
||||
<pile> 1 >>fill
|
||||
"ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget
|
||||
"ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget
|
||||
"ZW +" [ drop rotation-step 4D-Rzw rotation-4D ]
|
||||
button* add-gadget
|
||||
"ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ]
|
||||
button* add-gadget
|
||||
@bottom-right grid-add
|
||||
;
|
||||
|
||||
|
|
@ -211,9 +228,11 @@ VAR: present-space
|
|||
<frame>
|
||||
<pile> 1 >>fill
|
||||
<shelf> 1 >>fill
|
||||
"X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ]
|
||||
"X+" [ drop { 1 0 0 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
"X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ]
|
||||
"X-" [ drop { -1 0 0 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"YZW" <label> add-gadget
|
||||
|
|
@ -221,26 +240,32 @@ VAR: present-space
|
|||
<pile> 1 >>fill
|
||||
"XZW" <label> add-gadget
|
||||
<shelf> 1 >>fill
|
||||
"Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ]
|
||||
"Y+" [ drop { 0 1 0 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
"Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ]
|
||||
"Y-" [ drop { 0 -1 0 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
@top-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"XYW" <label> add-gadget
|
||||
<shelf> 1 >>fill
|
||||
"Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ]
|
||||
"Z+" [ drop { 0 0 1 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
"Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ]
|
||||
"Z-" [ drop { 0 0 -1 0 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
@top-left grid-add
|
||||
<pile> 1 >>fill
|
||||
<shelf> 1 >>fill
|
||||
"W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ]
|
||||
"W+" [ drop { 0 0 0 1 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
"W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ]
|
||||
"W-" [ drop { 0 0 0 -1 } translation-step v*n
|
||||
translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"XYZ" <label> add-gadget
|
||||
|
|
@ -267,7 +292,8 @@ VAR: present-space
|
|||
update-observer-projections ;
|
||||
|
||||
: load-model-file ( -- )
|
||||
selected-file dup selected-file-model> set-model read-model-file
|
||||
selected-file dup selected-file-model> set-model
|
||||
read-model-file
|
||||
redraw-model ;
|
||||
|
||||
: mvt-3D-X ( turn pitch -- quot )
|
||||
|
|
@ -305,37 +331,38 @@ VAR: present-space
|
|||
|
||||
: menu-rotations-3D ( -- gadget )
|
||||
<frame>
|
||||
"Turn\n left" [ rotation-step turn-left ] camera-button
|
||||
@left grid-add
|
||||
"Turn\n right" [ rotation-step turn-right ] camera-button
|
||||
@right grid-add
|
||||
"Pitch down" [ rotation-step pitch-down ] camera-button
|
||||
@bottom grid-add
|
||||
"Pitch up" [ rotation-step pitch-up ] camera-button
|
||||
@top grid-add
|
||||
"Turn\n left" [ rotation-step turn-left ]
|
||||
camera-button @left grid-add
|
||||
"Turn\n right" [ rotation-step turn-right ]
|
||||
camera-button @right grid-add
|
||||
"Pitch down" [ rotation-step pitch-down ]
|
||||
camera-button @bottom grid-add
|
||||
"Pitch up" [ rotation-step pitch-up ]
|
||||
camera-button @top grid-add
|
||||
<shelf> 1 >>fill
|
||||
"Roll left\n (ctl)" [ rotation-step roll-left ] camera-button
|
||||
add-gadget
|
||||
"Roll right\n(ctl)" [ rotation-step roll-right ] camera-button
|
||||
add-gadget
|
||||
"Roll left\n (ctl)" [ rotation-step roll-left ]
|
||||
camera-button add-gadget
|
||||
"Roll right\n(ctl)" [ rotation-step roll-right ]
|
||||
camera-button add-gadget
|
||||
@center grid-add
|
||||
;
|
||||
|
||||
: menu-translations-3D ( -- gadget )
|
||||
<frame>
|
||||
"left\n(alt)" [ translation-step strafe-left ] camera-button
|
||||
@left grid-add
|
||||
"right\n(alt)" [ translation-step strafe-right ] camera-button
|
||||
@right grid-add
|
||||
"Strafe up \n (alt)" [ translation-step strafe-up ] camera-button
|
||||
@top grid-add
|
||||
"Strafe down \n (alt)" [ translation-step strafe-down ] camera-button
|
||||
@bottom grid-add
|
||||
"left\n(alt)" [ translation-step strafe-left ]
|
||||
camera-button @left grid-add
|
||||
"right\n(alt)" [ translation-step strafe-right ]
|
||||
camera-button @right grid-add
|
||||
"Strafe up \n (alt)" [ translation-step strafe-up ]
|
||||
camera-button @top grid-add
|
||||
"Strafe down\n (alt)" [ translation-step strafe-down ]
|
||||
camera-button @bottom grid-add
|
||||
<pile> 1 >>fill
|
||||
"Forward (ctl)" [ translation-step step-turtle ] camera-button
|
||||
add-gadget
|
||||
"Backward (ctl)" [ translation-step neg step-turtle ] camera-button
|
||||
add-gadget
|
||||
"Forward (ctl)" [ translation-step step-turtle ]
|
||||
camera-button add-gadget
|
||||
"Backward (ctl)"
|
||||
[ translation-step neg step-turtle ]
|
||||
camera-button add-gadget
|
||||
@center grid-add
|
||||
;
|
||||
|
||||
|
|
@ -370,22 +397,23 @@ VAR: present-space
|
|||
[ [ rotation-step pitch-up ] camera-action ] }
|
||||
|
||||
{ T{ key-down f { C+ } "UP" }
|
||||
[ [ translation-step step-turtle ] camera-action ] }
|
||||
[ [ translation-step step-turtle ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "DOWN" }
|
||||
[ [ translation-step neg step-turtle ] camera-action ] }
|
||||
[ [ translation-step neg step-turtle ]
|
||||
camera-action ] }
|
||||
{ T{ key-down f { C+ } "LEFT" }
|
||||
[ [ rotation-step roll-left ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "RIGHT" }
|
||||
[ [ rotation-step roll-right ] camera-action ] }
|
||||
|
||||
{ T{ key-down f { A+ } "LEFT" }
|
||||
[ [ translation-step strafe-left ] camera-action ] }
|
||||
[ [ translation-step strafe-left ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "RIGHT" }
|
||||
[ [ translation-step strafe-right ] camera-action ] }
|
||||
[ [ translation-step strafe-right ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "UP" }
|
||||
[ [ translation-step strafe-up ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "DOWN" }
|
||||
[ [ translation-step strafe-down ] camera-action ] }
|
||||
[ [ translation-step strafe-down ] camera-action ] }
|
||||
|
||||
|
||||
{ T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
|
||||
|
|
@ -422,23 +450,26 @@ M: solid adsoda-display-model
|
|||
[ name>> "solid called : " pprint . ]
|
||||
[ color>> "color : " pprint . ]
|
||||
[ dimension>> "dimension : " pprint . ]
|
||||
[ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]
|
||||
[ faces>> "composed of faces : " pprint
|
||||
[ adsoda-display-model ] each ]
|
||||
} cleave
|
||||
;
|
||||
M: space adsoda-display-model
|
||||
{
|
||||
[ dimension>> "dimension : " pprint . ]
|
||||
[ ambient-color>> "ambient-color : " pprint . ]
|
||||
[ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]
|
||||
[ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ]
|
||||
[ solids>> "composed of solids : " pprint
|
||||
[ adsoda-display-model ] each ]
|
||||
[ lights>> "composed of lights : " pprint
|
||||
[ adsoda-display-model ] each ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
! ----------------------------------------------
|
||||
: menu-bar ( -- gadget )
|
||||
<shelf>
|
||||
"reinit" [ drop load-model-file ] button* add-gadget
|
||||
selected-file-model> <label-control> add-gadget
|
||||
"reinit" [ drop load-model-file ] button* add-gadget
|
||||
selected-file-model> <label-control> add-gadget
|
||||
;
|
||||
|
||||
|
||||
|
|
@ -454,7 +485,8 @@ M: space adsoda-display-model
|
|||
model-projection-chooser add-gadget
|
||||
f track-add
|
||||
<shelf>
|
||||
"Collision detection (slow and buggy ) : " <label> add-gadget
|
||||
"Collision detection (slow and buggy ) : "
|
||||
<label> add-gadget
|
||||
collision-detection-chooser add-gadget
|
||||
f track-add
|
||||
<pile>
|
||||
|
|
@ -6,41 +6,41 @@ IN: 4DNav.camera
|
|||
HELP: camera-eye
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
{ "point" "position" }
|
||||
}
|
||||
{ $description "return the position of the camera" } ;
|
||||
|
||||
HELP: camera-focus
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
{ "point" "position" }
|
||||
}
|
||||
{ $description "return the point the camera looks at" } ;
|
||||
|
||||
HELP: camera-up
|
||||
{ $values
|
||||
|
||||
{ "dirvec" null }
|
||||
{ "dirvec" "upside direction" }
|
||||
}
|
||||
{ $description "In order to precise the roling position of camera give an upward vector" } ;
|
||||
|
||||
HELP: do-look-at
|
||||
{ $values
|
||||
{ "camera" null }
|
||||
{ "camera" "direction" }
|
||||
}
|
||||
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
|
||||
|
||||
ARTICLE: "4DNav.camera" "4DNav.camera"
|
||||
ARTICLE: "4DNav.camera" "Camera"
|
||||
{ $vocab-link "4DNav.camera" }
|
||||
"\n"
|
||||
$nl
|
||||
"A camera is defined by:"
|
||||
{ $list
|
||||
{ "a position (" { $link camera-eye } ")" }
|
||||
{ "a focus direction (" { $link camera-focus } ")\n" }
|
||||
{ "an attitude information (" { $link camera-up } ")\n" }
|
||||
{ "a focus direction (" { $link camera-focus } ")" }
|
||||
{ "an attitude information (" { $link camera-up } ")" }
|
||||
}
|
||||
"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
|
||||
"\n\n"
|
||||
"Use " { $link do-look-at } " in opengl statement in placement of gl-look-at"
|
||||
$nl
|
||||
"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
|
||||
{ $list
|
||||
{ "To define a camera"
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
USING: kernel namespaces math.vectors opengl 4DNav.turtle
|
||||
self ;
|
||||
|
||||
IN: 4DNav.camera
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: camera-eye ( -- point ) turtle-pos> ;
|
||||
|
||||
: camera-focus ( -- point )
|
||||
[ 1 step-turtle turtle-pos> ] save-self ;
|
||||
|
||||
: camera-up ( -- dirvec )
|
||||
[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ]
|
||||
save-self ;
|
||||
|
||||
: do-look-at ( camera -- )
|
||||
[ >self camera-eye camera-focus camera-up gl-look-at ]
|
||||
with-scope ;
|
||||
|
|
@ -24,7 +24,7 @@ IN: 4DNav.deep
|
|||
! } }
|
||||
! ;
|
||||
|
||||
ARTICLE: "4DNav.deep" "4DNav.deep"
|
||||
ARTICLE: "4DNav.deep" "Deep"
|
||||
{ $vocab-link "4DNav.deep" }
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
USING: macros quotations math math.functions math.trig
|
||||
sequences.deep kernel make fry combinators grouping ;
|
||||
IN: 4DNav.deep
|
||||
|
||||
! USING: bake ;
|
||||
! MACRO: deep-cleave-quots ( seq -- quot )
|
||||
! [ [ quotation? ] deep-filter ]
|
||||
! [ [ dup quotation? [ drop , ] when ] deep-map ]
|
||||
! bi '[ _ cleave _ bake ] ;
|
||||
|
||||
: make-matrix ( quot width -- matrix )
|
||||
[ { } make ] dip group ; inline
|
||||
|
||||
|
|
@ -45,18 +45,26 @@ TUPLE: file-chooser < track
|
|||
[ file-chooser? ] find-parent list>> ;
|
||||
|
||||
file-chooser H{
|
||||
{ T{ key-down f f "UP" } [ find-file-list select-previous ] }
|
||||
{ T{ key-down f f "DOWN" } [ find-file-list select-next ] }
|
||||
{ T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }
|
||||
{ T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }
|
||||
{ T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }
|
||||
{ T{ button-down } request-focus }
|
||||
{ T{ button-down f 1 } [ find-file-list invoke-value-action ] }
|
||||
{ T{ key-down f f "UP" }
|
||||
[ find-file-list select-previous ] }
|
||||
{ T{ key-down f f "DOWN" }
|
||||
[ find-file-list select-next ] }
|
||||
{ T{ key-down f f "PAGE_UP" }
|
||||
[ find-file-list list-page-up ] }
|
||||
{ T{ key-down f f "PAGE_DOWN" }
|
||||
[ find-file-list list-page-down ] }
|
||||
{ T{ key-down f f "RET" }
|
||||
[ find-file-list invoke-value-action ] }
|
||||
{ T{ button-down }
|
||||
request-focus }
|
||||
{ T{ button-down f 1 }
|
||||
[ find-file-list invoke-value-action ] }
|
||||
} set-gestures
|
||||
|
||||
: list-of-files ( file-chooser -- seq )
|
||||
[ path>> value>> directory-entries ] [ extension>> ] bi
|
||||
'[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter
|
||||
'[ [ name>> _ [ tail? ] with any? ]
|
||||
[ directory? ] bi or ] filter
|
||||
;
|
||||
|
||||
: update-filelist-model ( file-chooser -- file-chooser )
|
||||
|
|
@ -123,15 +131,19 @@ file-chooser H{
|
|||
dup <file-list> >>list
|
||||
"choose a file in directory " <label> f track-add
|
||||
dup path>> <label-control> f track-add
|
||||
dup extension>> ", " join "limited to : " prepend <label> f track-add
|
||||
dup extension>> ", " join "limited to : " prepend
|
||||
<label> f track-add
|
||||
<shelf>
|
||||
"selected file : " <label> add-gadget
|
||||
over selected-file>> <label-control> add-gadget
|
||||
f track-add
|
||||
<shelf>
|
||||
over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget
|
||||
over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget
|
||||
! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget
|
||||
over [ swap fc-go-parent ] curry "go up"
|
||||
swap <bevel-button> add-gadget
|
||||
over [ swap fc-go-home ] curry "go home"
|
||||
swap <bevel-button> add-gadget
|
||||
! over [ swap fc-ok-action ] curry "OK"
|
||||
! swap <bevel-button> add-gadget
|
||||
! [ drop ] "Cancel" swap <bevel-button> add-gadget
|
||||
f track-add
|
||||
dup list>> <scroller> 1 track-add
|
||||
|
|
@ -140,5 +152,6 @@ file-chooser H{
|
|||
M: file-chooser pref-dim* drop { 400 200 } ;
|
||||
|
||||
: file-chooser-window ( -- )
|
||||
[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;
|
||||
[ . ] home { "xml" "txt" } <file-chooser>
|
||||
"Choose a file" open-window ;
|
||||
|
||||
|
|
@ -3,28 +3,17 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.space-file-decoder
|
||||
|
||||
HELP: adsoda-read-model
|
||||
{ $values
|
||||
{ "tag" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: decode-number-array
|
||||
{ $values
|
||||
{ "x" null }
|
||||
{ "y" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: read-model-file
|
||||
{ $values
|
||||
|
||||
{ "path" "path to the file to read" }
|
||||
{ "x" null }
|
||||
{ "x" "value" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Read a file containing the xml description of the model" } ;
|
||||
|
||||
ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
|
||||
ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
|
||||
{ $vocab-link "4DNav.space-file-decoder" }
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: adsoda xml xml.utilities xml.dispatch accessors
|
||||
combinators sequences math.parser kernel splitting values
|
||||
continuations ;
|
||||
IN: 4DNav.space-file-decoder
|
||||
|
||||
: decode-number-array ( x -- y )
|
||||
"," split [ string>number ] map ;
|
||||
|
||||
PROCESS: adsoda-read-model ( tag -- )
|
||||
|
||||
TAG: dimension adsoda-read-model
|
||||
children>> first string>number ;
|
||||
TAG: direction adsoda-read-model
|
||||
children>> first decode-number-array ;
|
||||
TAG: color adsoda-read-model
|
||||
children>> first decode-number-array ;
|
||||
TAG: name adsoda-read-model
|
||||
children>> first ;
|
||||
TAG: face adsoda-read-model
|
||||
children>> first decode-number-array ;
|
||||
|
||||
TAG: solid adsoda-read-model
|
||||
<solid> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
[ "face"
|
||||
tags-named [ adsoda-read-model cut-solid ] each ]
|
||||
} cleave
|
||||
ensure-adjacencies
|
||||
;
|
||||
|
||||
TAG: light adsoda-read-model
|
||||
<light> swap
|
||||
{
|
||||
[ "direction" tag-named adsoda-read-model >>direction ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
TAG: space adsoda-read-model
|
||||
<space> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named
|
||||
adsoda-read-model >>ambient-color ]
|
||||
[ "solid" tags-named
|
||||
[ adsoda-read-model suffix-solids ] each ]
|
||||
[ "light" tags-named
|
||||
[ adsoda-read-model suffix-lights ] each ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
: read-model-file ( path -- x )
|
||||
dup
|
||||
[
|
||||
[ file>xml "space" tags-named first adsoda-read-model ]
|
||||
[ drop <space> ] recover
|
||||
] [ drop <space> ] if
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
|
||||
ARTICLE: "4DNav.turtle" "Turtle"
|
||||
{ $vocab-link "4DNav.turtle" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.turtle"
|
||||
|
|
@ -6,7 +6,7 @@ splitting grouping self math.trig
|
|||
sequences accessors 4DNav.deep models ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: turtle pos ori ;
|
||||
|
||||
|
|
@ -32,7 +32,7 @@ TUPLE: observer < turtle projection-mode collision-mode ;
|
|||
: turtle-ori> ( -- val ) self> ori>> ;
|
||||
: >turtle-ori ( val -- ) self> (>>ori) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! These rotation matrices are from
|
||||
! `Computer Graphics: Principles and Practice'
|
||||
|
|
@ -74,15 +74,15 @@ TUPLE: observer < turtle projection-mode collision-mode ;
|
|||
0 , dup sin , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-ori ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-rotation ( rotation -- )
|
||||
turtle-ori> swap m. >turtle-ori ;
|
||||
: rotate-x ( angle -- ) Rx apply-rotation ;
|
||||
: rotate-y ( angle -- ) Ry apply-rotation ;
|
||||
: rotate-z ( angle -- ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( angle -- ) neg rotate-x ;
|
||||
: pitch-down ( angle -- ) rotate-x ;
|
||||
|
|
@ -93,9 +93,9 @@ TUPLE: observer < turtle projection-mode collision-mode ;
|
|||
: roll-left ( angle -- ) neg rotate-z ;
|
||||
: roll-right ( angle -- ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! roll-until-horizontal
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
|
|
@ -111,25 +111,27 @@ TUPLE: observer < turtle projection-mode collision-mode ;
|
|||
V Z cross normalize set-X
|
||||
Z X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: distance ( turtle turtle -- n ) pos>> swap pos>> v- [ sq ] map sum sqrt ;
|
||||
: distance ( turtle turtle -- n )
|
||||
pos>> swap pos>> v- [ sq ] map sum sqrt ;
|
||||
|
||||
: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reset-turtle ( -- )
|
||||
{ 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: step-vector ( length -- array ) { 0 0 1 } n*v ;
|
||||
|
||||
: step-turtle ( length -- )
|
||||
step-vector turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
|
||||
step-vector turtle-ori> swap m.v
|
||||
turtle-pos> v+ >turtle-pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: strafe-up ( length -- )
|
||||
90 pitch-up
|
||||
|
|
@ -3,17 +3,9 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.window3D
|
||||
|
||||
HELP: <window3D>
|
||||
{ $values
|
||||
{ "model" null } { "observer" null }
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: window3D
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.window3D" "4DNav.window3D"
|
||||
ARTICLE: "4DNav.window3D" "Window3D"
|
||||
{ $vocab-link "4DNav.window3D" }
|
||||
;
|
||||
|
||||
|
|
@ -21,9 +21,9 @@ prettyprint
|
|||
|
||||
IN: 4DNav.window3D
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! drawing functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: window3D < gadget observer ;
|
||||
|
||||
|
|
@ -63,7 +63,8 @@ M: window3D draw-gadget* ( gadget -- )
|
|||
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
||||
GL_LINE_SMOOTH_HINT GL_NICEST glHint
|
||||
1.25 glLineWidth
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor
|
||||
glClear
|
||||
glLoadIdentity
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
|
|
@ -1,23 +1,19 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
USING: help.markup help.syntax multiline ;
|
||||
IN: adsoda
|
||||
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! faces
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "face-page" "face in ADSODA"
|
||||
ARTICLE: "face-page" "Face in ADSODA"
|
||||
"explanation of faces"
|
||||
$nl
|
||||
"link to functions"
|
||||
"what is an halfspace"
|
||||
"halfspace touching-corners adjacent-faces"
|
||||
"touching-corners list of pointers to the corners which touch this face\n"
|
||||
|
||||
"adjacent-faces list of pointers to the faces which touch this face\n"
|
||||
"link to functions" $nl
|
||||
"what is an halfspace" $nl
|
||||
"halfspace touching-corners adjacent-faces" $nl
|
||||
"touching-corners list of pointers to the corners which touch this face" $nl
|
||||
"adjacent-faces list of pointers to the faces which touch this face"
|
||||
{ $subsection face }
|
||||
{ $subsection <face> }
|
||||
"test relative position"
|
||||
|
|
@ -65,7 +61,7 @@ HELP: face-transform
|
|||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "solid-page" "solid in ADSODA"
|
||||
ARTICLE: "solid-page" "Solid in ADSODA"
|
||||
"explanation of solids"
|
||||
$nl
|
||||
"link to functions"
|
||||
|
|
@ -133,13 +129,13 @@ $nl
|
|||
|
||||
HELP: subtract
|
||||
{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
|
||||
{ $description " " } ;
|
||||
{ $description "Substract solid2 from solid1" } ;
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! space
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "space-page" "space in ADSODA"
|
||||
ARTICLE: "space-page" "Space in ADSODA"
|
||||
"A space is a collection of solids and lights."
|
||||
$nl
|
||||
"link to functions"
|
||||
|
|
@ -211,7 +207,7 @@ HELP: space-project
|
|||
! --------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"
|
||||
ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"
|
||||
"explanation of 3D rendering"
|
||||
$nl
|
||||
"link to functions"
|
||||
|
|
@ -223,58 +219,53 @@ $nl
|
|||
|
||||
HELP: face->GL
|
||||
{ $values { "face" "a face" } { "color" "3 3 values array" } }
|
||||
{ $description "" } ;
|
||||
{ $description "display a face" } ;
|
||||
|
||||
HELP: solid->GL
|
||||
{ $values { "solid" "a solid" } }
|
||||
{ $description "" } ;
|
||||
{ $description "display a solid" } ;
|
||||
|
||||
HELP: space->GL
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "" } ;
|
||||
{ $description "display a space" } ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! light
|
||||
! --------------------------------------------------------------
|
||||
|
||||
ARTICLE: "light-page" "light in ADSODA"
|
||||
ARTICLE: "light-page" "Light in ADSODA"
|
||||
"explanation of light"
|
||||
$nl
|
||||
"link to functions"
|
||||
;
|
||||
|
||||
ARTICLE: { "adsoda" "light" } "ADSODA : lights"
|
||||
"! HELP: light position color"
|
||||
"! <light> ( -- tuple ) light new ;"
|
||||
|
||||
"! light est un vecteur avec 3 variables pour les couleurs\n"
|
||||
|
||||
" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"
|
||||
" { \n"
|
||||
" // Dot the light direction with the normalized normal of Face."
|
||||
" register double intensity = -(normal * (*this));"
|
||||
|
||||
" // Face is a backface, from light's perspective"
|
||||
" if (intensity < 0)"
|
||||
" return;"
|
||||
" "
|
||||
" // Add the intensity componentwise"
|
||||
" cRed += red * intensity;"
|
||||
" cGreen += green * intensity;"
|
||||
" cBlue += blue * intensity;"
|
||||
|
||||
" // Clip to unit range"
|
||||
" if (cRed > 1.0) cRed = 1.0;"
|
||||
" if (cGreen > 1.0) cGreen = 1.0;"
|
||||
" if (cBlue > 1.0) cBlue = 1.0;"
|
||||
|
||||
|
||||
{ $code <"
|
||||
! HELP: light position color
|
||||
! <light> ( -- tuple ) light new ;
|
||||
! light est un vecteur avec 3 variables pour les couleurs\n
|
||||
void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n
|
||||
{ \n
|
||||
// Dot the light direction with the normalized normal of Face.
|
||||
register double intensity = -(normal * (*this));
|
||||
// Face is a backface, from light's perspective
|
||||
if (intensity < 0)
|
||||
return;
|
||||
|
||||
// Add the intensity componentwise
|
||||
cRed += red * intensity;
|
||||
cGreen += green * intensity;
|
||||
cBlue += blue * intensity;
|
||||
// Clip to unit range
|
||||
if (cRed > 1.0) cRed = 1.0;
|
||||
if (cGreen > 1.0) cGreen = 1.0;
|
||||
if (cBlue > 1.0) cBlue = 1.0;
|
||||
"> }
|
||||
;
|
||||
|
||||
|
||||
|
||||
ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"
|
||||
"! demi espace défini par un vecteur normal et une constante"
|
||||
" defined by the concatenation of the normal vector and a constant"
|
||||
;
|
||||
|
||||
|
|
@ -41,7 +41,7 @@ DEFER: combinations
|
|||
VAR: pv
|
||||
|
||||
|
||||
! ---------------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! global values
|
||||
VALUE: remove-hidden-solids?
|
||||
VALUE: VERY-SMALL-NUM
|
||||
|
|
@ -52,25 +52,26 @@ t to: remove-hidden-solids?
|
|||
0.0000001 to: VERY-SMALL-NUM
|
||||
0.0000001 to: ZERO-VALUE
|
||||
4 to: MAX-FACE-PER-CORNER
|
||||
! ---------------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! sequence complement
|
||||
|
||||
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
|
||||
|
||||
: dimension ( array -- x ) length 1- ; inline
|
||||
: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline
|
||||
: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ;
|
||||
: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline
|
||||
: change-last ( seq quot -- )
|
||||
[ [ dimension ] keep ] dip change-nth ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! light
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
|
||||
TUPLE: light name { direction array } color ;
|
||||
: <light> ( -- tuple ) light new ;
|
||||
|
||||
! -----------------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! halfspace manipulation
|
||||
! -----------------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
|
||||
: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
|
||||
: translate ( u v -- w ) dupd v* sum constant+ ;
|
||||
|
|
@ -78,7 +79,8 @@ TUPLE: light name { direction array } color ;
|
|||
: transform ( u matrix -- w )
|
||||
[ swap m.v ] 2keep ! compute new normal vector
|
||||
[
|
||||
[ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier
|
||||
[ [ abs ZERO-VALUE > ] find ] keep
|
||||
! find a point on the frontier
|
||||
! be sure it's not null vector
|
||||
last ! get constant
|
||||
swap /f neg swap ! intercept value
|
||||
|
|
@ -97,8 +99,10 @@ TUPLE: light name { direction array } color ;
|
|||
position-point VERY-SMALL-NUM > ;
|
||||
: point-inside-or-on-halfspace? ( halfspace v -- ? )
|
||||
position-point VERY-SMALL-NUM neg > ;
|
||||
: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ;
|
||||
: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;
|
||||
: project-vector ( seq -- seq )
|
||||
pv> [ head ] [ 1+ tail ] 2bi append ;
|
||||
: get-intersection ( matrice -- seq )
|
||||
[ 1 tail* ] map flip first ;
|
||||
|
||||
: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
|
||||
|
||||
|
|
@ -117,29 +121,33 @@ TUPLE: light name { direction array } color ;
|
|||
[ solution dup ] [ first dimension ] bi
|
||||
valid-solution? [ get-intersection ] [ drop f ] if ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! faces
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
|
||||
TUPLE: face { halfspace array } touching-corners adjacent-faces ;
|
||||
TUPLE: face { halfspace array }
|
||||
touching-corners adjacent-faces ;
|
||||
: <face> ( v -- tuple ) face new swap >>halfspace ;
|
||||
: flip-face ( face -- face ) [ vneg ] change-halfspace ;
|
||||
: erase-face-touching-corners ( face -- face ) f >>touching-corners ;
|
||||
: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;
|
||||
: erase-face-touching-corners ( face -- face )
|
||||
f >>touching-corners ;
|
||||
: erase-face-adjacent-faces ( face -- face )
|
||||
f >>adjacent-faces ;
|
||||
: faces-intersection ( faces -- v )
|
||||
[ halfspace>> ] map intersect-hyperplanes ;
|
||||
: face-translate ( face v -- face )
|
||||
[ translate ] curry change-halfspace ; inline
|
||||
: face-transform ( face m -- face )
|
||||
[ transform ] curry change-halfspace ; inline
|
||||
: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
|
||||
: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
|
||||
: backface? ( face -- face ? ) dup face-orientation 0 <= ;
|
||||
: pv-factor ( face -- f face )
|
||||
halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
|
||||
: suffix-touching-corner ( face corner -- face )
|
||||
[ suffix ] curry change-touching-corners ; inline
|
||||
: real-face? ( face -- ? )
|
||||
[ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;
|
||||
[ touching-corners>> length ]
|
||||
[ halfspace>> dimension ] bi >= ;
|
||||
|
||||
: (add-to-adjacent-faces) ( face face -- face )
|
||||
over adjacent-faces>> 2dup member?
|
||||
|
|
@ -203,7 +211,8 @@ TUPLE: face { halfspace array } touching-corners adjacent-faces ;
|
|||
[ ] (intersection-into-face) ;
|
||||
|
||||
: intersections-into-faces ( face -- faces )
|
||||
clone dup adjacent-faces>> [ intersection-into-face ] with map
|
||||
clone dup
|
||||
adjacent-faces>> [ intersection-into-face ] with map
|
||||
[ ] filter ;
|
||||
|
||||
: (face-silhouette) ( face -- faces )
|
||||
|
|
@ -219,30 +228,32 @@ TUPLE: face { halfspace array } touching-corners adjacent-faces ;
|
|||
|
||||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
||||
! -------------------------------------------------------------
|
||||
TUPLE: solid dimension silhouettes
|
||||
faces corners adjacencies-valid color name ;
|
||||
|
||||
: <solid> ( -- tuple ) solid new ;
|
||||
|
||||
: suffix-silhouettes ( solid silhouette -- solid )
|
||||
[ suffix ] curry change-silhouettes ;
|
||||
|
||||
: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;
|
||||
|
||||
: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ;
|
||||
|
||||
: suffix-face ( solid face -- solid )
|
||||
[ suffix ] curry change-faces ;
|
||||
: suffix-corner ( solid corner -- solid )
|
||||
[ suffix ] curry change-corners ;
|
||||
: erase-solid-corners ( solid -- solid ) f >>corners ;
|
||||
|
||||
: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;
|
||||
|
||||
: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;
|
||||
|
||||
: erase-silhouettes ( solid -- solid )
|
||||
dup dimension>> f <array> >>silhouettes ;
|
||||
: filter-real-faces ( solid -- solid )
|
||||
[ [ real-face? ] filter ] change-faces ;
|
||||
: initiate-solid-from-face ( face -- solid )
|
||||
face-project-dim <solid> swap >>dimension ;
|
||||
|
||||
: erase-old-adjacencies ( solid -- solid )
|
||||
erase-solid-corners
|
||||
[ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]
|
||||
[ dup [ erase-face-touching-corners
|
||||
erase-face-adjacent-faces drop ] each ]
|
||||
change-faces ;
|
||||
|
||||
: point-inside-or-on-face? ( face v -- ? )
|
||||
|
|
@ -252,13 +263,15 @@ TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
|||
[ halfspace>> ] dip point-inside-halfspace? ;
|
||||
|
||||
: point-inside-solid? ( solid point -- ? )
|
||||
[ faces>> ] dip [ point-inside-face? ] curry all? ; inline
|
||||
[ faces>> ] dip [ point-inside-face? ] curry all? ; inline
|
||||
|
||||
: point-inside-or-on-solid? ( solid point -- ? )
|
||||
[ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline
|
||||
[ faces>> ] dip
|
||||
[ point-inside-or-on-face? ] curry all? ; inline
|
||||
|
||||
: unvalid-adjacencies ( solid -- solid )
|
||||
erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;
|
||||
erase-old-adjacencies f >>adjacencies-valid
|
||||
erase-silhouettes ;
|
||||
|
||||
: add-face ( solid face -- solid )
|
||||
suffix-face unvalid-adjacencies ;
|
||||
|
|
@ -338,8 +351,10 @@ TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
|||
ensure-silhouettes
|
||||
;
|
||||
|
||||
: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;
|
||||
: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;
|
||||
: (non-empty-solid?) ( solid -- ? )
|
||||
[ dimension>> ] [ corners>> length ] bi < ;
|
||||
: non-empty-solid? ( solid -- ? )
|
||||
ensure-adjacencies (non-empty-solid?) ;
|
||||
|
||||
: compare-corners-roughly ( corner corner -- ? )
|
||||
2drop t ;
|
||||
|
|
@ -367,8 +382,10 @@ TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
|||
[ dup faces>> ] dip call drop
|
||||
unvalid-adjacencies ; inline
|
||||
|
||||
: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ;
|
||||
: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ;
|
||||
: solid-translate ( solid v -- solid )
|
||||
[ face-translate ] (solid-move) ;
|
||||
: solid-transform ( solid m -- solid )
|
||||
[ face-transform ] (solid-move) ;
|
||||
|
||||
: find-corner-in-silhouette ( s1 s2 -- elt bool )
|
||||
pv> swap silhouettes>> nth
|
||||
|
|
@ -402,13 +419,15 @@ TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
|||
[ ensure-adjacencies ] map
|
||||
; inline
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! space
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
TUPLE: space name dimension solids ambient-color lights ;
|
||||
: <space> ( -- space ) space new ;
|
||||
: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline
|
||||
: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline
|
||||
: suffix-solids ( space solid -- space )
|
||||
[ suffix ] curry change-solids ; inline
|
||||
: suffix-lights ( space light -- space )
|
||||
[ suffix ] curry change-lights ; inline
|
||||
: clear-space-solids ( space -- space ) f >>solids ;
|
||||
|
||||
: space-ensure-solids ( space -- space )
|
||||
|
|
@ -417,19 +436,24 @@ TUPLE: space name dimension solids ambient-color lights ;
|
|||
[ [ non-empty-solid? ] filter ] change-solids ;
|
||||
|
||||
: projected-space ( space solids -- space )
|
||||
swap dimension>> 1- <space> swap >>dimension swap >>solids ;
|
||||
swap dimension>> 1- <space>
|
||||
swap >>dimension swap >>solids ;
|
||||
|
||||
: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;
|
||||
: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;
|
||||
: get-silhouette ( solid -- silhouette )
|
||||
silhouettes>> pv> swap nth ;
|
||||
: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;
|
||||
|
||||
: space-apply ( space m quot -- space )
|
||||
curry [ map ] curry [ dup solids>> ] dip
|
||||
[ call ] [ drop ] recover drop ;
|
||||
: space-transform ( space m -- space ) [ solid-transform ] space-apply ;
|
||||
: space-translate ( space v -- space ) [ solid-translate ] space-apply ;
|
||||
: space-transform ( space m -- space )
|
||||
[ solid-transform ] space-apply ;
|
||||
: space-translate ( space v -- space )
|
||||
[ solid-translate ] space-apply ;
|
||||
|
||||
: describe-space ( space -- )
|
||||
solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
|
||||
solids>>
|
||||
[ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
|
||||
|
||||
: clip-solid ( solid solid -- solids )
|
||||
[ ]
|
||||
|
|
@ -451,7 +475,8 @@ TUPLE: space name dimension solids ambient-color lights ;
|
|||
; inline
|
||||
|
||||
: remove-hidden-solids ( space -- space )
|
||||
! We must include each solid in a sequence because during substration
|
||||
! We must include each solid in a sequence because
|
||||
! during substration
|
||||
! a solid can be divided in more than on solid
|
||||
[
|
||||
[ [ 1array ] map ]
|
||||
|
|
@ -489,9 +514,9 @@ TUPLE: space name dimension solids ambient-color lights ;
|
|||
[ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
|
||||
;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
! -------------------------------------------------------------
|
||||
|
||||
: face-reference ( face -- halfspace point vect )
|
||||
[ halfspace>> ]
|
||||
|
|
@ -523,8 +548,10 @@ TUPLE: space name dimension solids ambient-color lights ;
|
|||
|
||||
: face->GL ( face color -- )
|
||||
[ ordered-face-points ] dip
|
||||
[ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry
|
||||
[ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]
|
||||
[ first3 1.0 glColor4d GL_POLYGON
|
||||
[ [ point->GL ] each ] do-state ] curry
|
||||
[ 0 0 0 1 glColor4d GL_LINE_LOOP
|
||||
[ [ point->GL ] each ] do-state ]
|
||||
bi
|
||||
; inline
|
||||
|
||||
|
|
@ -5,7 +5,7 @@ IN: adsoda.combinators
|
|||
|
||||
HELP: among
|
||||
{ $values
|
||||
{ "array" array } { "n" null }
|
||||
{ "array" array } { "n" "number of value to select" }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
|
||||
|
|
@ -32,7 +32,7 @@ HELP: do-cycle
|
|||
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
|
||||
|
||||
|
||||
ARTICLE: "adsoda.combinators" "adsoda.combinators"
|
||||
ARTICLE: "adsoda.combinators" "Combinators"
|
||||
{ $vocab-link "adsoda.combinators" }
|
||||
;
|
||||
|
||||
|
|
@ -4,7 +4,7 @@ USING: kernel arrays sequences fry math combinators ;
|
|||
|
||||
IN: adsoda.combinators
|
||||
|
||||
! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
|
||||
! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
|
||||
|
||||
! : prefix-each [ prefix ] curry map ; inline
|
||||
|
||||
|
|
@ -34,7 +34,8 @@ IN: adsoda.combinators
|
|||
} cond
|
||||
;
|
||||
|
||||
: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;
|
||||
: concat-nth ( seq1 seq2 -- seq )
|
||||
[ nth append ] curry map-index ;
|
||||
|
||||
: do-cycle ( array -- array ) dup first suffix ;
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ HELP: 3cube
|
|||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax"
|
||||
"\n returns a 3D solid with given limits"
|
||||
"returns a 3D solid with given limits"
|
||||
} ;
|
||||
|
||||
HELP: 4cube
|
||||
|
|
@ -18,24 +18,10 @@ HELP: 4cube
|
|||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
|
||||
"\n returns a 4D solid with given limits"
|
||||
"returns a 4D solid with given limits"
|
||||
} ;
|
||||
|
||||
|
||||
HELP: coord-max
|
||||
{ $values
|
||||
{ "x" null } { "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: coord-min
|
||||
{ $values
|
||||
{ "x" null } { "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: equation-system-for-normal
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
|
|
@ -51,8 +37,8 @@ HELP: normal-vector
|
|||
{ "v" "a vector" }
|
||||
}
|
||||
{ $description "From a list of points, returns the vector normal to the plan defined by the points"
|
||||
"\nWith n points, creates n-1 vectors and then find a vector orthogonal to every others"
|
||||
"\n returns { f } if a normal vector can not be found" }
|
||||
"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
|
||||
"returns { f } if a normal vector can not be found" }
|
||||
;
|
||||
|
||||
HELP: points-to-hyperplane
|
||||
|
|
@ -61,14 +47,14 @@ HELP: points-to-hyperplane
|
|||
{ "hyperplane" "an hyperplane equation" }
|
||||
}
|
||||
{ $description "From a list of points, returns the equation of the hyperplan"
|
||||
"\n Finds a normal vector and then translate it so that it includes one of the points"
|
||||
"Finds a normal vector and then translate it so that it includes one of the points"
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "adsoda.tools" "adsoda.tools"
|
||||
ARTICLE: "adsoda.tools" "Tools"
|
||||
{ $vocab-link "adsoda.tools" }
|
||||
"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
|
||||
"Tools to help in building an " { $vocab-link "adsoda" } "-space"
|
||||
;
|
||||
|
||||
ABOUT: "adsoda.tools"
|
||||
|
|
@ -79,7 +79,8 @@ IN: adsoda.tools
|
|||
translate ;
|
||||
|
||||
: refs-to-points ( points faces -- faces )
|
||||
[ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map
|
||||
[ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ]
|
||||
with map
|
||||
;
|
||||
! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }
|
||||
! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }
|
||||
|
|
@ -102,13 +103,15 @@ refs-to-points
|
|||
;
|
||||
: 2-faces-to-prism ( seq seq -- seq )
|
||||
2dup
|
||||
[ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires
|
||||
[ do-cycle 2 clump ] bi@ concat-nth
|
||||
! 3 faces rectangulaires
|
||||
swap prefix
|
||||
swap prefix
|
||||
;
|
||||
|
||||
: Xpoints-to-prisme ( seq height -- cube )
|
||||
! from 3 points gives a list of faces representing a cube of height "height"
|
||||
! from 3 points gives a list of faces representing
|
||||
! a cube of height "height"
|
||||
! and of based on the three points
|
||||
! a face is a group of 3 or mode points.
|
||||
[ dup dup 3points-to-normal ] dip
|
||||
|
|
@ -121,7 +124,8 @@ refs-to-points
|
|||
|
||||
|
||||
: Xpoints-to-plane4D ( seq x y -- 4Dplane )
|
||||
! from 3 points gives a list of faces representing a cube in 4th dim
|
||||
! from 3 points gives a list of faces representing
|
||||
! a cube in 4th dim
|
||||
! from x to y (height = y-x)
|
||||
! and of based on the X points
|
||||
! a face is a group of 3 or mode points.
|
||||
|
|
@ -130,7 +134,8 @@ refs-to-points
|
|||
;
|
||||
|
||||
: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )
|
||||
[ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map
|
||||
[ 1 Xpoints-to-prisme [ 100
|
||||
110 Xpoints-to-plane4D ] map concat ] map
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2009 Eduardo Cavazos
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax multiline ;
|
||||
IN: ui.gadgets.slate
|
||||
|
||||
ARTICLE: "ui.gadgets.slate" "Slate gadget"
|
||||
{ $description "A gadget with an 'action' slot which should be set to a callable."}
|
||||
{ $heading "Example" }
|
||||
{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
|
||||
[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
|
||||
gadget."> } ;
|
||||
|
||||
ABOUT: "ui.gadgets.slate"
|
||||
|
|
@ -1,32 +1,11 @@
|
|||
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets accessors
|
||||
help.syntax
|
||||
easy-help ;
|
||||
! Copyright (C) 2009 Eduardo Cavazos
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
|
||||
|
||||
IN: ui.gadgets.slate
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "slate" "Slate Gadget"
|
||||
|
||||
Summary:
|
||||
|
||||
A gadget with an 'action' slot which should be set to a callable. ..
|
||||
|
||||
Example:
|
||||
|
||||
! Load the right vocabs for the examples
|
||||
|
||||
USING: processing.shapes ui.gadgets.slate ; ..
|
||||
|
||||
Example:
|
||||
|
||||
[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
|
||||
gadget. ..
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "slate"
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,400 +0,0 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations strings ;
|
||||
IN: 4DNav
|
||||
|
||||
HELP: (mvt-4D)
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxy
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Ryw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Ryz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rzw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4DNav
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >observer3d
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >present-space
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
|
||||
HELP: >view1
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view2
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view3
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view4
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: add-keyboard-delegate
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "obj" object }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: button*
|
||||
{ $values
|
||||
{ "string" string } { "quot" quotation }
|
||||
{ "button" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: camera-action
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: camera-button
|
||||
{ $values
|
||||
{ "string" string } { "quot" quotation }
|
||||
{ "button" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: controller-window*
|
||||
{ $values
|
||||
{ "gadget" "a gadget" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
|
||||
HELP: init-models
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: init-variables
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: menu-3D
|
||||
{ $values
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "The menu dedicated to 3D movements of the camera" } ;
|
||||
|
||||
HELP: menu-4D
|
||||
{ $values
|
||||
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "The menu dedicated to 4D movements of space" } ;
|
||||
|
||||
HELP: menu-bar
|
||||
{ $values
|
||||
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "return gadget containing menu buttons" } ;
|
||||
|
||||
HELP: model-projection
|
||||
{ $values
|
||||
{ "x" null }
|
||||
{ "space" null }
|
||||
}
|
||||
{ $description "Project space following coordinate x" } ;
|
||||
|
||||
HELP: mvt-3D-1
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: mvt-3D-2
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from second point of view" } ;
|
||||
|
||||
HELP: mvt-3D-3
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from third point of view" } ;
|
||||
|
||||
HELP: mvt-3D-4
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: observer3d
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: observer3d>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: present-space
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: present-space>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: load-model-file
|
||||
{ $description "load space from file" } ;
|
||||
|
||||
HELP: rotation-4D
|
||||
{ $values
|
||||
{ "m" "a rotation matrix" }
|
||||
}
|
||||
{ $description "Apply a 4D rotation matrix" } ;
|
||||
|
||||
HELP: translation-4D
|
||||
{ $values
|
||||
{ "v" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: update-model-projections
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: update-observer-projections
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view1
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view1>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view2
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view2>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view3
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view3>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view4
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view4>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: viewer-windows*
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: win3D
|
||||
{ $values
|
||||
{ "text" null } { "gadget" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: windows
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "Space file" "Create a new space file"
|
||||
"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:"
|
||||
$nl
|
||||
|
||||
"\n<model>"
|
||||
"\n<space>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <solid>"
|
||||
"\n <name>4cube1</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,100</face>"
|
||||
"\n <face>-1,0,0,0,-150</face>"
|
||||
"\n <face>0,1,0,0,100</face>"
|
||||
"\n <face>0,-1,0,0,-150</face>"
|
||||
"\n <face>0,0,1,0,100</face>"
|
||||
"\n <face>0,0,-1,0,-150</face>"
|
||||
"\n <face>0,0,0,1,100</face>"
|
||||
"\n <face>0,0,0,-1,-150</face>"
|
||||
"\n <color>1,0,0</color>"
|
||||
"\n </solid>"
|
||||
"\n <solid>"
|
||||
"\n <name>4triancube</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,160</face>"
|
||||
"\n <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>"
|
||||
"\n <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>"
|
||||
"\n <face>0,0,1,0,140</face>"
|
||||
"\n <face>0,0,-1,0,-180</face>"
|
||||
"\n <face>0,0,0,1,110</face>"
|
||||
"\n <face>0,0,0,-1,-180</face>"
|
||||
"\n <color>0,1,0</color>"
|
||||
"\n </solid>"
|
||||
"\n <solid>"
|
||||
"\n <name>triangone</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,60</face>"
|
||||
"\n <face>0.5,0.8660254037844386,0,0,60</face>"
|
||||
"\n <face>-0.5,0.8660254037844387,0,0,-20</face>"
|
||||
"\n <face>-1.0,0,0,0,-100</face>"
|
||||
"\n <face>-0.5,-0.8660254037844384,0,0,-100</face>"
|
||||
"\n <face>0.5,-0.8660254037844387,0,0,-20</face>"
|
||||
"\n <face>0,0,1,0,120</face>"
|
||||
"\n <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>"
|
||||
"\n <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>"
|
||||
"\n <color>0,1,1</color>"
|
||||
"\n </solid>"
|
||||
"\n <light>"
|
||||
"\n <direction>1,1,1,1</direction>"
|
||||
"\n <color>0.2,0.2,0.6</color>"
|
||||
"\n </light>"
|
||||
"\n <color>0.8,0.9,0.9</color>"
|
||||
"\n</space>"
|
||||
"\n</model>"
|
||||
|
||||
|
||||
;
|
||||
|
||||
ARTICLE: "TODO" "Todo"
|
||||
{ $list
|
||||
"A file chooser"
|
||||
"A vocab to initialize parameters"
|
||||
"an editor mode"
|
||||
{ $list "add a face to a solid"
|
||||
"add a solid to the space"
|
||||
"move a face"
|
||||
"move a solid"
|
||||
"select a solid in a list"
|
||||
"select a face"
|
||||
"display selected face"
|
||||
"edit a solid color"
|
||||
"add a light"
|
||||
"edit a light color"
|
||||
"move a light"
|
||||
}
|
||||
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
|
||||
"decorrelate 3D camera and activate them with select buttons"
|
||||
|
||||
|
||||
|
||||
} ;
|
||||
|
||||
|
||||
ARTICLE: "4DNav" "4DNav"
|
||||
{ $vocab-link "4DNav" }
|
||||
$nl
|
||||
{ $heading "4D Navigator" }
|
||||
"4DNav is a simple tool to visualize 4 dimensionnal objects."
|
||||
"\n"
|
||||
"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
|
||||
|
||||
"It will display:"
|
||||
{ $list
|
||||
{ "a menu window" }
|
||||
{ "4 visualization windows" }
|
||||
}
|
||||
"Each window represents the projection of the 4D space on a particular 3D space."
|
||||
$nl
|
||||
|
||||
{ $heading "Initialization" }
|
||||
"put the space file " { $strong "space-exemple.xml" } " in temp directory"
|
||||
" and then type:" { $code "\"4DNav\" run" }
|
||||
{ $heading "Navigation" }
|
||||
"4D submenu move the space in translations and rotation."
|
||||
"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one"
|
||||
$nl
|
||||
|
||||
|
||||
|
||||
|
||||
{ $heading "Links" }
|
||||
{ $subsection "Space file" }
|
||||
|
||||
{ $subsection "TODO" }
|
||||
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "4DNav"
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
USING: kernel namespaces math.vectors opengl 4DNav.turtle self ;
|
||||
|
||||
IN: 4DNav.camera
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: camera-eye ( -- point ) turtle-pos> ;
|
||||
|
||||
: camera-focus ( -- point ) [ 1 step-turtle turtle-pos> ] save-self ;
|
||||
|
||||
: camera-up ( -- dirvec )
|
||||
[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ] save-self ;
|
||||
|
||||
: do-look-at ( camera -- )
|
||||
[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;
|
||||
IN: 4DNav.deep
|
||||
|
||||
! USING: bake ;
|
||||
! MACRO: deep-cleave-quots ( seq -- quot )
|
||||
! [ [ quotation? ] deep-filter ]
|
||||
! [ [ dup quotation? [ drop , ] when ] deep-map ]
|
||||
! bi '[ _ cleave _ bake ] ;
|
||||
|
||||
: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
|
||||
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: adsoda xml xml.utilities xml.dispatch accessors combinators
|
||||
sequences math.parser kernel splitting values continuations ;
|
||||
IN: 4DNav.space-file-decoder
|
||||
|
||||
: decode-number-array ( x -- y ) "," split [ string>number ] map ;
|
||||
|
||||
PROCESS: adsoda-read-model ( tag -- )
|
||||
|
||||
TAG: dimension adsoda-read-model children>> first string>number ;
|
||||
TAG: direction adsoda-read-model children>> first decode-number-array ;
|
||||
TAG: color adsoda-read-model children>> first decode-number-array ;
|
||||
TAG: name adsoda-read-model children>> first ;
|
||||
TAG: face adsoda-read-model children>> first decode-number-array ;
|
||||
|
||||
TAG: solid adsoda-read-model
|
||||
<solid> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
[ "face" tags-named [ adsoda-read-model cut-solid ] each ]
|
||||
} cleave
|
||||
ensure-adjacencies
|
||||
;
|
||||
|
||||
TAG: light adsoda-read-model
|
||||
<light> swap
|
||||
{
|
||||
[ "direction" tag-named adsoda-read-model >>direction ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
TAG: space adsoda-read-model
|
||||
<space> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named adsoda-read-model >>ambient-color ]
|
||||
[ "solid" tags-named [ adsoda-read-model suffix-solids ] each ]
|
||||
[ "light" tags-named [ adsoda-read-model suffix-lights ] each ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
: read-model-file ( path -- x )
|
||||
dup
|
||||
[
|
||||
[ file>xml "space" tags-named first adsoda-read-model ]
|
||||
[ drop <space> ] recover
|
||||
] [ drop <space> ] if
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -1,229 +0,0 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
HELP: <turtle>
|
||||
{ $values
|
||||
|
||||
{ "turtle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >turtle-ori
|
||||
{ $values
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >turtle-pos
|
||||
{ $values
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Rx
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Ry
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Rz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: V
|
||||
{ $values
|
||||
|
||||
{ "V" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: X
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Y
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Z
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: apply-rotation
|
||||
{ $values
|
||||
{ "rotation" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: distance
|
||||
{ $values
|
||||
{ "turtle" null } { "turtle" null }
|
||||
{ "n" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: move-by
|
||||
{ $values
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: pitch-down
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: pitch-up
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: reset-turtle
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-left
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-right
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-until-horizontal
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-x
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-y
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-z
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-X
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-Y
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-Z
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: step-turtle
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: step-vector
|
||||
{ $values
|
||||
{ "length" null }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-down
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-left
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-right
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-up
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turn-left
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turn-right
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle-ori>
|
||||
{ $values
|
||||
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle-pos>
|
||||
{ $values
|
||||
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.turtle" "4DNav.turtle"
|
||||
{ $vocab-link "4DNav.turtle" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.turtle"
|
||||
Loading…
Reference in New Issue