Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
1b98b7d1c8
|
|
@ -9,7 +9,7 @@ TUPLE: column seq col ;
|
|||
C: <column> column
|
||||
|
||||
M: column virtual-seq seq>> ;
|
||||
M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
|
||||
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
|
||||
M: column length seq>> length ;
|
||||
|
||||
INSTANCE: column virtual-sequence
|
||||
|
|
|
|||
|
|
@ -60,8 +60,8 @@ GENERIC: add-atom ( a disjoint-set -- )
|
|||
|
||||
M: disjoint-set add-atom
|
||||
[ dupd parents>> set-at ]
|
||||
[ 0 -rot ranks>> set-at ]
|
||||
[ 1 -rot counts>> set-at ]
|
||||
[ [ 0 ] 2dip ranks>> set-at ]
|
||||
[ [ 1 ] 2dip counts>> set-at ]
|
||||
2tri ;
|
||||
|
||||
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
|
||||
|
|
|
|||
|
|
@ -153,18 +153,18 @@ GENERIC: next-elt ( loc document elt -- newloc )
|
|||
TUPLE: char-elt ;
|
||||
|
||||
: (prev-char) ( loc document quot -- loc )
|
||||
-rot {
|
||||
{ [ over { 0 0 } = ] [ drop ] }
|
||||
{ [ over second zero? ] [ [ first 1- ] dip line-end ] }
|
||||
[ pick call ]
|
||||
} cond nip ; inline
|
||||
{
|
||||
{ [ pick { 0 0 } = ] [ 2drop ] }
|
||||
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
: (next-char) ( loc document quot -- loc )
|
||||
-rot {
|
||||
{ [ 2dup doc-end = ] [ drop ] }
|
||||
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
|
||||
[ pick call ]
|
||||
} cond nip ; inline
|
||||
{
|
||||
{ [ 2over doc-end = ] [ 2drop ] }
|
||||
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
|
||||
[ call ]
|
||||
} cond ; inline
|
||||
|
||||
M: char-elt prev-elt
|
||||
drop [ drop -1 +col ] (prev-char) ;
|
||||
|
|
|
|||
|
|
@ -85,13 +85,13 @@ IN: formatting.tests
|
|||
|
||||
[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
|
||||
[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
|
||||
[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "10/09/08" testtime "%m/%d/%y" strftime = ] unit-test
|
||||
[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
|
||||
[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
|
||||
[ t ] [ "October" testtime "%B" strftime = ] unit-test
|
||||
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
|
||||
[ t ] [ "PM" testtime "%p" strftime = ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays ascii calendar combinators fry kernel
|
||||
io io.encodings.ascii io.files io.streams.string
|
||||
generalizations io io.encodings.ascii io.files io.streams.string
|
||||
macros math math.functions math.parser peg.ebnf quotations
|
||||
sequences splitting strings unicode.case vectors ;
|
||||
|
||||
|
|
@ -32,10 +32,7 @@ IN: formatting
|
|||
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
|
||||
|
||||
: max-digits ( n digits -- n' )
|
||||
10 swap ^ [ * round ] keep / ;
|
||||
|
||||
: max-width ( string length -- string' )
|
||||
short head ;
|
||||
10 swap ^ [ * round ] keep / ; inline
|
||||
|
||||
: >exp ( x -- exp base )
|
||||
[
|
||||
|
|
@ -69,7 +66,7 @@ pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 =
|
|||
|
||||
sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
|
||||
|
||||
width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
|
||||
width_ = "." ([0-9])* => [[ second >digits '[ _ short head ] ]]
|
||||
width = (width_)? => [[ [ ] or ]]
|
||||
|
||||
digits_ = "." ([0-9])* => [[ second >digits ]]
|
||||
|
|
@ -113,23 +110,25 @@ MACRO: printf ( format-string -- )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: zero-pad ( str -- str' ) 2 CHAR: 0 pad-left ; inline
|
||||
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
|
||||
|
||||
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
|
||||
|
||||
: >time ( timestamp -- string )
|
||||
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
|
||||
[ number>string zero-pad ] map ":" join ; inline
|
||||
[ pad-00 ] map ":" join ; inline
|
||||
|
||||
: >date ( timestamp -- string )
|
||||
[ month>> ] [ day>> ] [ year>> ] tri 3array
|
||||
[ number>string zero-pad ] map "/" join ; inline
|
||||
[ pad-00 ] map "/" join ; inline
|
||||
|
||||
: >datetime ( timestamp -- string )
|
||||
{ [ day-of-week day-abbreviation3 ]
|
||||
[ month>> month-abbreviation ]
|
||||
[ day>> number>string zero-pad ]
|
||||
[ day>> pad-00 ]
|
||||
[ >time ]
|
||||
[ year>> number>string ]
|
||||
} cleave 3array [ 2array ] dip append " " join ; inline
|
||||
} cleave 5 narray " " join ; inline
|
||||
|
||||
: (week-of-year) ( timestamp day -- n )
|
||||
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
|
||||
|
|
@ -147,20 +146,20 @@ fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
|
|||
fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
|
||||
fmt-B = "B" => [[ [ dup month>> month-name ] ]]
|
||||
fmt-c = "c" => [[ [ dup >datetime ] ]]
|
||||
fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
|
||||
fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
|
||||
fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
|
||||
fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
|
||||
fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
|
||||
fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
|
||||
fmt-d = "d" => [[ [ dup day>> pad-00 ] ]]
|
||||
fmt-H = "H" => [[ [ dup hour>> pad-00 ] ]]
|
||||
fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]]
|
||||
fmt-j = "j" => [[ [ dup day-of-year pad-000 ] ]]
|
||||
fmt-m = "m" => [[ [ dup month>> pad-00 ] ]]
|
||||
fmt-M = "M" => [[ [ dup minute>> pad-00 ] ]]
|
||||
fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
|
||||
fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
|
||||
fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
|
||||
fmt-S = "S" => [[ [ dup second>> floor pad-00 ] ]]
|
||||
fmt-U = "U" => [[ [ dup week-of-year-sunday pad-00 ] ]]
|
||||
fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
|
||||
fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
|
||||
fmt-W = "W" => [[ [ dup week-of-year-monday pad-00 ] ]]
|
||||
fmt-x = "x" => [[ [ dup >date ] ]]
|
||||
fmt-X = "X" => [[ [ dup >time ] ]]
|
||||
fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
|
||||
fmt-y = "y" => [[ [ dup year>> 100 mod pad-00 ] ]]
|
||||
fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
|
||||
fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
|
||||
unknown = (.)* => [[ "Unknown directive" throw ]]
|
||||
|
|
|
|||
|
|
@ -100,14 +100,12 @@ $nl
|
|||
{ $code "10 [ \"Factor rocks!\" print ] times" }
|
||||
"Now we can look at a new data type, the array:"
|
||||
{ $code "{ 1 2 3 }" }
|
||||
"An array looks like a quotation except it cannot be evaluated; it simply stores data."
|
||||
"An array differs from a quotation in that it cannot be evaluated; it simply stores data."
|
||||
$nl
|
||||
"You can perform an operation on each element of an array:"
|
||||
{ $example
|
||||
"{ 1 2 3 } [ \"The number is \" write . ] each"
|
||||
"The number is 1"
|
||||
"The number is 2"
|
||||
"The number is 3"
|
||||
"The number is 1\nThe number is 2\nThe number is 3"
|
||||
}
|
||||
"You can transform each element, collecting the results in a new array:"
|
||||
{ $example "{ 5 12 0 -12 -5 } [ sq ] map ." "{ 25 144 0 144 25 }" }
|
||||
|
|
|
|||
|
|
@ -327,7 +327,7 @@ HELP: $table
|
|||
|
||||
HELP: $values
|
||||
{ $values { "element" "an array of pairs of markup elements" } }
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
|
||||
{ $see-also $maybe $instance $quotation } ;
|
||||
|
||||
HELP: $instance
|
||||
|
|
|
|||
|
|
@ -3,3 +3,4 @@ USING: tools.test help kernel ;
|
|||
|
||||
[ 3 throw ] must-fail
|
||||
[ ] [ :help ] unit-test
|
||||
[ ] [ f print-topic ] unit-test
|
||||
|
|
@ -112,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
] with-style nl ;
|
||||
|
||||
: print-topic ( topic -- )
|
||||
>link
|
||||
last-element off dup $title
|
||||
article-content print-content nl ;
|
||||
|
||||
|
|
|
|||
|
|
@ -58,6 +58,8 @@ IN: http.server.cgi
|
|||
] with-stream
|
||||
] >>body ;
|
||||
|
||||
SLOT: special
|
||||
|
||||
: enable-cgi ( responder -- responder )
|
||||
[ serve-cgi ] "application/x-cgi-script"
|
||||
pick special>> set-at ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays generic hashtables io kernel assocs math
|
||||
namespaces prettyprint sequences strings io.styles vectors words
|
||||
quotations mirrors splitting math.parser classes vocabs refs
|
||||
sets sorting summary debugger continuations ;
|
||||
sets sorting summary debugger continuations fry ;
|
||||
IN: inspector
|
||||
|
||||
: value-editor ( path -- )
|
||||
|
|
@ -53,7 +53,7 @@ SYMBOL: +editable+
|
|||
[ drop ] [
|
||||
dup enum? [ +sequence+ on ] when
|
||||
standard-table-style [
|
||||
swap [ -rot describe-row ] curry each-index
|
||||
swap '[ [ _ ] 2dip describe-row ] each-index
|
||||
] tabular-output
|
||||
] if-empty ;
|
||||
|
||||
|
|
@ -64,7 +64,7 @@ M: tuple error. describe ;
|
|||
|
||||
: namestack. ( seq -- )
|
||||
[ [ global eq? not ] filter [ keys ] gather ] keep
|
||||
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||
'[ dup _ assoc-stack ] H{ } map>assoc describe ;
|
||||
|
||||
: .vars ( -- )
|
||||
namestack namestack. ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: io.files io.files.temp io.directories io.sockets io kernel threads
|
||||
namespaces tools.test continuations strings byte-arrays
|
||||
sequences prettyprint system io.encodings.binary io.encodings.ascii
|
||||
io.streams.duplex destructors make ;
|
||||
io.streams.duplex destructors make io.launcher ;
|
||||
IN: io.backend.unix.tests
|
||||
|
||||
! Unix domain stream sockets
|
||||
|
|
@ -138,3 +138,13 @@ datagram-client delete-file
|
|||
input-stream get send
|
||||
] with-file-reader
|
||||
] must-fail
|
||||
|
||||
! closing stdin caused some problems
|
||||
[ ] [
|
||||
[
|
||||
vm ,
|
||||
"-i=" image append ,
|
||||
"-run=none" ,
|
||||
"-e=USING: destructors namespaces io calendar threads ; input-stream get dispose 1 seconds sleep" ,
|
||||
] { } make try-process
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: io.directories io.files.links tools.test
|
||||
io.files.unique tools.files fry ;
|
||||
IN: io.files.links.tests
|
||||
USING: io.directories io.files.links tools.test sequences
|
||||
io.files.unique tools.files fry math kernel math.parser
|
||||
io.pathnames namespaces ;
|
||||
IN: io.files.links.unix.tests
|
||||
|
||||
: make-test-links ( n path -- )
|
||||
[ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
|
||||
|
|
@ -61,7 +61,7 @@ PRIVATE>
|
|||
[ dup ] 2dip 2curry annotate ;
|
||||
|
||||
: call-logging-quot ( quot word level -- quot' )
|
||||
"called" -rot [ log-message ] 3curry prepose ;
|
||||
[ "called" ] 2dip [ log-message ] 3curry prepose ;
|
||||
|
||||
: add-logging ( word level -- )
|
||||
[ call-logging-quot ] (define-logging) ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ HELP: parse-log
|
|||
} ;
|
||||
|
||||
ARTICLE: "logging.parser" "Log file parser"
|
||||
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs."
|
||||
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $vocab-link "logging.insomniac" } " to analyze logs."
|
||||
$nl
|
||||
"There is only one primary entry point:"
|
||||
{ $subsection parse-log } ;
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ SYMBOL: log-files
|
|||
|
||||
: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
|
||||
|
||||
: (write-message) ( msg name>> level multi? -- )
|
||||
: (write-message) ( msg word-name level multi? -- )
|
||||
[
|
||||
"[" write multiline-header write "] " write
|
||||
] [
|
||||
|
|
@ -36,18 +36,19 @@ SYMBOL: log-files
|
|||
] if
|
||||
write bl write ": " write print ;
|
||||
|
||||
: write-message ( msg name>> level -- )
|
||||
rot harvest {
|
||||
{ [ dup empty? ] [ 3drop ] }
|
||||
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
|
||||
: write-message ( msg word-name level -- )
|
||||
[ harvest ] 2dip {
|
||||
{ [ pick empty? ] [ 3drop ] }
|
||||
{ [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] }
|
||||
[
|
||||
[ first -rot f (write-message) ] 3keep
|
||||
rest -rot [ t (write-message) ] 2curry each
|
||||
[ [ first ] 2dip f (write-message) ]
|
||||
[ [ rest ] 2dip [ t (write-message) ] 2curry each ]
|
||||
3bi
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: (log-message) ( msg -- )
|
||||
#! msg: { msg name>> level service }
|
||||
#! msg: { msg word-name level service }
|
||||
first4 log-stream [ write-message flush ] with-output-stream* ;
|
||||
|
||||
: try-dispose ( stream -- )
|
||||
|
|
|
|||
|
|
@ -50,11 +50,11 @@ M: ratio <= scale <= ;
|
|||
M: ratio > scale > ;
|
||||
M: ratio >= scale >= ;
|
||||
|
||||
M: ratio + 2dup scale + -rot ratio+d / ;
|
||||
M: ratio - 2dup scale - -rot ratio+d / ;
|
||||
M: ratio * 2>fraction * [ * ] dip / ;
|
||||
M: ratio + [ scale + ] [ ratio+d ] 2bi / ;
|
||||
M: ratio - [ scale - ] [ ratio+d ] 2bi / ;
|
||||
M: ratio * 2>fraction [ * ] 2bi@ / ;
|
||||
M: ratio / scale / ;
|
||||
M: ratio /i scale /i ;
|
||||
M: ratio /f scale /f ;
|
||||
M: ratio mod [ /i ] 2keep rot * - ;
|
||||
M: ratio mod 2dup /i * - ;
|
||||
M: ratio /mod [ /i ] 2keep mod ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: mirror set-at ( val key mirror -- )
|
|||
swap set-slot ;
|
||||
|
||||
M: mirror delete-at ( key mirror -- )
|
||||
f -rot set-at ;
|
||||
[ f ] 2dip set-at ;
|
||||
|
||||
M: mirror clear-assoc ( mirror -- )
|
||||
[ object>> ] [ object-slots ] bi [
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays generic kernel math models namespaces sequences assocs
|
||||
tools.test models.compose accessors ;
|
||||
tools.test models.compose accessors locals ;
|
||||
IN: models.compose.tests
|
||||
|
||||
! Test compose
|
||||
|
|
@ -22,3 +22,25 @@ IN: models.compose.tests
|
|||
[ { 4 5 } ] [ "c" get value>> ] unit-test
|
||||
|
||||
[ ] [ "c" get deactivate-model ] unit-test
|
||||
|
||||
TUPLE: an-observer { i integer } ;
|
||||
|
||||
M: an-observer model-changed nip [ 1+ ] change-i drop ;
|
||||
|
||||
[ 1 0 ] [
|
||||
[let* | m1 [ 1 <model> ]
|
||||
m2 [ 2 <model> ]
|
||||
c [ { m1 m2 } <compose> ]
|
||||
o1 [ an-observer new ]
|
||||
o2 [ an-observer new ] |
|
||||
|
||||
o1 m1 add-connection
|
||||
o2 m2 add-connection
|
||||
|
||||
c activate-model
|
||||
|
||||
"OH HAI" m1 set-model
|
||||
o1 i>>
|
||||
o2 i>>
|
||||
]
|
||||
] unit-test
|
||||
|
|
@ -18,7 +18,8 @@ TUPLE: compose < model ;
|
|||
|
||||
M: compose model-changed
|
||||
nip
|
||||
[ [ value>> ] composed-value ] keep set-model ;
|
||||
dup [ value>> ] composed-value >>value
|
||||
notify-connections ;
|
||||
|
||||
M: compose model-activated dup model-changed ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,11 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces make sequences splitting opengl.gl
|
||||
continuations math.parser math arrays sets math.order ;
|
||||
continuations math.parser math arrays sets math.order fry ;
|
||||
IN: opengl.capabilities
|
||||
|
||||
: (require-gl) ( thing require-quot make-error-quot -- )
|
||||
-rot dupd call
|
||||
[ 2drop ]
|
||||
[ swap " " make throw ]
|
||||
if ; inline
|
||||
[ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
|
||||
|
||||
: gl-extensions ( -- seq )
|
||||
GL_EXTENSIONS glGetString " " split ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ USING: alien alien.c-types continuations kernel libc math macros
|
|||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays assocs colors accessors
|
||||
generalizations locals specialized-arrays.float
|
||||
generalizations locals fry specialized-arrays.float
|
||||
specialized-arrays.uint ;
|
||||
IN: opengl
|
||||
|
||||
|
|
@ -154,19 +154,21 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: delete-gl-buffer ( id -- )
|
||||
[ glDeleteBuffers ] (delete-gl-object) ;
|
||||
|
||||
: with-gl-buffer ( binding id quot -- )
|
||||
-rot dupd glBindBuffer
|
||||
[ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
|
||||
:: with-gl-buffer ( binding id quot -- )
|
||||
binding id glBindBuffer
|
||||
quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline
|
||||
|
||||
: with-array-element-buffers ( array-buffer element-buffer quot -- )
|
||||
-rot GL_ELEMENT_ARRAY_BUFFER swap [
|
||||
swap GL_ARRAY_BUFFER -rot with-gl-buffer
|
||||
[ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[
|
||||
GL_ARRAY_BUFFER swap _ with-gl-buffer
|
||||
] with-gl-buffer ; inline
|
||||
|
||||
: <gl-buffer> ( target data hint -- id )
|
||||
pick gen-gl-buffer [ [
|
||||
[ dup byte-length swap ] dip glBufferData
|
||||
] with-gl-buffer ] keep ;
|
||||
pick gen-gl-buffer [
|
||||
[
|
||||
[ [ byte-length ] keep ] dip glBufferData
|
||||
] with-gl-buffer
|
||||
] keep ;
|
||||
|
||||
: buffer-offset ( int -- alien )
|
||||
<alien> ; inline
|
||||
|
|
|
|||
|
|
@ -51,8 +51,7 @@ PRIVATE>
|
|||
dup zero? [
|
||||
2drop epsilon
|
||||
] [
|
||||
2dup exactly-n
|
||||
-rot 1- at-most-n 2choice
|
||||
[ exactly-n ] [ 1- at-most-n ] 2bi 2choice
|
||||
] if ;
|
||||
|
||||
: at-least-n ( parser n -- parser' )
|
||||
|
|
|
|||
|
|
@ -373,7 +373,7 @@ TUPLE: range-parser min max ;
|
|||
pick empty? [
|
||||
3drop f
|
||||
] [
|
||||
pick first -rot between? [
|
||||
[ dup first ] 2dip between? [
|
||||
unclip-slice <parse-result>
|
||||
] [
|
||||
drop f
|
||||
|
|
|
|||
|
|
@ -14,11 +14,11 @@ M: object branch? drop f ;
|
|||
|
||||
: deep-each ( obj quot: ( elt -- ) -- )
|
||||
[ call ] 2keep over branch?
|
||||
[ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
|
||||
[ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
|
||||
|
||||
: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
|
||||
[ call ] keep over branch?
|
||||
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
|
||||
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
|
||||
|
||||
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
|
||||
over [ pusher [ deep-each ] dip ] dip
|
||||
|
|
@ -27,7 +27,7 @@ M: object branch? drop f ;
|
|||
: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
|
||||
[ call ] 2keep rot [ drop t ] [
|
||||
over branch? [
|
||||
f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean
|
||||
[ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
|
||||
] [ 2drop f f ] if
|
||||
] if ; inline recursive
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ M: object branch? drop f ;
|
|||
: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
|
||||
|
||||
: deep-all? ( obj quot -- ? )
|
||||
[ not ] compose deep-contains? not ; inline
|
||||
'[ @ not ] deep-contains? not ; inline
|
||||
|
||||
: deep-member? ( obj seq -- ? )
|
||||
swap '[
|
||||
|
|
@ -50,7 +50,7 @@ M: object branch? drop f ;
|
|||
|
||||
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
|
||||
over branch? [
|
||||
[ [ call ] keep over [ deep-change-each ] dip ] curry change-each
|
||||
'[ _ [ call ] keep over [ deep-change-each ] dip ] change-each
|
||||
] [ 2drop ] if ; inline recursive
|
||||
|
||||
: flatten ( obj -- seq )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: struct-arrays.tests
|
||||
USING: struct-arrays tools.test kernel math sequences
|
||||
alien.syntax alien.c-types destructors libc accessors ;
|
||||
alien.syntax alien.c-types destructors libc accessors
|
||||
destructors ;
|
||||
|
||||
C-STRUCT: test-struct
|
||||
{ "int" "x" }
|
||||
|
|
@ -27,3 +28,12 @@ C-STRUCT: test-struct
|
|||
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
||||
[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
10 "test-struct" malloc-struct-array
|
||||
underlying>> &free drop
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
|
@ -32,9 +32,9 @@ ERROR: bad-byte-array-length byte-array ;
|
|||
] keep struct-array boa ; inline
|
||||
|
||||
: <direct-struct-array> ( alien length c-type -- struct-array )
|
||||
struct-array boa ; inline
|
||||
heap-size struct-array boa ; inline
|
||||
|
||||
: malloc-struct-array ( length c-type -- struct-array )
|
||||
heap-size [ calloc ] 2keep <direct-struct-array> ;
|
||||
[ heap-size calloc ] 2keep <direct-struct-array> ;
|
||||
|
||||
INSTANCE: struct-array sequence
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: tools.deploy.macosx
|
|||
vm parent-directory parent-directory ;
|
||||
|
||||
: copy-bundle-dir ( bundle-name dir -- )
|
||||
bundle-dir over append-path -rot
|
||||
[ bundle-dir prepend-path swap ] keep
|
||||
"Contents" prepend-path append-path copy-tree ;
|
||||
|
||||
: app-plist ( executable bundle-name -- assoc )
|
||||
|
|
|
|||
|
|
@ -2,14 +2,18 @@ USING: tools.profiler.private tools.time help.markup help.syntax
|
|||
quotations io strings words definitions ;
|
||||
IN: tools.profiler
|
||||
|
||||
ARTICLE: "profiling" "Profiling code"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words and methods which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
|
||||
ARTICLE: "profiler-limitations" "Profiler limitations"
|
||||
"Certain optimizations performed by the compiler can inhibit accurate call counting:"
|
||||
{ $list
|
||||
"The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
|
||||
{ "Calls to " { $link POSTPONE: inline } " words are not counted.." }
|
||||
"Calls to open-coded intrinsics are not counted. Certain words are open-coded as inline machine code, and in some cases optimized out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
|
||||
{ "Calls to " { $link POSTPONE: inline } " words are not counted." }
|
||||
{ "Calls to methods which were inlined as a result of type inference are not counted." }
|
||||
"Tail-recursive loops will only count the initial invocation of the word, not every tail call."
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "profiling" "Profiling code"
|
||||
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler."
|
||||
$nl
|
||||
"Quotations can be passed to a combinator which calls them with the profiler enabled:"
|
||||
{ $subsection profile }
|
||||
"After a quotation has been profiled, call counts can be presented in various ways:"
|
||||
|
|
@ -17,7 +21,9 @@ ARTICLE: "profiling" "Profiling code"
|
|||
{ $subsection vocab-profile. }
|
||||
{ $subsection usage-profile. }
|
||||
{ $subsection vocabs-profile. }
|
||||
{ $subsection method-profile. } ;
|
||||
{ $subsection method-profile. }
|
||||
{ $subsection "profiler-limitations" }
|
||||
{ $see-also "ui-profiler" } ;
|
||||
|
||||
ABOUT: "profiling"
|
||||
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@ TUPLE: border < gadget
|
|||
swap border new-border
|
||||
swap dup 2array >>size ;
|
||||
|
||||
: <filled-border> ( child gap -- border )
|
||||
<border> { 1 1 } >>fill ;
|
||||
|
||||
M: border pref-dim*
|
||||
[ size>> 2 v*n ] keep
|
||||
gadget-child pref-dim v+ ;
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@ M: editor ungraft*
|
|||
editor-font* "" string-height ;
|
||||
|
||||
: y>line ( y editor -- line# )
|
||||
line-height / >fixnum ;
|
||||
line-height /i ;
|
||||
|
||||
:: point>loc ( point editor -- loc )
|
||||
point second editor y>line {
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals accessors arrays ui.commands ui.gadgets
|
||||
USING: locals accessors arrays ui.commands ui.operations ui.gadgets
|
||||
ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
|
||||
hashtables kernel math models namespaces opengl sequences
|
||||
math.vectors ui.gadgets.theme ui.gadgets.packs
|
||||
|
|
@ -54,3 +54,9 @@ M: menu-glass layout* gadget-child prefer ;
|
|||
|
||||
: show-commands-menu ( target commands -- )
|
||||
[ dup [ ] ] dip <commands-menu> show-menu ;
|
||||
|
||||
: <operations-menu> ( target hook -- menu )
|
||||
over object-operations <commands-menu> ;
|
||||
|
||||
: show-operations-menu ( gadget target -- )
|
||||
[ ] <operations-menu> show-menu ;
|
||||
|
|
@ -35,8 +35,6 @@ HELP: <presentation>
|
|||
|
||||
{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
|
||||
|
||||
{ <commands-menu> <toolbar> operations-menu show-menu } related-words
|
||||
|
||||
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
|
||||
|
||||
HELP: show-mouse-help
|
||||
|
|
|
|||
|
|
@ -11,8 +11,8 @@ IN: ui.gadgets.presentations
|
|||
TUPLE: presentation < button object hook ;
|
||||
|
||||
: invoke-presentation ( presentation command -- )
|
||||
over dup hook>> call
|
||||
[ object>> ] dip invoke-command ;
|
||||
[ [ dup hook>> call ] [ object>> ] bi ] dip
|
||||
invoke-command ;
|
||||
|
||||
: invoke-primary ( presentation -- )
|
||||
dup object>> primary-operation
|
||||
|
|
@ -23,7 +23,7 @@ TUPLE: presentation < button object hook ;
|
|||
invoke-presentation ;
|
||||
|
||||
: show-mouse-help ( presentation -- )
|
||||
dup object>> over show-summary button-update ;
|
||||
[ [ object>> ] keep show-summary ] [ button-update ] bi ;
|
||||
|
||||
: <presentation> ( label object -- button )
|
||||
swap [ invoke-primary ] presentation new-button
|
||||
|
|
@ -35,18 +35,13 @@ M: presentation ungraft*
|
|||
dup hand-gadget get-global child? [ dup hide-status ] when
|
||||
call-next-method ;
|
||||
|
||||
: <operations-menu> ( presentation -- menu )
|
||||
[ object>> ]
|
||||
[ dup hook>> curry ]
|
||||
[ object>> object-operations ]
|
||||
tri <commands-menu> ;
|
||||
|
||||
: operations-menu ( presentation -- )
|
||||
dup <operations-menu> show-menu ;
|
||||
: show-operations-menu ( presentation -- )
|
||||
[ ] [ object>> ] [ dup hook>> curry ] tri
|
||||
<operations-menu> show-menu ;
|
||||
|
||||
presentation H{
|
||||
{ T{ button-down f f 3 } [ operations-menu ] }
|
||||
{ T{ mouse-leave } [ dup hide-status button-update ] }
|
||||
{ T{ button-down f f 3 } [ show-operations-menu ] }
|
||||
{ T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
|
||||
{ T{ mouse-enter } [ show-mouse-help ] }
|
||||
! Responding to motion too allows nested presentations to
|
||||
! display status help properly, when the mouse leaves a
|
||||
|
|
|
|||
|
|
@ -21,3 +21,20 @@ IN: ui.gadgets.tracks.tests
|
|||
<gadget> { 10 10 } >>dim 0 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 10 30 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 10 40 } ] [
|
||||
{ 0 1 } <track>
|
||||
{ 5 5 } >>gap
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
<gadget> { 10 10 } >>dim f track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
@ -27,10 +27,15 @@ TUPLE: track < pack sizes ;
|
|||
[ children>> ] [ sizes>> ] bi { 0 0 }
|
||||
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
|
||||
|
||||
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
|
||||
: gap-dim ( track -- dim )
|
||||
[ gap>> ] [ children>> length 1 [-] ] bi v*n ;
|
||||
|
||||
: available-dim ( track -- dim )
|
||||
[ dim>> ] [ alloted-dim ] bi v- ;
|
||||
|
||||
: track-layout ( track -- sizes )
|
||||
[ available-dim ] [ children>> ] [ normalized-sizes ] tri
|
||||
[ [ available-dim ] [ gap-dim ] bi v- ]
|
||||
[ children>> ] [ normalized-sizes ] tri
|
||||
[ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
|
||||
|
||||
M: track layout* ( track -- ) dup track-layout pack-layout ;
|
||||
|
|
@ -41,11 +46,9 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
|
|||
: track-pref-dims-2 ( track -- dim )
|
||||
[
|
||||
[ children>> pref-dims ] [ normalized-sizes ] bi
|
||||
[ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
|
||||
[ dup { 0 f } member? [ 2drop { 0 0 } ] [ v/n ] if ] 2map
|
||||
max-dim [ >fixnum ] map
|
||||
]
|
||||
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
|
||||
v+ ;
|
||||
] [ gap-dim ] bi v+ ;
|
||||
|
||||
M: track pref-dim* ( gadget -- dim )
|
||||
[ track-pref-dims-1 ]
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
|
|||
ui.tools.search ui.tools.workspace kernel models namespaces
|
||||
sequences tools.test ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
|
||||
ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
|
||||
IN: ui.tools.tests
|
||||
|
||||
[ f ]
|
||||
|
|
@ -40,7 +40,10 @@ IN: ui.tools.tests
|
|||
|
||||
[ t ] [ "p" get presentation? ] unit-test
|
||||
|
||||
[ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
|
||||
[ ] [
|
||||
"p" get [ object>> ] [ dup hook>> curry ] bi
|
||||
<operations-menu> gadget-child gadget-child "c" set
|
||||
] unit-test
|
||||
|
||||
[ ] [ notify-queued ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
Generates UUID's.
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
|
||||
USING: help.syntax help.markup kernel prettyprint sequences strings ;
|
||||
|
||||
IN: uuid
|
||||
|
||||
HELP: uuid1
|
||||
{ $values { "string" "a UUID string" } }
|
||||
{ $description
|
||||
"Generates a UUID (version 1) from the host ID, sequence number, "
|
||||
"and current time."
|
||||
} ;
|
||||
|
||||
HELP: uuid3
|
||||
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
|
||||
{ $description
|
||||
"Generates a UUID (version 3) from the MD5 hash of a namespace "
|
||||
"UUID and a name."
|
||||
} ;
|
||||
|
||||
HELP: uuid4
|
||||
{ $values { "string" "a UUID string" } }
|
||||
{ $description
|
||||
"Generates a UUID (version 4) from random bits."
|
||||
} ;
|
||||
|
||||
HELP: uuid5
|
||||
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
|
||||
{ $description
|
||||
"Generates a UUID (version 5) from the SHA-1 hash of a namespace "
|
||||
"UUID and a name."
|
||||
} ;
|
||||
|
||||
|
||||
ARTICLE: "uuid" "UUID (Universally Unique Identifier)"
|
||||
"The " { $vocab-link "uuid" } " vocabulary is used to generate UUIDs. "
|
||||
"The below words can be used to generate version 1, 3, 4, and 5 UUIDs as specified in RFC 4122."
|
||||
$nl
|
||||
"If all you want is a unique ID, you should probably call " { $link uuid1 } " or " { $link uuid4 } "."
|
||||
{ $subsection uuid1 }
|
||||
{ $subsection uuid3 }
|
||||
{ $subsection uuid4 }
|
||||
{ $subsection uuid5 }
|
||||
;
|
||||
|
||||
ABOUT: "uuid"
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: kernel uuid tools.test ;
|
||||
|
||||
IN: uuid.tests
|
||||
|
||||
[ t ] [ NAMESPACE_DNS [ uuid-parse uuid-unparse ] keep = ] unit-test
|
||||
[ t ] [ NAMESPACE_URL [ uuid-parse uuid-unparse ] keep = ] unit-test
|
||||
[ t ] [ NAMESPACE_OID [ uuid-parse uuid-unparse ] keep = ] unit-test
|
||||
[ t ] [ NAMESPACE_X500 [ uuid-parse uuid-unparse ] keep = ] unit-test
|
||||
|
||||
[ t ] [ NAMESPACE_URL "ABCD" uuid3
|
||||
"2e10e403-d7fa-3ffb-808f-ab834a46890e" = ] unit-test
|
||||
|
||||
[ t ] [ NAMESPACE_URL "ABCD" uuid5
|
||||
"0aa883d6-7953-57e7-a8f0-66db29ce5a91" = ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: byte-arrays checksums checksums.md5 checksums.sha1
|
||||
kernel math math.parser math.ranges random unicode.case
|
||||
sequences strings system io.binary ;
|
||||
|
||||
IN: uuid
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (timestamp) ( -- time_high time_mid time_low )
|
||||
! 0x01b21dd213814000L is the number of 100-ns intervals
|
||||
! between the UUID epoch 1582-10-15 00:00:00 and the
|
||||
! Unix epoch 1970-01-01 00:00:00.
|
||||
micros 10 * HEX: 01b21dd213814000 +
|
||||
[ -48 shift HEX: 0fff bitand ]
|
||||
[ -32 shift HEX: ffff bitand ]
|
||||
[ HEX: ffffffff bitand ]
|
||||
tri ;
|
||||
|
||||
: (hardware) ( -- address )
|
||||
! Choose a random 48-bit number with eighth bit
|
||||
! set to 1 (as recommended in RFC 4122)
|
||||
48 random-bits HEX: 010000000000 bitor ;
|
||||
|
||||
: (clock) ( -- clockseq )
|
||||
! Choose a random 14-bit number
|
||||
14 random-bits ;
|
||||
|
||||
: <uuid> ( address clockseq time_high time_mid time_low -- n )
|
||||
96 shift
|
||||
[ 80 shift ] dip bitor
|
||||
[ 64 shift ] dip bitor
|
||||
[ 48 shift ] dip bitor
|
||||
bitor ;
|
||||
|
||||
: (version) ( n version -- n' )
|
||||
[
|
||||
HEX: c000 48 shift bitnot bitand
|
||||
HEX: 8000 48 shift bitor
|
||||
HEX: f000 64 shift bitnot bitand
|
||||
] dip 76 shift bitor ;
|
||||
|
||||
: uuid>string ( n -- string )
|
||||
>hex 32 CHAR: 0 pad-left
|
||||
[ CHAR: - 20 ] dip insert-nth
|
||||
[ CHAR: - 16 ] dip insert-nth
|
||||
[ CHAR: - 12 ] dip insert-nth
|
||||
[ CHAR: - 8 ] dip insert-nth ;
|
||||
|
||||
: string>uuid ( string -- n )
|
||||
[ CHAR: - = not ] filter 16 base> ;
|
||||
|
||||
: uuid>byte-array ( n -- byte-array )
|
||||
16 >be ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: uuid-parse ( string -- byte-array )
|
||||
string>uuid uuid>byte-array ;
|
||||
|
||||
: uuid-unparse ( byte-array -- string )
|
||||
be> uuid>string ;
|
||||
|
||||
: uuid1 ( -- string )
|
||||
(hardware) (clock) (timestamp) <uuid>
|
||||
1 (version) uuid>string ;
|
||||
|
||||
: uuid3 ( namespace name -- string )
|
||||
[ uuid-parse ] dip append
|
||||
md5 checksum-bytes 16 short head be>
|
||||
3 (version) uuid>string ;
|
||||
|
||||
: uuid4 ( -- string )
|
||||
128 random-bits
|
||||
4 (version) uuid>string ;
|
||||
|
||||
: uuid5 ( namespace name -- string )
|
||||
[ uuid-parse ] dip append
|
||||
sha1 checksum-bytes 16 short head be>
|
||||
5 (version) uuid>string ;
|
||||
|
||||
CONSTANT: NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
|
||||
CONSTANT: NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
|
||||
CONSTANT: NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
|
||||
CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
|
||||
|
||||
|
||||
|
|
@ -61,3 +61,4 @@ SYMBOL: xml-file
|
|||
[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
|
||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
|
||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk second ] unit-test
|
||||
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ M: system-id write-xml-chunk
|
|||
M: public-id write-xml-chunk
|
||||
"PUBLIC '" write
|
||||
[ pubid-literal>> write "' '" write ]
|
||||
[ system-literal>> write "'>" write ] bi ;
|
||||
[ system-literal>> write "'" write ] bi ;
|
||||
|
||||
M: doctype-decl write-xml-chunk
|
||||
"<!DOCTYPE " write
|
||||
|
|
|
|||
|
|
@ -3,18 +3,20 @@ USING: help.markup help.syntax vocabs.loader words io
|
|||
quotations words.symbol ;
|
||||
|
||||
ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||
"The compiler saves various notifications in a global variable:"
|
||||
"The compiler saves " { $link "inference-errors" } " in a global variable:"
|
||||
{ $subsection compiler-errors }
|
||||
"These notifications can be viewed later:"
|
||||
{ $subsection :errors }
|
||||
{ $subsection :warnings }
|
||||
{ $subsection :linkage }
|
||||
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
|
||||
{ $link with-compiler-errors } ;
|
||||
{ $subsection with-compiler-errors } ;
|
||||
|
||||
HELP: compiler-errors
|
||||
{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
|
||||
|
||||
ABOUT: "compiler-errors"
|
||||
|
||||
HELP: compiler-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays byte-arrays kernel kernel.private math memory
|
||||
namespaces sequences tools.test math.private quotations
|
||||
continuations prettyprint io.streams.string debugger assocs
|
||||
sequences.private accessors ;
|
||||
sequences.private accessors locals.backend ;
|
||||
IN: kernel.tests
|
||||
|
||||
[ 0 ] [ f size ] unit-test
|
||||
|
|
@ -35,7 +35,7 @@ IN: kernel.tests
|
|||
|
||||
[ ] [ [ :c ] with-string-writer drop ] unit-test
|
||||
|
||||
: overflow-r 3 [ overflow-r ] dip ;
|
||||
: overflow-r 3 load-local overflow-r ;
|
||||
|
||||
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
|
||||
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@ M: float fp-infinity? ( float -- ? )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: iterate-prep ( n quot -- i n quot ) 0 -rot ; inline
|
||||
: iterate-prep ( n quot -- i n quot ) [ 0 ] 2dip ; inline
|
||||
|
||||
: if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ M: primitive definition drop f ;
|
|||
SYMBOL: bootstrapping?
|
||||
|
||||
: if-bootstrapping ( true false -- )
|
||||
bootstrapping? get -rot if ; inline
|
||||
[ bootstrapping? get ] 2dip if ; inline
|
||||
|
||||
: bootstrap-word ( word -- target )
|
||||
[ target-word ] [ ] if-bootstrapping ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,400 @@
|
|||
! 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"
|
||||
|
|
@ -0,0 +1,524 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel
|
||||
namespaces
|
||||
accessors
|
||||
make
|
||||
math
|
||||
math.functions
|
||||
math.trig
|
||||
math.parser
|
||||
hashtables
|
||||
sequences
|
||||
combinators
|
||||
continuations
|
||||
colors
|
||||
prettyprint
|
||||
vars
|
||||
quotations
|
||||
io
|
||||
io.directories
|
||||
io.pathnames
|
||||
help.markup
|
||||
io.files
|
||||
ui.gadgets.panes
|
||||
ui
|
||||
ui.gadgets
|
||||
ui.traverse
|
||||
ui.gadgets.borders
|
||||
ui.gadgets.handler
|
||||
ui.gadgets.slate
|
||||
ui.gadgets.theme
|
||||
ui.gadgets.frames
|
||||
ui.gadgets.tracks
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.labelled
|
||||
ui.gadgets.lists
|
||||
ui.gadgets.buttons
|
||||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gestures
|
||||
ui.tools.workspace
|
||||
ui.gadgets.scrollers
|
||||
splitting
|
||||
vectors
|
||||
math.vectors
|
||||
rewrite-closures
|
||||
self
|
||||
values
|
||||
4DNav.turtle
|
||||
4DNav.window3D
|
||||
4DNav.deep
|
||||
4DNav.space-file-decoder
|
||||
models
|
||||
fry
|
||||
adsoda
|
||||
adsoda.tools
|
||||
;
|
||||
|
||||
IN: 4DNav
|
||||
VALUE: selected-file
|
||||
VALUE: translation-step
|
||||
VALUE: rotation-step
|
||||
|
||||
3 to: translation-step
|
||||
5 to: rotation-step
|
||||
|
||||
VAR: selected-file-model
|
||||
VAR: observer3d
|
||||
VAR: view1
|
||||
VAR: view2
|
||||
VAR: view3
|
||||
VAR: view4
|
||||
VAR: present-space
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! replacement of namespaces.lib
|
||||
|
||||
: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! waiting for deep-cleave-quots
|
||||
|
||||
: 4D-Rxy ( angle -- Rx ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , dup cos , dup sin neg ,
|
||||
0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rxz ( angle -- Ry ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , dup cos , 0.0 , dup sin neg ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rxw ( angle -- Rz ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , dup cos , dup sin neg , 0.0 ,
|
||||
0.0 , dup sin , dup cos , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Ryz ( angle -- Rx ) deg>rad
|
||||
[ dup cos , 0.0 , 0.0 , dup sin neg ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Ryw ( angle -- Ry ) deg>rad
|
||||
[ 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! UI
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: button* ( string quot -- button ) closed-quot <repeat-button> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: model-projection-chooser ( -- gadget )
|
||||
observer3d> projection-mode>>
|
||||
{ { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;
|
||||
|
||||
: collision-detection-chooser ( -- gadget )
|
||||
observer3d> collision-mode>>
|
||||
{ { t "on" } { f "off" } } <toggle-buttons>
|
||||
;
|
||||
|
||||
: model-projection ( x -- space ) present-space> swap space-project ;
|
||||
|
||||
: update-observer-projections ( -- )
|
||||
view1> relayout-1
|
||||
view2> relayout-1
|
||||
view3> relayout-1
|
||||
view4> relayout-1 ;
|
||||
|
||||
: update-model-projections ( -- )
|
||||
0 model-projection <model> view1> (>>model)
|
||||
1 model-projection <model> view2> (>>model)
|
||||
2 model-projection <model> view3> (>>model)
|
||||
3 model-projection <model> view4> (>>model) ;
|
||||
|
||||
: camera-action ( quot -- quot )
|
||||
[ drop [ ] observer3d> with-self update-observer-projections ]
|
||||
make* closed-quot ;
|
||||
|
||||
: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 4D object manipulation
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (mvt-4D) ( quot -- )
|
||||
present-space>
|
||||
swap call space-ensure-solids
|
||||
>present-space
|
||||
update-model-projections
|
||||
update-observer-projections ;
|
||||
|
||||
: rotation-4D ( m -- )
|
||||
'[ _ [ [ 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
|
||||
@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
|
||||
@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
|
||||
@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
|
||||
@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
|
||||
@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
|
||||
@bottom-right grid-add
|
||||
;
|
||||
|
||||
: menu-translations-4D ( -- gadget )
|
||||
<frame>
|
||||
<pile> 1 >>fill
|
||||
<shelf> 1 >>fill
|
||||
"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 ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"YZW" <label> add-gadget
|
||||
@bottom-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"XZW" <label> add-gadget
|
||||
<shelf> 1 >>fill
|
||||
"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 ]
|
||||
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 ]
|
||||
button* add-gadget
|
||||
"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 ]
|
||||
button* add-gadget
|
||||
"W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"XYZ" <label> add-gadget
|
||||
@bottom-left grid-add
|
||||
"X" <label> @center grid-add
|
||||
;
|
||||
|
||||
: menu-4D ( -- gadget )
|
||||
<shelf>
|
||||
"rotations" <label> add-gadget
|
||||
menu-rotations-4D add-gadget
|
||||
"translations" <label> add-gadget
|
||||
menu-translations-4D add-gadget
|
||||
0.5 >>align
|
||||
{ 0 10 } >>gap
|
||||
;
|
||||
|
||||
|
||||
! ------------------------------------------------------
|
||||
|
||||
: redraw-model ( space -- )
|
||||
>present-space
|
||||
update-model-projections
|
||||
update-observer-projections ;
|
||||
|
||||
: load-model-file ( -- )
|
||||
selected-file dup selected-file-model> set-model read-model-file
|
||||
redraw-model ;
|
||||
|
||||
: mvt-3D-X ( turn pitch -- quot )
|
||||
'[ turtle-pos> norm neg reset-turtle
|
||||
_ turn-left
|
||||
_ pitch-up
|
||||
step-turtle ] ;
|
||||
|
||||
: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
|
||||
: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
|
||||
: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
|
||||
: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
|
||||
|
||||
: camera-button ( string quot -- button )
|
||||
[ <label> ] dip camera-action <repeat-button> ;
|
||||
|
||||
! ----------------------------------------------------------
|
||||
! file chooser
|
||||
! ----------------------------------------------------------
|
||||
: <run-file-button> ( file-name -- button )
|
||||
dup '[ drop _ \ selected-file set-value load-model-file
|
||||
]
|
||||
closed-quot <roll-button> { 0 0 } >>align ;
|
||||
|
||||
: <list-runner> ( -- gadget )
|
||||
"resource:extra/4DNav"
|
||||
<pile> 1 >>fill
|
||||
over dup directory-files
|
||||
[ ".xml" tail? ] filter
|
||||
[ append-path ] with map
|
||||
[ <run-file-button> add-gadget ] each
|
||||
swap <labelled-gadget> ;
|
||||
|
||||
! -----------------------------------------------------
|
||||
|
||||
: 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
|
||||
<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
|
||||
@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
|
||||
<pile> 1 >>fill
|
||||
"Forward (ctl)" [ translation-step step-turtle ] camera-button
|
||||
add-gadget
|
||||
"Backward (ctl)" [ translation-step neg step-turtle ] camera-button
|
||||
add-gadget
|
||||
@center grid-add
|
||||
;
|
||||
|
||||
: menu-quick-views ( -- gadget )
|
||||
<shelf>
|
||||
"View 1 (1)" mvt-3D-1 camera-button add-gadget
|
||||
"View 2 (2)" mvt-3D-2 camera-button add-gadget
|
||||
"View 3 (3)" mvt-3D-3 camera-button add-gadget
|
||||
"View 4 (4)" mvt-3D-4 camera-button add-gadget
|
||||
;
|
||||
|
||||
: menu-3D ( -- gadget )
|
||||
<pile>
|
||||
<shelf>
|
||||
menu-rotations-3D add-gadget
|
||||
menu-translations-3D add-gadget
|
||||
0.5 >>align
|
||||
{ 0 10 } >>gap
|
||||
add-gadget
|
||||
menu-quick-views add-gadget ;
|
||||
|
||||
: add-keyboard-delegate ( obj -- obj )
|
||||
<handler>
|
||||
{
|
||||
{ T{ key-down f f "LEFT" }
|
||||
[ [ rotation-step turn-left ] camera-action ] }
|
||||
{ T{ key-down f f "RIGHT" }
|
||||
[ [ rotation-step turn-right ] camera-action ] }
|
||||
{ T{ key-down f f "UP" }
|
||||
[ [ rotation-step pitch-down ] camera-action ] }
|
||||
{ T{ key-down f f "DOWN" }
|
||||
[ [ rotation-step pitch-up ] camera-action ] }
|
||||
|
||||
{ T{ key-down f { C+ } "UP" }
|
||||
[ [ translation-step step-turtle ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "DOWN" }
|
||||
[ [ 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 ] }
|
||||
{ T{ key-down f { A+ } "RIGHT" }
|
||||
[ [ 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 ] }
|
||||
|
||||
|
||||
{ T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
|
||||
{ T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
|
||||
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
|
||||
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
|
||||
|
||||
} [ make* ] map >hashtable >>table
|
||||
;
|
||||
|
||||
! --------------------------------------------
|
||||
! print elements
|
||||
! --------------------------------------------
|
||||
! print-content
|
||||
|
||||
GENERIC: adsoda-display-model ( x -- )
|
||||
|
||||
M: light adsoda-display-model
|
||||
"\n light : " .
|
||||
{
|
||||
[ direction>> "direction : " pprint . ]
|
||||
[ color>> "color : " pprint . ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
M: face adsoda-display-model
|
||||
{
|
||||
[ halfspace>> "halfspace : " pprint . ]
|
||||
[ touching-corners>> "touching corners : " pprint . ]
|
||||
} cleave
|
||||
;
|
||||
M: solid adsoda-display-model
|
||||
{
|
||||
[ name>> "solid called : " pprint . ]
|
||||
[ color>> "color : " pprint . ]
|
||||
[ dimension>> "dimension : " pprint . ]
|
||||
[ 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 ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
! ----------------------------------------------
|
||||
: menu-bar ( -- gadget )
|
||||
<shelf>
|
||||
"reinit" [ drop load-model-file ] button* add-gadget
|
||||
selected-file-model> <label-control> add-gadget
|
||||
;
|
||||
|
||||
|
||||
: controller-window* ( -- gadget )
|
||||
{ 0 1 } <track>
|
||||
menu-bar f track-add
|
||||
<list-runner>
|
||||
<limited-scroller>
|
||||
{ 200 400 } >>max-dim
|
||||
f track-add
|
||||
<shelf>
|
||||
"Projection mode : " <label> add-gadget
|
||||
model-projection-chooser add-gadget
|
||||
f track-add
|
||||
<shelf>
|
||||
"Collision detection (slow and buggy ) : " <label> add-gadget
|
||||
collision-detection-chooser add-gadget
|
||||
f track-add
|
||||
<pile>
|
||||
0.5 >>align
|
||||
menu-4D add-gadget
|
||||
light-purple solid-interior
|
||||
"4D movements" <labelled-gadget>
|
||||
f track-add
|
||||
<pile>
|
||||
0.5 >>align
|
||||
{ 2 2 } >>gap
|
||||
menu-3D add-gadget
|
||||
light-purple solid-interior
|
||||
"Camera 3D" <labelled-gadget>
|
||||
f track-add
|
||||
gray solid-interior
|
||||
;
|
||||
|
||||
: viewer-windows* ( -- )
|
||||
"YZW" view1> win3D
|
||||
"XZW" view2> win3D
|
||||
"XYW" view3> win3D
|
||||
"XYZ" view4> win3D
|
||||
;
|
||||
|
||||
: navigator-window* ( -- )
|
||||
controller-window*
|
||||
viewer-windows*
|
||||
add-keyboard-delegate
|
||||
"navigateur 4D" open-window
|
||||
;
|
||||
|
||||
: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-variables ( -- )
|
||||
"choose a file" <model> >selected-file-model
|
||||
<observer> >observer3d
|
||||
[ observer3d> >self
|
||||
reset-turtle
|
||||
45 turn-left
|
||||
45 pitch-up
|
||||
-300 step-turtle
|
||||
] with-scope
|
||||
|
||||
;
|
||||
|
||||
|
||||
: init-models ( -- )
|
||||
0 model-projection observer3d> <window3D> >view1
|
||||
1 model-projection observer3d> <window3D> >view2
|
||||
2 model-projection observer3d> <window3D> >view3
|
||||
3 model-projection observer3d> <window3D> >view4
|
||||
;
|
||||
|
||||
: 4DNav ( -- )
|
||||
init-variables
|
||||
selected-file read-model-file >present-space
|
||||
init-models
|
||||
windows
|
||||
;
|
||||
|
||||
MAIN: 4DNav
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1 @@
|
|||
Adam Wendt
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.camera
|
||||
|
||||
HELP: camera-eye
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "return the position of the camera" } ;
|
||||
|
||||
HELP: camera-focus
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "return the point the camera looks at" } ;
|
||||
|
||||
HELP: camera-up
|
||||
{ $values
|
||||
|
||||
{ "dirvec" null }
|
||||
}
|
||||
{ $description "In order to precise the roling position of camera give an upward vector" } ;
|
||||
|
||||
HELP: do-look-at
|
||||
{ $values
|
||||
{ "camera" null }
|
||||
}
|
||||
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
|
||||
|
||||
ARTICLE: "4DNav.camera" "4DNav.camera"
|
||||
{ $vocab-link "4DNav.camera" }
|
||||
"\n"
|
||||
"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" }
|
||||
}
|
||||
"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
|
||||
"\n\n"
|
||||
"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"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
"VAR: my-camera"
|
||||
": init-my-camera ( -- )"
|
||||
" <turtle> >my-camera"
|
||||
" [ my-camera> >self"
|
||||
" reset-turtle "
|
||||
" ] with-scope ;"
|
||||
} }
|
||||
{ "To move it"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
" [ my-camera> >self"
|
||||
" 45 pitch-up "
|
||||
" 5 step-turtle"
|
||||
" ] with-scope "
|
||||
} }
|
||||
{ "or"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
" [ my-camera> >self"
|
||||
" 5 strafe-left"
|
||||
" ] with-scope "
|
||||
}
|
||||
}
|
||||
{
|
||||
"to use it in an opengl statement"
|
||||
{
|
||||
$unchecked-example
|
||||
"my-camera> do-look-at"
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.camera"
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
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 ;
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations sequences ;
|
||||
IN: 4DNav.deep
|
||||
|
||||
! HELP: deep-cleave-quots
|
||||
! { $values
|
||||
! { "seq" sequence }
|
||||
! { "quot" quotation }
|
||||
! }
|
||||
! { $description "A word to build a soquence from a sequence of quotation" }
|
||||
!
|
||||
! { $examples
|
||||
! "It is useful to build matrix"
|
||||
! { $example "USING: math math.trig ; "
|
||||
! " 30 deg>rad "
|
||||
! " { { [ cos ] [ sin neg ] 0 } "
|
||||
! " { [ sin ] [ cos ] 0 } "
|
||||
! " { 0 0 1 } "
|
||||
! " } deep-cleave-quots "
|
||||
! " "
|
||||
!
|
||||
!
|
||||
! } }
|
||||
! ;
|
||||
|
||||
ARTICLE: "4DNav.deep" "4DNav.deep"
|
||||
{ $vocab-link "4DNav.deep" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.deep"
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
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
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? t }
|
||||
{ deploy-word-props? t }
|
||||
{ deploy-name "4DNav" }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-reflection 3 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-unicode? t }
|
||||
{ deploy-io 3 }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-defs? t }
|
||||
}
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
kernel
|
||||
io.files
|
||||
io.backend
|
||||
io.directories
|
||||
io.files.info
|
||||
io.pathnames
|
||||
sequences
|
||||
models
|
||||
strings
|
||||
ui
|
||||
ui.operations
|
||||
ui.commands
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
ui.gadgets.buttons
|
||||
ui.gadgets.lists
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.tracks
|
||||
ui.gadgets.packs
|
||||
ui.gadgets.panes
|
||||
ui.gadgets.scrollers
|
||||
prettyprint
|
||||
combinators
|
||||
rewrite-closures
|
||||
accessors
|
||||
values
|
||||
tools.walker
|
||||
fry
|
||||
;
|
||||
IN: 4DNav.file-chooser
|
||||
|
||||
TUPLE: file-chooser < track
|
||||
path
|
||||
extension
|
||||
selected-file
|
||||
presenter
|
||||
hook
|
||||
list
|
||||
;
|
||||
|
||||
: find-file-list ( gadget -- list )
|
||||
[ 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 ] }
|
||||
} set-gestures
|
||||
|
||||
: list-of-files ( file-chooser -- seq )
|
||||
[ path>> value>> directory-entries ] [ extension>> ] bi
|
||||
'[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter
|
||||
;
|
||||
|
||||
: update-filelist-model ( file-chooser -- file-chooser )
|
||||
[ list-of-files ] [ model>> ] bi set-model ;
|
||||
|
||||
: init-filelist-model ( file-chooser -- file-chooser )
|
||||
dup list-of-files <model> >>model ;
|
||||
|
||||
: (fc-go) ( file-chooser quot -- )
|
||||
[ [ file-chooser? ] find-parent dup path>> ] dip
|
||||
call
|
||||
normalize-path swap set-model
|
||||
update-filelist-model
|
||||
drop ;
|
||||
|
||||
: fc-go-parent ( file-chooser -- )
|
||||
[ dup value>> parent-directory ] (fc-go) ;
|
||||
|
||||
: fc-go-home ( file-chooser -- )
|
||||
[ home ] (fc-go) ;
|
||||
|
||||
: fc-change-directory ( file-chooser file -- file-chooser )
|
||||
dupd [ path>> value>> normalize-path ] [ name>> ] bi*
|
||||
append-path over path>> set-model
|
||||
update-filelist-model
|
||||
;
|
||||
|
||||
: fc-load-file ( file-chooser file -- )
|
||||
dupd [ selected-file>> ] [ name>> ] bi* swap set-model
|
||||
[ path>> value>> ]
|
||||
[ selected-file>> value>> append ]
|
||||
[ hook>> ] tri
|
||||
call
|
||||
; inline
|
||||
|
||||
! : fc-ok-action ( file-chooser -- quot )
|
||||
! dup selected-file>> value>> "" =
|
||||
! [ drop [ drop ] ] [
|
||||
! [ path>> value>> ]
|
||||
! [ selected-file>> value>> append ]
|
||||
! [ hook>> prefix ] tri
|
||||
! [ drop ] prepend
|
||||
! ] if ;
|
||||
|
||||
: line-selected-action ( file-chooser -- )
|
||||
dup list>> list-value
|
||||
dup directory?
|
||||
[ fc-change-directory ] [ fc-load-file ] if ;
|
||||
|
||||
: present-dir-element ( element -- string )
|
||||
[ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
|
||||
|
||||
: <file-list> ( file-chooser -- list )
|
||||
dup [ nip line-selected-action ] curry
|
||||
[ present-dir-element ] rot model>> <list> ;
|
||||
|
||||
: <file-chooser> ( hook path extension -- gadget )
|
||||
{ 0 1 } file-chooser new-track
|
||||
swap >>extension
|
||||
swap <model> >>path
|
||||
"" <model> >>selected-file
|
||||
swap >>hook
|
||||
init-filelist-model
|
||||
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
|
||||
<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
|
||||
! [ drop ] "Cancel" swap <bevel-button> add-gadget
|
||||
f track-add
|
||||
dup list>> <scroller> 1 track-add
|
||||
;
|
||||
|
||||
M: file-chooser pref-dim* drop { 400 200 } ;
|
||||
|
||||
: file-chooser-window ( -- )
|
||||
[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>hypercube</name>
|
||||
<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>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>
|
||||
<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>
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>multi solids</name>
|
||||
<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,1,1</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>1,1,1</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>1,1,1</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,0,0,0</direction>
|
||||
<color>0,0,0,0.6</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,1,0,0</direction>
|
||||
<color>0,0.6,0,0</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,0,1,0</direction>
|
||||
<color>0,0,0.6,0</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,0,0,1</direction>
|
||||
<color>0.6,0.6,0.6</color>
|
||||
</light>
|
||||
<color>0.99,0.99,0.99</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>multi solids</name>
|
||||
<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>
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>Prismetragone</name>
|
||||
<dimension>4</dimension>
|
||||
<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>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
|
||||
{ $vocab-link "4DNav.space-file-decoder" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.space-file-decoder"
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: adsoda
|
||||
xml
|
||||
xml.utilities
|
||||
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 @@
|
|||
4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
|
||||
|
|
@ -0,0 +1 @@
|
|||
4D viewer
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>triancube</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>
|
||||
<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>
|
||||
0
unmaintained/golden-section/authors.txt → extra/4DNav/turtle/authors.txt
Normal file → Executable file
0
unmaintained/golden-section/authors.txt → extra/4DNav/turtle/authors.txt
Normal file → Executable file
|
|
@ -0,0 +1,229 @@
|
|||
! 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"
|
||||
|
|
@ -0,0 +1,152 @@
|
|||
USING: kernel math arrays math.vectors math.matrices
|
||||
namespaces make
|
||||
math.constants math.functions
|
||||
math.vectors
|
||||
splitting grouping self math.trig
|
||||
sequences accessors 4DNav.deep models ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: turtle pos ori ;
|
||||
|
||||
: <turtle> ( -- turtle )
|
||||
turtle new
|
||||
{ 0 0 0 } clone >>pos
|
||||
3 identity-matrix >>ori
|
||||
;
|
||||
|
||||
|
||||
TUPLE: observer < turtle projection-mode collision-mode ;
|
||||
|
||||
: <observer> ( -- object )
|
||||
observer new
|
||||
0 <model> >>projection-mode
|
||||
f <model> >>collision-mode
|
||||
;
|
||||
|
||||
|
||||
: turtle-pos> ( -- val ) self> pos>> ;
|
||||
: >turtle-pos ( val -- ) self> (>>pos) ;
|
||||
|
||||
: turtle-ori> ( -- val ) self> ori>> ;
|
||||
: >turtle-ori ( val -- ) self> (>>ori) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! These rotation matrices are from
|
||||
! `Computer Graphics: Principles and Practice'
|
||||
|
||||
|
||||
! waiting for deep-cleave-quots
|
||||
|
||||
! : Rz ( angle -- Rx ) deg>rad
|
||||
! { { [ cos ] [ sin neg ] 0 }
|
||||
! { [ sin ] [ cos ] 0 }
|
||||
! { 0 0 1 }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
! : Ry ( angle -- Ry ) deg>rad
|
||||
! { { [ cos ] 0 [ sin ] }
|
||||
! { 0 1 0 }
|
||||
! { [ sin neg ] 0 [ cos ] }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
! : Rx ( angle -- Rz ) deg>rad
|
||||
! { { 1 0 0 }
|
||||
! { 0 [ cos ] [ sin neg ] }
|
||||
! { 0 [ sin ] [ cos ] }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
: Rz ( angle -- Rx ) deg>rad
|
||||
[ dup cos , dup sin neg , 0 ,
|
||||
dup sin , dup cos , 0 ,
|
||||
0 , 0 , 1 , ] 3 make-matrix nip ;
|
||||
|
||||
: Ry ( angle -- Ry ) deg>rad
|
||||
[ dup cos , 0 , dup sin ,
|
||||
0 , 1 , 0 ,
|
||||
dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
: Rx ( angle -- Rz ) deg>rad
|
||||
[ 1 , 0 , 0 ,
|
||||
0 , dup cos , dup sin neg ,
|
||||
0 , dup sin , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-rotation ( rotation -- ) 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 ;
|
||||
|
||||
: turn-left ( angle -- ) rotate-y ;
|
||||
: turn-right ( angle -- ) neg rotate-y ;
|
||||
|
||||
: roll-left ( angle -- ) neg rotate-z ;
|
||||
: roll-right ( angle -- ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! roll-until-horizontal
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( -- 3array ) turtle-ori> [ first ] map ;
|
||||
: Y ( -- 3array ) turtle-ori> [ second ] map ;
|
||||
: Z ( -- 3array ) turtle-ori> [ third ] map ;
|
||||
|
||||
: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
|
||||
: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
|
||||
: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
|
||||
|
||||
: roll-until-horizontal ( -- )
|
||||
V Z cross normalize set-X
|
||||
Z X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: strafe-up ( length -- )
|
||||
90 pitch-up
|
||||
step-turtle
|
||||
90 pitch-down ;
|
||||
|
||||
: strafe-down ( length -- )
|
||||
90 pitch-down
|
||||
step-turtle
|
||||
90 pitch-up ;
|
||||
|
||||
: strafe-left ( length -- )
|
||||
90 turn-left
|
||||
step-turtle
|
||||
90 turn-right ;
|
||||
|
||||
: strafe-right ( length -- )
|
||||
90 turn-right
|
||||
step-turtle
|
||||
90 turn-left ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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"
|
||||
{ $vocab-link "4DNav.window3D" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.window3D"
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel
|
||||
ui.gadgets
|
||||
ui.render
|
||||
opengl
|
||||
opengl.gl
|
||||
opengl.glu
|
||||
4DNav.camera
|
||||
4DNav.turtle
|
||||
math
|
||||
values
|
||||
alien.c-types
|
||||
accessors
|
||||
namespaces
|
||||
adsoda
|
||||
models
|
||||
accessors
|
||||
prettyprint
|
||||
;
|
||||
|
||||
IN: 4DNav.window3D
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! drawing functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: window3D < gadget observer ;
|
||||
|
||||
: <window3D> ( model observer -- gadget )
|
||||
window3D new-gadget
|
||||
swap 2dup
|
||||
projection-mode>> add-connection
|
||||
2dup
|
||||
collision-mode>> add-connection
|
||||
>>observer
|
||||
swap <model> >>model
|
||||
t >>root?
|
||||
;
|
||||
|
||||
M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;
|
||||
|
||||
M: window3D draw-gadget* ( gadget -- )
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
0.6 0.6 0.6 .9 glClearColor
|
||||
dup observer>> projection-mode>> value>> 1 =
|
||||
[ 60.0 1.0 0.1 3000.0 gluPerspective ]
|
||||
[ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if
|
||||
dup observer>> collision-mode>> value>>
|
||||
\ remove-hidden-solids?
|
||||
set-value
|
||||
dup observer>> do-look-at
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
0.9 0.9 0.9 1.0 glClearColor
|
||||
1.0 glClearDepth
|
||||
GL_LINE_SMOOTH glEnable
|
||||
GL_BLEND glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_LEQUAL glDepthFunc
|
||||
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
|
||||
glLoadIdentity
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_COLOR_MATERIAL glEnable
|
||||
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
|
||||
! *************************
|
||||
|
||||
model>> value>>
|
||||
[ space->GL ] when*
|
||||
|
||||
! *************************
|
||||
;
|
||||
|
||||
M: window3D graft* drop ;
|
||||
|
||||
M: window3D model-changed nip relayout ;
|
||||
|
|
@ -0,0 +1,300 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: adsoda
|
||||
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! faces
|
||||
! --------------------------------------------------------------
|
||||
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"
|
||||
{ $subsection face }
|
||||
{ $subsection <face> }
|
||||
"test relative position"
|
||||
{ $subsection point-inside-or-on-face? }
|
||||
{ $subsection point-inside-face? }
|
||||
"handling face"
|
||||
{ $subsection flip-face }
|
||||
{ $subsection face-translate }
|
||||
{ $subsection face-transform }
|
||||
|
||||
;
|
||||
|
||||
HELP: face
|
||||
{ $class-description "a face is defined by"
|
||||
{ $list "halfspace equation" }
|
||||
{ $list "list of touching corners" }
|
||||
{ $list "list of adjacent faces" }
|
||||
$nl
|
||||
"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"
|
||||
}
|
||||
|
||||
|
||||
;
|
||||
HELP: <face>
|
||||
{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;
|
||||
HELP: flip-face
|
||||
{ $values { "face" "a face" } { "face" "flipped face" } }
|
||||
{ $description "change the orientation of a face" }
|
||||
;
|
||||
|
||||
HELP: face-translate
|
||||
{ $values { "face" "a face" } { "v" "a vector" } }
|
||||
{ $description
|
||||
"translate a face following a vector"
|
||||
$nl
|
||||
"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }
|
||||
|
||||
|
||||
;
|
||||
HELP: face-transform
|
||||
{ $values { "face" "a face" } { "m" "a transformation matrix" } }
|
||||
{ $description "compute the transformation of a face using a transformation matrix" }
|
||||
|
||||
;
|
||||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "solid-page" "solid in ADSODA"
|
||||
"explanation of solids"
|
||||
$nl
|
||||
"link to functions"
|
||||
{ $subsection solid }
|
||||
{ $subsection <solid> }
|
||||
"test relative position"
|
||||
{ $subsection point-inside-solid? }
|
||||
{ $subsection point-inside-or-on-solid? }
|
||||
"playing with faces and solids"
|
||||
{ $subsection add-face }
|
||||
{ $subsection cut-solid }
|
||||
{ $subsection slice-solid }
|
||||
"solid handling"
|
||||
{ $subsection solid-project }
|
||||
{ $subsection solid-translate }
|
||||
{ $subsection solid-transform }
|
||||
{ $subsection subtract }
|
||||
|
||||
{ $subsection get-silhouette }
|
||||
|
||||
{ $subsection solid= }
|
||||
|
||||
|
||||
;
|
||||
|
||||
HELP: solid
|
||||
{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name"
|
||||
}
|
||||
;
|
||||
|
||||
HELP: add-face
|
||||
{ $values { "solid" "a solid" } { "face" "a face" } }
|
||||
{ $description "reshape a solid with a face. The face truncate the solid." } ;
|
||||
|
||||
HELP: cut-solid
|
||||
{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }
|
||||
{ $description "like add-face but just with halfspace equation" } ;
|
||||
|
||||
HELP: slice-solid
|
||||
{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }
|
||||
{ $description "cut a solid into two parts. The face acts like a knife"
|
||||
} ;
|
||||
|
||||
|
||||
HELP: solid-project
|
||||
{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }
|
||||
{ $description "Project the solid using pv vector"
|
||||
$nl
|
||||
"TODO: explain how to use lights"
|
||||
} ;
|
||||
|
||||
HELP: solid-translate
|
||||
{ $values { "solid" "a solid" } { "v" "translating vector" } }
|
||||
{ $description "Translate a solid using a vector"
|
||||
$nl
|
||||
"v and solid must have the same dimension "
|
||||
} ;
|
||||
|
||||
HELP: solid-transform
|
||||
{ $values { "solid" "a solid" } { "m" "transformation matrix" } }
|
||||
{ $description "Transform a solid using a matrix"
|
||||
$nl
|
||||
"v and solid must have the same dimension "
|
||||
} ;
|
||||
|
||||
HELP: subtract
|
||||
{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
|
||||
{ $description " " } ;
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! space
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "space-page" "space in ADSODA"
|
||||
"A space is a collection of solids and lights."
|
||||
$nl
|
||||
"link to functions"
|
||||
$nl
|
||||
"Defining words"
|
||||
{ $subsection space }
|
||||
{ $subsection <space> }
|
||||
{ $subsection suffix-solids }
|
||||
{ $subsection suffix-lights }
|
||||
{ $subsection clear-space-solids }
|
||||
{ $subsection describe-space }
|
||||
|
||||
|
||||
"Handling space"
|
||||
{ $subsection space-ensure-solids }
|
||||
{ $subsection eliminate-empty-solids }
|
||||
{ $subsection space-transform }
|
||||
{ $subsection space-translate }
|
||||
{ $subsection remove-hidden-solids }
|
||||
{ $subsection space-project }
|
||||
|
||||
|
||||
;
|
||||
|
||||
HELP: space
|
||||
{ $class-description
|
||||
"dimension" $nl " solids" $nl " ambient-color" $nl "lights"
|
||||
}
|
||||
;
|
||||
|
||||
HELP: suffix-solids
|
||||
"( space solid -- space )"
|
||||
{ $values { "space" "a space" } { "solid" "a solid to add" } }
|
||||
{ $description "Add solid to space definition" } ;
|
||||
|
||||
HELP: suffix-lights
|
||||
"( space light -- space ) "
|
||||
{ $values { "space" "a space" } { "light" "a light to add" } }
|
||||
{ $description "Add a light to space definition" } ;
|
||||
|
||||
HELP: clear-space-solids
|
||||
"( space -- space )"
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "remove all solids in space" } ;
|
||||
|
||||
HELP: space-ensure-solids
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "rebuild corners of all solids in space" } ;
|
||||
|
||||
|
||||
|
||||
HELP: space-transform
|
||||
" ( space m -- space )"
|
||||
{ $values { "space" "a space" } { "m" "a matrix" } }
|
||||
{ $description "Transform a space using a matrix" } ;
|
||||
|
||||
HELP: space-translate
|
||||
{ $values { "space" "a space" } { "v" "a vector" } }
|
||||
{ $description "Translate a space following a vector" } ;
|
||||
|
||||
HELP: describe-space " ( space -- )"
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "return a description of space" } ;
|
||||
|
||||
HELP: space-project
|
||||
{ $values { "space" "a space" } { "i" "an integer" } }
|
||||
{ $description "Project a space along ith coordinate" } ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"
|
||||
"explanation of 3D rendering"
|
||||
$nl
|
||||
"link to functions"
|
||||
{ $subsection face->GL }
|
||||
{ $subsection solid->GL }
|
||||
{ $subsection space->GL }
|
||||
|
||||
;
|
||||
|
||||
HELP: face->GL
|
||||
{ $values { "face" "a face" } { "color" "3 3 values array" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: solid->GL
|
||||
{ $values { "solid" "a solid" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: space->GL
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "" } ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! light
|
||||
! --------------------------------------------------------------
|
||||
|
||||
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;"
|
||||
|
||||
|
||||
;
|
||||
|
||||
|
||||
|
||||
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"
|
||||
;
|
||||
|
||||
|
||||
|
||||
ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"
|
||||
"multidimensional handler :"
|
||||
$nl
|
||||
"design a solid using face delimitations. Only works on convex shapes"
|
||||
$nl
|
||||
{ $emphasis "written in C++ by Greg Ferrar" }
|
||||
$nl
|
||||
"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }
|
||||
$nl
|
||||
"Useful words are describe on the following pages: "
|
||||
{ $subsection "face-page" }
|
||||
{ $subsection "solid-page" }
|
||||
{ $subsection "space-page" }
|
||||
{ $subsection "light-page" }
|
||||
{ $subsection "3D-rendering-page" }
|
||||
;
|
||||
|
||||
ABOUT: "adsoda-main-page"
|
||||
|
|
@ -0,0 +1,310 @@
|
|||
USING: adsoda
|
||||
kernel
|
||||
math
|
||||
accessors
|
||||
sequences
|
||||
adsoda.solution2
|
||||
fry
|
||||
tools.test
|
||||
arrays ;
|
||||
|
||||
IN: adsoda.tests
|
||||
|
||||
|
||||
|
||||
: s1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"s1" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
: solid1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid1" >>name
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
: solid2 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid2" >>name
|
||||
{ -1 1 -10 } cut-solid
|
||||
{ -1 -1 -28 } cut-solid
|
||||
{ 1 0 13 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid3 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid3" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 16 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
|
||||
;
|
||||
|
||||
: solid4 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid4" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 21 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid5 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid5" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 6 } cut-solid
|
||||
{ -1 0 -17 } cut-solid
|
||||
{ 0 1 17 } cut-solid
|
||||
{ 0 -1 -19 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid7 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid7" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 38 } cut-solid
|
||||
{ 1 -5 -66 } cut-solid
|
||||
{ -2 1 -75 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid6s ( -- seq )
|
||||
solid3 clone solid2 clone subtract
|
||||
;
|
||||
|
||||
: space1 ( -- space )
|
||||
<space>
|
||||
2 >>dimension
|
||||
! solid3 suffix-solids
|
||||
solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
! solid6s [ suffix-solids ] each
|
||||
solid4 suffix-solids
|
||||
! solid5 suffix-solids
|
||||
solid7 suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
;
|
||||
|
||||
: space2 ( -- space )
|
||||
<space>
|
||||
4 >>dimension
|
||||
! 4cube suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
|
||||
;
|
||||
|
||||
|
||||
|
||||
! {
|
||||
! { 1 0 0 0 }
|
||||
! { 0 1 0 0 }
|
||||
! { 0 0 0.984807753012208 -0.1736481776669303 }
|
||||
! { 0 0 0.1736481776669303 0.984807753012208 }
|
||||
! }
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! constant+
|
||||
[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! translate
|
||||
[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! transform
|
||||
[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }
|
||||
{ { 1 0 0 }
|
||||
{ 0 1 0 }
|
||||
{ 0 0 1 }
|
||||
} transform
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! compare-nleft-to-identity-matrix
|
||||
[ t ] [
|
||||
{
|
||||
{ 1 0 0 1232 }
|
||||
{ 0 1 0 0 321 }
|
||||
{ 0 0 1 0 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 } { 0 1 0 } { 0 0 0 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 2 0 0 } { 0 1 0 } { 0 0 1 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
! ------------------------------------------------------------
|
||||
[ t ] [
|
||||
{ { 1 0 0 }
|
||||
{ 0 1 0 }
|
||||
{ 0 0 1 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 }
|
||||
{ 0 0 1 0 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 }
|
||||
{ 0 0 1 0 } } 2 valid-solution?
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
[ 3 ] [ { 1 2 3 } last ] unit-test
|
||||
|
||||
[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! position-point
|
||||
[ 0 ] [
|
||||
{ 1 -1 -5 } { 2 7 } position-point
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
|
||||
! transform
|
||||
! TODO construire un exemple
|
||||
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! slice-solid
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! solve-equation
|
||||
! deux cas de tests, avec solution et sans solution
|
||||
|
||||
[ { 2 7 } ]
|
||||
[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
[ f ]
|
||||
[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
[ f ]
|
||||
[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! point-inside-halfspace
|
||||
[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ]
|
||||
unit-test
|
||||
[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ]
|
||||
unit-test
|
||||
[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ]
|
||||
unit-test
|
||||
|
||||
|
||||
! ------------------------------
|
||||
! order solid
|
||||
|
||||
[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test
|
||||
[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test
|
||||
[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test
|
||||
[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test
|
||||
|
||||
|
||||
! clip-solid
|
||||
[ { { 13 15 } { 15 13 } { 13 13 } } ]
|
||||
[ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test
|
||||
solid2 corners>> '[ _ ]
|
||||
[ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
!
|
||||
[
|
||||
{
|
||||
{ { 13 15 } { 15 13 } { 13 13 } }
|
||||
{ { 16 17 } { 16 13 } { 36 17 } { 36 13 } }
|
||||
{ { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
|
||||
}
|
||||
] [ 0 >pv solid2 solid3 2array
|
||||
solid1 (solids-silhouette-subtract)
|
||||
[ corners>> ] map
|
||||
] unit-test
|
||||
|
||||
|
||||
[
|
||||
{
|
||||
{ { 8 13 } { 2 7 } { 12 9 } { 12 2 } }
|
||||
{ { 13 15 } { 15 13 } { 13 13 } }
|
||||
{ { 16 17 } { 16 15 } { 36 17 } { 36 15 } }
|
||||
{ { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
|
||||
}
|
||||
] [
|
||||
0 >pv <space> solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
solid3 suffix-solids
|
||||
remove-hidden-solids
|
||||
solids>> [ corners>> ] map
|
||||
] unit-test
|
||||
|
||||
! { }
|
||||
! { }
|
||||
! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix
|
||||
! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix
|
||||
! suffix
|
||||
! { 0.1 0.1 0.1 } suffix ! ambient color
|
||||
! { 0.23 0.32 0.17 } suffix ! solid color
|
||||
! solid3 faces>> first
|
||||
|
||||
! enlight-projection
|
||||
|
|
@ -0,0 +1,543 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors
|
||||
arrays
|
||||
assocs
|
||||
combinators
|
||||
kernel
|
||||
fry
|
||||
math
|
||||
math.constants
|
||||
math.functions
|
||||
math.libm
|
||||
math.order
|
||||
math.vectors
|
||||
math.matrices
|
||||
math.parser
|
||||
namespaces
|
||||
prettyprint
|
||||
sequences
|
||||
sequences.deep
|
||||
sets
|
||||
slots
|
||||
sorting
|
||||
tools.time
|
||||
vars
|
||||
continuations
|
||||
words
|
||||
opengl
|
||||
opengl.gl
|
||||
colors
|
||||
adsoda.solution2
|
||||
adsoda.combinators
|
||||
opengl.demo-support
|
||||
values
|
||||
tools.walker
|
||||
;
|
||||
|
||||
IN: adsoda
|
||||
|
||||
DEFER: combinations
|
||||
VAR: pv
|
||||
|
||||
|
||||
! ---------------------------------------------------------------------
|
||||
! global values
|
||||
VALUE: remove-hidden-solids?
|
||||
VALUE: VERY-SMALL-NUM
|
||||
VALUE: ZERO-VALUE
|
||||
VALUE: MAX-FACE-PER-CORNER
|
||||
|
||||
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 ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 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+ ;
|
||||
|
||||
: transform ( u matrix -- w )
|
||||
[ swap m.v ] 2keep ! compute new normal vector
|
||||
[
|
||||
[ [ 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
|
||||
] dip
|
||||
flip
|
||||
nth
|
||||
[ * ] with map ! apply intercep value
|
||||
over v*
|
||||
sum neg
|
||||
suffix ! add value as constant at the end of equation
|
||||
;
|
||||
|
||||
: position-point ( halfspace v -- x )
|
||||
-1 suffix v* sum ; inline
|
||||
: point-inside-halfspace? ( halfspace v -- ? )
|
||||
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 ;
|
||||
|
||||
: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
|
||||
|
||||
: compare-nleft-to-identity-matrix ( seq n -- ? )
|
||||
[ [ head ] curry map ] keep identity-matrix m-
|
||||
flatten
|
||||
[ abs ZERO-VALUE < ] all?
|
||||
;
|
||||
|
||||
: valid-solution? ( matrice n -- ? )
|
||||
islenght=?
|
||||
[ compare-nleft-to-identity-matrix ]
|
||||
[ 2drop f ] if ; inline
|
||||
|
||||
: intersect-hyperplanes ( matrice -- seq )
|
||||
[ solution dup ] [ first dimension ] bi
|
||||
valid-solution? [ get-intersection ] [ drop f ] if ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 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 ;
|
||||
: 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 ;
|
||||
: 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 >= ;
|
||||
|
||||
: (add-to-adjacent-faces) ( face face -- face )
|
||||
over adjacent-faces>> 2dup member?
|
||||
[ 2drop ] [ swap suffix >>adjacent-faces ] if ;
|
||||
|
||||
: add-to-adjacent-faces ( face face -- face )
|
||||
2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
|
||||
|
||||
: update-adjacent-faces ( faces corner -- )
|
||||
'[ [ _ suffix-touching-corner drop ] each ] keep
|
||||
2 among [
|
||||
[ first ] keep second
|
||||
[ add-to-adjacent-faces drop ] 2keep
|
||||
swap add-to-adjacent-faces drop
|
||||
] each ; inline
|
||||
|
||||
: face-project-dim ( face -- x ) halfspace>> length 2 - ;
|
||||
|
||||
: apply-light ( color light normal -- u )
|
||||
over direction>> v.
|
||||
neg dup 0 >
|
||||
[
|
||||
[ color>> swap ] dip
|
||||
[ * ] curry map v+
|
||||
[ 1 min ] map
|
||||
]
|
||||
[ 2drop ]
|
||||
if
|
||||
;
|
||||
|
||||
: enlight-projection ( array face -- color )
|
||||
! array = lights + ambient color
|
||||
[ [ third ] [ second ] [ first ] tri ]
|
||||
[ halfspace>> project-vector normalize ] bi*
|
||||
[ apply-light ] curry each
|
||||
v*
|
||||
;
|
||||
|
||||
: (intersection-into-face) ( face-init face-adja quot -- face )
|
||||
[
|
||||
[ [ pv-factor ] bi@
|
||||
roll
|
||||
[ map ] 2bi@
|
||||
v-
|
||||
] 2keep
|
||||
[ touching-corners>> ] bi@
|
||||
[ swap [ = ] curry find nip f = ] curry find nip
|
||||
] dip over
|
||||
[
|
||||
call
|
||||
dupd
|
||||
point-inside-halfspace? [ vneg ] unless
|
||||
<face>
|
||||
] [ 3drop f ] if
|
||||
; inline
|
||||
|
||||
: intersection-into-face ( face-init face-adja -- face )
|
||||
[ [ project-vector ] bi@ ] (intersection-into-face) ;
|
||||
|
||||
: intersection-into-silhouette-face ( face-init face-adja -- face )
|
||||
[ ] (intersection-into-face) ;
|
||||
|
||||
: intersections-into-faces ( face -- faces )
|
||||
clone dup adjacent-faces>> [ intersection-into-face ] with map
|
||||
[ ] filter ;
|
||||
|
||||
: (face-silhouette) ( face -- faces )
|
||||
clone dup adjacent-faces>>
|
||||
[ backface?
|
||||
[ intersection-into-silhouette-face ] [ 2drop f ] if
|
||||
] with map
|
||||
[ ] filter
|
||||
; inline
|
||||
|
||||
: face-silhouette ( face -- faces )
|
||||
backface? [ drop f ] [ (face-silhouette) ] if ;
|
||||
|
||||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 ]
|
||||
change-faces ;
|
||||
|
||||
: point-inside-or-on-face? ( face v -- ? )
|
||||
[ halfspace>> ] dip point-inside-or-on-halfspace? ;
|
||||
|
||||
: point-inside-face? ( face v -- ? )
|
||||
[ halfspace>> ] dip point-inside-halfspace? ;
|
||||
|
||||
: point-inside-solid? ( solid point -- ? )
|
||||
[ 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
|
||||
|
||||
: unvalid-adjacencies ( solid -- solid )
|
||||
erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;
|
||||
|
||||
: add-face ( solid face -- solid )
|
||||
suffix-face unvalid-adjacencies ;
|
||||
|
||||
: cut-solid ( solid halfspace -- solid ) <face> add-face ;
|
||||
|
||||
: slice-solid ( solid face -- solid1 solid2 )
|
||||
[ [ clone ] bi@ flip-face add-face
|
||||
[ "/outer/" append ] change-name ] 2keep
|
||||
add-face [ "/inner/" append ] change-name ;
|
||||
|
||||
! -------------
|
||||
|
||||
|
||||
: add-silhouette ( solid -- solid )
|
||||
dup
|
||||
! find-adjacencies
|
||||
faces>> { }
|
||||
[ face-silhouette append ] reduce
|
||||
[ ] filter
|
||||
<solid>
|
||||
swap >>faces
|
||||
over dimension>> >>dimension
|
||||
over name>> " silhouette " append
|
||||
pv> number>string append
|
||||
>>name
|
||||
! ensure-adjacencies
|
||||
suffix-silhouettes ; inline
|
||||
|
||||
: find-silhouettes ( solid -- solid )
|
||||
{ } >>silhouettes
|
||||
dup dimension>> [ [ add-silhouette ] with-pv ] each ;
|
||||
|
||||
: ensure-silhouettes ( solid -- solid )
|
||||
dup silhouettes>> [ f = ] all?
|
||||
[ find-silhouettes ] when ;
|
||||
|
||||
! ------------
|
||||
|
||||
: corner-added? ( solid corner -- ? )
|
||||
! add corner to solid if it is inside solid
|
||||
[ ]
|
||||
[ point-inside-or-on-solid? ]
|
||||
[ swap corners>> member? not ]
|
||||
2tri and
|
||||
[ suffix-corner drop t ] [ 2drop f ] if ;
|
||||
|
||||
: process-corner ( solid faces corner -- )
|
||||
swapd
|
||||
[ corner-added? ] keep swap ! test if corner is inside solid
|
||||
[ update-adjacent-faces ]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
: compute-intersection ( solid faces -- )
|
||||
dup faces-intersection
|
||||
dup f = [ 3drop ] [ process-corner ] if ;
|
||||
|
||||
: test-faces-combinaisons ( solid n -- )
|
||||
[ dup faces>> ] dip among
|
||||
[ compute-intersection ] with each ;
|
||||
|
||||
: compute-adjacencies ( solid -- solid )
|
||||
dup dimension>> [ >= ] curry
|
||||
[ keep swap ] curry MAX-FACE-PER-CORNER swap
|
||||
[ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;
|
||||
|
||||
: find-adjacencies ( solid -- solid )
|
||||
erase-old-adjacencies
|
||||
compute-adjacencies
|
||||
filter-real-faces
|
||||
t >>adjacencies-valid ;
|
||||
|
||||
: ensure-adjacencies ( solid -- solid )
|
||||
dup adjacencies-valid>>
|
||||
[ find-adjacencies ] unless
|
||||
ensure-silhouettes
|
||||
;
|
||||
|
||||
: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;
|
||||
: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;
|
||||
|
||||
: compare-corners-roughly ( corner corner -- ? )
|
||||
2drop t ;
|
||||
! : remove-inner-faces ( -- ) ;
|
||||
: face-project ( array face -- seq )
|
||||
backface?
|
||||
[ 2drop f ]
|
||||
[ [ enlight-projection ]
|
||||
[ initiate-solid-from-face ]
|
||||
[ intersections-into-faces ] tri
|
||||
>>faces
|
||||
swap >>color
|
||||
] if ;
|
||||
|
||||
: solid-project ( lights ambient solid -- solids )
|
||||
ensure-adjacencies
|
||||
[ color>> ] [ faces>> ] bi [ 3array ] dip
|
||||
[ face-project ] with map
|
||||
[ ] filter
|
||||
[ ensure-adjacencies ] map
|
||||
;
|
||||
|
||||
: (solid-move) ( solid v move -- solid )
|
||||
curry [ map ] curry
|
||||
[ 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) ;
|
||||
|
||||
: find-corner-in-silhouette ( s1 s2 -- elt bool )
|
||||
pv> swap silhouettes>> nth
|
||||
swap corners>>
|
||||
[ point-inside-solid? ] with find swap ;
|
||||
|
||||
: valid-face-for-order ( solid point -- face )
|
||||
[ point-inside-face? not ]
|
||||
[ drop face-orientation 0 = not ] 2bi and ;
|
||||
|
||||
: check-orientation ( s1 s2 pt -- int )
|
||||
[ nip faces>> ] dip
|
||||
[ valid-face-for-order ] curry find swap
|
||||
[ face-orientation ] [ drop f ] if ;
|
||||
|
||||
: (order-solid) ( s1 s2 -- int )
|
||||
2dup find-corner-in-silhouette
|
||||
[ check-orientation ] [ 3drop f ] if ;
|
||||
|
||||
: order-solid ( solid solid -- i )
|
||||
2dup (order-solid)
|
||||
[ 2nip ]
|
||||
[ swap (order-solid)
|
||||
[ neg ] [ f ] if*
|
||||
] if* ;
|
||||
|
||||
: subtract ( solid1 solid2 -- solids )
|
||||
faces>> swap clone ensure-adjacencies ensure-silhouettes
|
||||
[ swap slice-solid drop ] curry map
|
||||
[ non-empty-solid? ] filter
|
||||
[ 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
|
||||
: clear-space-solids ( space -- space ) f >>solids ;
|
||||
|
||||
: space-ensure-solids ( space -- space )
|
||||
[ [ ensure-adjacencies ] map ] change-solids ;
|
||||
: eliminate-empty-solids ( space -- space )
|
||||
[ [ non-empty-solid? ] filter ] change-solids ;
|
||||
|
||||
: projected-space ( space solids -- space )
|
||||
swap dimension>> 1- <space> swap >>dimension swap >>solids ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: describe-space ( space -- )
|
||||
solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
|
||||
|
||||
: clip-solid ( solid solid -- solids )
|
||||
[ ]
|
||||
[ solid= not ]
|
||||
[ order-solid -1 = ] 2tri
|
||||
and
|
||||
[ get-silhouette subtract ]
|
||||
[ drop 1array ]
|
||||
if
|
||||
|
||||
;
|
||||
|
||||
: (solids-silhouette-subtract) ( solids solid -- solids )
|
||||
[ clip-solid append ] curry { } -rot each ; inline
|
||||
|
||||
: solids-silhouette-subtract ( solids i solid -- solids )
|
||||
! solids is an array of 1 solid arrays
|
||||
[ (solids-silhouette-subtract) ] curry map-but
|
||||
; inline
|
||||
|
||||
: remove-hidden-solids ( space -- space )
|
||||
! We must include each solid in a sequence because during substration
|
||||
! a solid can be divided in more than on solid
|
||||
[
|
||||
[ [ 1array ] map ]
|
||||
[ length ]
|
||||
[ ]
|
||||
tri
|
||||
[ solids-silhouette-subtract ] 2each
|
||||
{ } [ append ] reduce
|
||||
] change-solids
|
||||
eliminate-empty-solids ! TODO include into change-solids
|
||||
;
|
||||
|
||||
: space-project ( space i -- space )
|
||||
[
|
||||
[ clone
|
||||
remove-hidden-solids? [ remove-hidden-solids ] when
|
||||
dup
|
||||
[ solids>> ]
|
||||
[ lights>> ]
|
||||
[ ambient-color>> ] tri
|
||||
[ rot solid-project ] 2curry
|
||||
map
|
||||
[ append ] { } -rot each
|
||||
! TODO project lights
|
||||
projected-space
|
||||
! remove-inner-faces
|
||||
!
|
||||
eliminate-empty-solids
|
||||
] with-pv
|
||||
] [ 3drop <space> ] recover
|
||||
; inline
|
||||
|
||||
: middle-of-space ( space -- point )
|
||||
solids>> [ corners>> ] map concat
|
||||
[ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
|
||||
;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
|
||||
: face-reference ( face -- halfspace point vect )
|
||||
[ halfspace>> ]
|
||||
[ touching-corners>> first ]
|
||||
[ touching-corners>> second ] tri
|
||||
over v-
|
||||
;
|
||||
|
||||
: theta ( v halfspace point vect -- v x )
|
||||
[ [ over ] dip v- ] dip
|
||||
[ cross dup norm >float ]
|
||||
[ v. >float ]
|
||||
2bi
|
||||
fatan2
|
||||
-rot v.
|
||||
0 < [ neg ] when
|
||||
;
|
||||
|
||||
: ordered-face-points ( face -- corners )
|
||||
[ touching-corners>> 1 head ]
|
||||
[ touching-corners>> 1 tail ]
|
||||
[ face-reference [ theta ] 3curry ] tri
|
||||
{ } map>assoc sort-values keys
|
||||
append
|
||||
; inline
|
||||
|
||||
: point->GL ( point -- ) gl-vertex ;
|
||||
: points->GL ( array -- ) do-cycle [ point->GL ] each ;
|
||||
|
||||
: 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 ]
|
||||
bi
|
||||
; inline
|
||||
|
||||
: solid->GL ( solid -- )
|
||||
[ faces>> ]
|
||||
[ color>> ] bi
|
||||
[ face->GL ] curry each ; inline
|
||||
|
||||
: space->GL ( space -- )
|
||||
solids>>
|
||||
[ solid->GL ] each ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
! : init-4D-demo ( -- space )
|
||||
! OK
|
||||
! espace de dimension 4 et de couleur 0,3 0.3 0.3
|
||||
<space>
|
||||
4 >>dimension
|
||||
{ 0.3 0.3 0.3 } >>ambient-color
|
||||
{ 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids
|
||||
{ 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids
|
||||
<light>
|
||||
{ -100 -100 -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
! ;
|
||||
! : init-3D-demo ( -- space )
|
||||
! OK
|
||||
! espace de dimension 4 et de couleur 0,3 0.3 0.3
|
||||
<space>
|
||||
3 >>dimension
|
||||
{ 0.3 0.3 0.3 } >>ambient-color
|
||||
{ 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids
|
||||
! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids
|
||||
<light>
|
||||
{ -100 -100 -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
! ;
|
||||
|
||||
|
||||
: s1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"s1" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
: solid1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid1" >>name
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
: solid2 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid2" >>name
|
||||
{ -1 1 -10 } cut-solid
|
||||
{ -1 -1 -28 } cut-solid
|
||||
{ 1 0 13 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid3 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid3" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 16 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
|
||||
;
|
||||
|
||||
: solid4 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid4" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 21 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid5 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid5" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 6 } cut-solid
|
||||
{ -1 0 -17 } cut-solid
|
||||
{ 0 1 17 } cut-solid
|
||||
{ 0 -1 -19 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid7 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid7" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 38 } cut-solid
|
||||
{ 1 -5 -66 } cut-solid
|
||||
{ -2 1 -75 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid6s ( -- seq )
|
||||
solid3 clone solid2 clone subtract
|
||||
;
|
||||
|
||||
: space1 ( -- space )
|
||||
<space>
|
||||
2 >>dimension
|
||||
! solid3 suffix-solids
|
||||
solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
! solid6s [ suffix-solids ] each
|
||||
solid4 suffix-solids
|
||||
! solid5 suffix-solids
|
||||
solid7 suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
;
|
||||
|
||||
: space2 ( -- space )
|
||||
<space>
|
||||
4 >>dimension
|
||||
! 4cube suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Jeff Bigot
|
||||
Greg Ferrar
|
||||
|
|
@ -0,0 +1 @@
|
|||
JF Bigot, after Greg Ferrar
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2008 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: adsoda.combinators
|
||||
|
||||
HELP: among
|
||||
{ $values
|
||||
{ "array" array } { "n" null }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
|
||||
|
||||
HELP: columnize
|
||||
{ $values
|
||||
{ "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "flip a sequence into a sequence of 1 element sequences" } ;
|
||||
|
||||
HELP: concat-nth
|
||||
{ $values
|
||||
{ "seq1" sequence } { "seq2" sequence }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
|
||||
|
||||
HELP: do-cycle
|
||||
{ $values
|
||||
{ "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
|
||||
|
||||
|
||||
ARTICLE: "adsoda.combinators" "adsoda.combinators"
|
||||
{ $vocab-link "adsoda.combinators" }
|
||||
;
|
||||
|
||||
ABOUT: "adsoda.combinators"
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
USING: adsoda.combinators
|
||||
sequences
|
||||
tools.test
|
||||
;
|
||||
|
||||
IN: adsoda.combinators.tests
|
||||
|
||||
|
||||
[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences fry math combinators ;
|
||||
|
||||
IN: adsoda.combinators
|
||||
|
||||
! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
|
||||
|
||||
! : prefix-each [ prefix ] curry map ; inline
|
||||
|
||||
! : combinations ( seq n -- seqs )
|
||||
! {
|
||||
! { [ dup 0 = ] [ 2drop { { } } ] }
|
||||
! { [ over empty? ] [ 2drop { } ] }
|
||||
! { [ t ] [
|
||||
! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]
|
||||
! [ (combinations) ] 2bi append
|
||||
! ] }
|
||||
! } cond ;
|
||||
|
||||
: columnize ( array -- array ) [ 1array ] map ; inline
|
||||
|
||||
: among ( array n -- array )
|
||||
2dup swap length
|
||||
{
|
||||
{ [ over 1 = ] [ 3drop columnize ] }
|
||||
{ [ over 0 = ] [ 2drop 2drop { } ] }
|
||||
{ [ 2dup < ] [ 2drop [ 1 cut ] dip
|
||||
[ 1- among [ append ] with map ]
|
||||
[ among append ] 2bi
|
||||
] }
|
||||
{ [ 2dup = ] [ 3drop 1array ] }
|
||||
{ [ 2dup > ] [ 2drop 2drop { } ] }
|
||||
} cond
|
||||
;
|
||||
|
||||
: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;
|
||||
|
||||
: do-cycle ( array -- array ) dup first suffix ;
|
||||
|
||||
: map-but ( seq i quot -- seq )
|
||||
! quot : ( seq x -- seq )
|
||||
'[ _ = [ @ ] unless ] map-index ; inline
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
USING: kernel
|
||||
sequences
|
||||
namespaces
|
||||
|
||||
math
|
||||
math.vectors
|
||||
math.matrices
|
||||
;
|
||||
IN: adsoda.solution2
|
||||
|
||||
! -------------------
|
||||
! correctif solution
|
||||
! ---------------
|
||||
SYMBOL: matrix
|
||||
: MIN-VAL-adsoda ( -- x ) 0.00000001
|
||||
! 0.000000000001
|
||||
;
|
||||
|
||||
: zero? ( x -- ? )
|
||||
abs MIN-VAL-adsoda <
|
||||
;
|
||||
|
||||
! [ number>string string>number ] map
|
||||
|
||||
: with-matrix ( matrix quot -- )
|
||||
[ swap matrix set call matrix get ] with-scope ; inline
|
||||
|
||||
: nth-row ( row# -- seq ) matrix get nth ;
|
||||
|
||||
: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )
|
||||
matrix get swap change-nth ; inline
|
||||
|
||||
: exchange-rows ( row# row# -- ) matrix get exchange ;
|
||||
|
||||
: rows ( -- n ) matrix get length ;
|
||||
|
||||
: cols ( -- n ) 0 nth-row length ;
|
||||
|
||||
: skip ( i seq quot -- n )
|
||||
over [ find-from drop ] dip length or ; inline
|
||||
|
||||
: first-col ( row# -- n )
|
||||
#! First non-zero column
|
||||
0 swap nth-row [ zero? not ] skip ;
|
||||
|
||||
: clear-scale ( col# pivot-row i-row -- n )
|
||||
[ over ] dip nth dup zero? [
|
||||
3drop 0
|
||||
] [
|
||||
[ nth dup zero? ] dip swap [
|
||||
2drop 0
|
||||
] [
|
||||
swap / neg
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: (clear-col) ( col# pivot-row i -- )
|
||||
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
|
||||
|
||||
: rows-from ( row# -- slice )
|
||||
rows dup <slice> ;
|
||||
|
||||
: clear-col ( col# row# rows -- )
|
||||
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
|
||||
|
||||
: do-row ( exchange-with row# -- )
|
||||
[ exchange-rows ] keep
|
||||
[ first-col ] keep
|
||||
dup 1+ rows-from clear-col ;
|
||||
|
||||
: find-row ( row# quot -- i elt )
|
||||
[ rows-from ] dip find ; inline
|
||||
|
||||
: pivot-row ( col# row# -- n )
|
||||
[ dupd nth-row nth zero? not ] find-row 2nip ;
|
||||
|
||||
: (echelon) ( col# row# -- )
|
||||
over cols < over rows < and [
|
||||
2dup pivot-row [ over do-row 1+ ] when*
|
||||
[ 1+ ] dip (echelon)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: echelon ( matrix -- matrix' )
|
||||
[ 0 0 (echelon) ] with-matrix ;
|
||||
|
||||
: nonzero-rows ( matrix -- matrix' )
|
||||
[ [ zero? ] all? not ] filter ;
|
||||
|
||||
: null/rank ( matrix -- null rank )
|
||||
echelon dup length swap nonzero-rows length [ - ] keep ;
|
||||
|
||||
: leading ( seq -- n elt ) [ zero? not ] find ;
|
||||
|
||||
: reduced ( matrix' -- matrix'' )
|
||||
[
|
||||
rows <reversed> [
|
||||
dup nth-row leading drop
|
||||
dup [ swap dup clear-col ] [ 2drop ] if
|
||||
] each
|
||||
] with-matrix ;
|
||||
|
||||
: basis-vector ( row col# -- )
|
||||
[ clone ] dip
|
||||
[ swap nth neg recip ] 2keep
|
||||
[ 0 spin set-nth ] 2keep
|
||||
[ n*v ] dip
|
||||
matrix get set-nth ;
|
||||
|
||||
: nullspace ( matrix -- seq )
|
||||
echelon reduced dup empty? [
|
||||
dup first length identity-matrix [
|
||||
[
|
||||
dup leading drop
|
||||
dup [ basis-vector ] [ 2drop ] if
|
||||
] each
|
||||
] with-matrix flip nonzero-rows
|
||||
] unless ;
|
||||
|
||||
: 1-pivots ( matrix -- matrix )
|
||||
[ dup leading nip [ recip v*n ] when* ] map ;
|
||||
|
||||
: solution ( matrix -- matrix )
|
||||
echelon nonzero-rows reduced 1-pivots ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
A modification of solution to approximate solutions
|
||||
|
|
@ -0,0 +1 @@
|
|||
ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
|
||||
|
|
@ -0,0 +1 @@
|
|||
adsoda 4D viewer
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2008 Jeff Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: adsoda.tools
|
||||
|
||||
HELP: 3cube
|
||||
{ $values
|
||||
{ "array" "array" } { "name" "name" }
|
||||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax"
|
||||
"\n returns a 3D solid with given limits"
|
||||
} ;
|
||||
|
||||
HELP: 4cube
|
||||
{ $values
|
||||
{ "array" "array" } { "name" "name" }
|
||||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
|
||||
"\n 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" }
|
||||
{ "matrix" "matrix" }
|
||||
}
|
||||
{ $description "From a list of points, return the matrix"
|
||||
"to solve in order to find the vector normal to the plan defined by the points" }
|
||||
;
|
||||
|
||||
HELP: normal-vector
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
{ "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" }
|
||||
;
|
||||
|
||||
HELP: points-to-hyperplane
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
{ "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"
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "adsoda.tools" "adsoda.tools"
|
||||
{ $vocab-link "adsoda.tools" }
|
||||
"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
|
||||
;
|
||||
|
||||
ABOUT: "adsoda.tools"
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
adsoda.tools
|
||||
tools.test
|
||||
;
|
||||
|
||||
IN: adsoda.tools.tests
|
||||
|
||||
|
||||
[ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test
|
||||
[ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test
|
||||
|
||||
[ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
kernel
|
||||
sequences
|
||||
math
|
||||
accessors
|
||||
adsoda
|
||||
math.vectors
|
||||
math.matrices
|
||||
bunny.model
|
||||
io.encodings.ascii
|
||||
io.files
|
||||
sequences.deep
|
||||
combinators
|
||||
adsoda.combinators
|
||||
fry
|
||||
io.files.temp
|
||||
grouping
|
||||
;
|
||||
|
||||
IN: adsoda.tools
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
! ---------------------------------
|
||||
: coord-min ( x array -- array ) swap suffix ;
|
||||
: coord-max ( x array -- array ) swap neg suffix ;
|
||||
|
||||
: 4cube ( array name -- solid )
|
||||
! array : xmin xmax ymin ymax zmin zmax wmin wmax
|
||||
<solid>
|
||||
4 >>dimension
|
||||
swap >>name
|
||||
swap
|
||||
{
|
||||
[ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ]
|
||||
[ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]
|
||||
[ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ]
|
||||
[ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]
|
||||
}
|
||||
[ curry call ] 2map
|
||||
[ cut-solid ] each
|
||||
ensure-adjacencies
|
||||
|
||||
; inline
|
||||
|
||||
: 3cube ( array name -- solid )
|
||||
! array : xmin xmax ymin ymax zmin zmax wmin wmax
|
||||
<solid>
|
||||
3 >>dimension
|
||||
swap >>name
|
||||
swap
|
||||
{
|
||||
[ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ]
|
||||
[ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]
|
||||
[ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ]
|
||||
}
|
||||
[ curry call ] 2map
|
||||
[ cut-solid ] each
|
||||
ensure-adjacencies
|
||||
|
||||
; inline
|
||||
|
||||
|
||||
: equation-system-for-normal ( points -- matrix )
|
||||
unclip [ v- 0 suffix ] curry map
|
||||
dup first [ drop 1 ] map suffix
|
||||
;
|
||||
|
||||
: normal-vector ( points -- v )
|
||||
equation-system-for-normal
|
||||
intersect-hyperplanes ;
|
||||
|
||||
: points-to-hyperplane ( points -- hyperplane )
|
||||
[ normal-vector 0 suffix ] [ first ] bi
|
||||
translate ;
|
||||
|
||||
: refs-to-points ( points faces -- faces )
|
||||
[ 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 } } }
|
||||
|
||||
: ply-model-path ( -- path )
|
||||
|
||||
! "bun_zipper.ply"
|
||||
"screw2.ply"
|
||||
temp-file
|
||||
;
|
||||
|
||||
: read-bunny-model ( -- v )
|
||||
ply-model-path ascii [ parse-model ] with-file-reader
|
||||
|
||||
refs-to-points
|
||||
;
|
||||
|
||||
: 3points-to-normal ( seq -- v )
|
||||
unclip [ v- ] curry map first2 cross normalize
|
||||
;
|
||||
: 2-faces-to-prism ( seq seq -- seq )
|
||||
2dup
|
||||
[ 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"
|
||||
! and of based on the three points
|
||||
! a face is a group of 3 or mode points.
|
||||
[ dup dup 3points-to-normal ] dip
|
||||
v*n [ v+ ] curry map ! 2 eme face triangulaire
|
||||
2-faces-to-prism
|
||||
|
||||
! [ dup number? [ 1 + ] when ] deep-map
|
||||
! dup keep
|
||||
;
|
||||
|
||||
|
||||
: Xpoints-to-plane4D ( seq x y -- 4Dplane )
|
||||
! 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.
|
||||
'[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call
|
||||
2-faces-to-prism
|
||||
;
|
||||
|
||||
: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )
|
||||
[ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map
|
||||
|
||||
;
|
||||
|
||||
: test-figure ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
|
||||
|
|
@ -30,7 +30,7 @@ IN: bunny.model
|
|||
[ n ] keep [ rot [ v+ ] change-nth ] with with each ;
|
||||
|
||||
: normals ( vs is -- ns )
|
||||
over length { 0.0 0.0 0.0 } <array> -rot
|
||||
[ [ length { 0.0 0.0 0.0 } <array> ] keep ] dip
|
||||
[ [ 2dup ] dip normal ] each drop
|
||||
[ normalize ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,111 @@
|
|||
|
||||
USING: arrays assocs compiler.units
|
||||
grouping help help.markup help.topics kernel lexer multiline
|
||||
namespaces parser sequences splitting words
|
||||
easy-help.expand-markup ;
|
||||
|
||||
IN: easy-help
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: parse-text-block ( -- array )
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ expand-markup ] map
|
||||
concat
|
||||
[ dup "" = [ drop { $nl } ] [ ] if ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Text: parse-text-block parsed ; parsing
|
||||
|
||||
: Block: scan-word 1array parse-text-block append parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Notes: { $notes } parse-text-block append parsed ; parsing
|
||||
: Description: { $description } parse-text-block append parsed ; parsing
|
||||
: Contract: { $contract } parse-text-block append parsed ; parsing
|
||||
: Checked-Example: { $example } parse-text-block append parsed ; parsing
|
||||
|
||||
: Class-Description:
|
||||
{ $class-description } parse-text-block append parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Code:
|
||||
|
||||
{ $code }
|
||||
parse-text-block [ dup array? [ drop "" ] [ ] if ] map
|
||||
append
|
||||
parsed
|
||||
|
||||
; parsing
|
||||
|
||||
: Example:
|
||||
{ $heading "Example" }
|
||||
{ $code }
|
||||
parse-text-block
|
||||
[ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
|
||||
append
|
||||
2array parsed ; parsing
|
||||
|
||||
: Introduction:
|
||||
|
||||
{ $heading "Introduction" }
|
||||
parse-text-block
|
||||
2array parsed ; parsing
|
||||
|
||||
: Summary:
|
||||
|
||||
{ $heading "Summary" }
|
||||
parse-text-block
|
||||
2array parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Values:
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ " " split1 [ " " first = ] trim-left 2array ] map
|
||||
\ $values prefix
|
||||
parsed
|
||||
|
||||
; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Word:
|
||||
|
||||
scan current-vocab create dup old-definitions get
|
||||
[ delete-at ] with each dup set-word
|
||||
|
||||
bootstrap-word dup set-word
|
||||
dup >link save-location
|
||||
\ ; parse-until >array swap set-word-help ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: List:
|
||||
|
||||
{ $list }
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ expand-markup ] map
|
||||
|
||||
append parsed
|
||||
|
||||
; parsing
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
|
||||
USING: accessors arrays kernel lexer locals math namespaces parser
|
||||
sequences splitting ;
|
||||
|
||||
IN: easy-help.expand-markup
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scan-one-array ( string -- array rest )
|
||||
string-lines
|
||||
lexer-factory get call
|
||||
[
|
||||
[
|
||||
\ } parse-until >array
|
||||
lexer get line-text>>
|
||||
lexer get column>> tail
|
||||
]
|
||||
with-lexer
|
||||
]
|
||||
with-scope ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: expand-markup ( LINE -- lines )
|
||||
|
||||
LINE contains-markup?
|
||||
[
|
||||
|
||||
[let | N [ "{ $" LINE start ] |
|
||||
|
||||
LINE N head
|
||||
|
||||
LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
|
||||
|
||||
[ 2array ] dip
|
||||
|
||||
expand-markup
|
||||
|
||||
append ]
|
||||
|
||||
]
|
||||
[ LINE 1array ]
|
||||
if ;
|
||||
|
|
@ -1,19 +1,17 @@
|
|||
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs classes classes.tuple
|
||||
combinators compiler.units continuations debugger definitions
|
||||
eval help io io.files io.pathnames io.streams.string kernel
|
||||
lexer listener listener.private make math memoize namespaces
|
||||
parser prettyprint prettyprint.config quotations sequences sets
|
||||
sorting source-files strings tools.vocabs vectors vocabs
|
||||
vocabs.loader vocabs.parser summary ;
|
||||
USING: accessors arrays assocs classes.tuple combinators
|
||||
compiler.units continuations debugger definitions io io.pathnames
|
||||
io.streams.string kernel lexer math math.order memoize namespaces
|
||||
parser prettyprint sequences sets sorting source-files strings summary
|
||||
tools.vocabs vectors vocabs vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
! Evaluation status:
|
||||
|
||||
TUPLE: fuel-status in use ds? restarts ;
|
||||
TUPLE: fuel-status in use restarts ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
|
@ -36,26 +34,22 @@ t clone fuel-eval-res-flag set-global
|
|||
: fuel-eval-non-restartable ( -- )
|
||||
f fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get restarts get-global clone
|
||||
: fuel-push-status ( -- )
|
||||
in get use get clone restarts get-global clone
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
: fuel-pop-restarts ( restarts -- )
|
||||
fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
|
||||
|
||||
: fuel-pop-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop {
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ]
|
||||
[
|
||||
restarts>> fuel-eval-restartable? [ drop ] [
|
||||
clone restarts set-global
|
||||
] if
|
||||
]
|
||||
} cleave
|
||||
[ restarts>> fuel-pop-restarts ] tri
|
||||
] unless ;
|
||||
|
||||
|
||||
! Lispy pretty printing
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
|
@ -69,11 +63,7 @@ M: integer fuel-pprint pprint ; inline
|
|||
M: string fuel-pprint pprint ; inline
|
||||
|
||||
M: sequence fuel-pprint
|
||||
dup empty? [ drop f fuel-pprint ] [
|
||||
"(" write
|
||||
[ " " write ] [ fuel-pprint ] interleave
|
||||
")" write
|
||||
] if ;
|
||||
"(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline
|
||||
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ; inline
|
||||
|
||||
|
|
@ -112,22 +102,20 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
error get
|
||||
fuel-eval-result get-global
|
||||
fuel-eval-output get-global
|
||||
3array fuel-pprint flush nl "EOT:" write ;
|
||||
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
|
||||
|
||||
: fuel-forget-error ( -- ) f error set-global ; inline
|
||||
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
|
||||
: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
push-fuel-status
|
||||
display-stacks? off
|
||||
fuel-push-status
|
||||
fuel-forget-error
|
||||
fuel-forget-result
|
||||
fuel-forget-output ;
|
||||
|
||||
: (fuel-end-eval) ( quot -- )
|
||||
with-string-writer fuel-eval-output set-global
|
||||
fuel-retort pop-fuel-status ; inline
|
||||
: (fuel-end-eval) ( output -- )
|
||||
fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
|
||||
|
||||
: (fuel-eval) ( lines -- )
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry
|
||||
|
|
@ -144,34 +132,59 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
|
||||
|
||||
: fuel-eval-in-context ( lines in usings -- )
|
||||
(fuel-begin-eval) [
|
||||
(fuel-eval-usings)
|
||||
(fuel-eval-in)
|
||||
(fuel-eval)
|
||||
] (fuel-end-eval) ;
|
||||
|
||||
: fuel-begin-eval ( in -- )
|
||||
(fuel-begin-eval)
|
||||
(fuel-eval-in)
|
||||
fuel-retort ;
|
||||
[ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
|
||||
(fuel-end-eval) ;
|
||||
|
||||
: fuel-eval ( lines -- )
|
||||
(fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
|
||||
|
||||
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
|
||||
! Loading files
|
||||
|
||||
: fuel-run-file ( path -- ) run-file ; inline
|
||||
|
||||
: fuel-with-autouse ( quot -- )
|
||||
[
|
||||
auto-use? on
|
||||
[ amended-use get clone fuel-eval-set-result ] print-use-hook set
|
||||
call
|
||||
] curry with-scope ;
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
[ parse-fresh drop ] curry with-compilation-unit ; inline
|
||||
|
||||
: fuel-get-uses ( lines -- )
|
||||
[ (fuel-get-uses) ] curry fuel-with-autouse ;
|
||||
|
||||
! Edit locations
|
||||
|
||||
: fuel-normalize-loc ( seq -- path line )
|
||||
dup length 1 > [ first2 [ (normalize-path) ] dip ] [ f ] if ; inline
|
||||
|
||||
: fuel-get-edit-location ( defspec -- )
|
||||
where [
|
||||
first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
|
||||
] when* ; inline
|
||||
where fuel-normalize-loc 2array fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-get-vocab-location ( vocab -- )
|
||||
>vocab-link fuel-get-edit-location ; inline
|
||||
|
||||
: fuel-get-doc-location ( defspec -- )
|
||||
props>> "help-loc" swap at
|
||||
fuel-normalize-loc 2array fuel-eval-set-result ;
|
||||
|
||||
! Cross-references
|
||||
|
||||
: fuel-word>xref ( word -- xref )
|
||||
[ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;
|
||||
|
||||
: fuel-sort-xrefs ( seq -- seq' )
|
||||
[ [ first ] dip first <=> ] sort ; inline
|
||||
|
||||
: fuel-format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;
|
||||
|
||||
: fuel-callers-xref ( word -- )
|
||||
usage fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-callees-xref ( word -- )
|
||||
uses fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
: fuel-filter-prefix ( seq prefix -- seq )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Eduardo Cavazos
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue