LD = ld
EXECUTABLE = factor
+CONSOLE_EXECUTABLE = factor-console
VERSION = 0.92
IMAGE = factor.image
winnt-x86-32: freetype6.dll zlib1.dll
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+factor-console: $(DLL_OBJS) $(EXE_OBJS)
+ $(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib}
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array io.streams.string kernel math namespaces
-sequences strings ;
+sequences strings io.crlf ;
IN: base64
<PRIVATE
: write1-lines ( ch -- )
write1
column get [
- 1+ [ 76 = [ "\r\n" write ] when ]
+ 1+ [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
] with each ; inline
: encode-pad ( seq n -- )
- [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
- [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
+ [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
+ [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
ERROR: malformed-base64 ;
--- /dev/null
+parsing
+web
bootstrap-cell <groups> native> emit-seq ;
: pad-bytes ( seq -- newseq )
- dup length bootstrap-cell align 0 pad-right ;
+ dup length bootstrap-cell align 0 pad-tail ;
: extended-part ( str -- str' )
dup [ 128 < ] all? [ drop f ] [
SYMBOL: bootstrap-time
: default-image-name ( -- string )
- vm file-name os windows? [ "." split1 drop ] when
+ vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
: do-crossref ( -- )
combinators accessors calendar calendar.format.macros present ;\r
IN: calendar.format\r
\r
-: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
+: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
\r
-: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
+: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;\r
\r
-: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
+: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;\r
\r
: write-00 ( n -- ) pad-00 write ;\r
\r
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
- [ zero? ] trim-left
+ [ zero? ] trim-head
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
- word-size get group [ be> ] map block-size get 0 pad-right
+ word-size get group [ be> ] map block-size get 0 pad-tail
dup 16 64 dup <slice> [
process-M-256
] with each ;
[ ] [
{
- T{ ##load-indirect f V int-regs 1 "hello" }
+ T{ ##load-reference f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##load-indirect analyze-aliases*
+M: ##load-reference analyze-aliases*
dup dst>> set-heap-ac ;
M: ##alien-global analyze-aliases*
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-indirect < ##pure obj ;
+INSN: ##load-reference < ##pure obj ;
GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-indirect ;
+M: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;
##box-float
##box-alien
} memq?
- ] contains? ;
+ ] any? ;
: linearize-basic-block ( bb -- )
[ number>> _label ]
M: ##load-immediate >expr val>> <constant> ;
-M: ##load-indirect >expr obj>> <constant> ;
-
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
[
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
}
] [
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
[
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
}
] [
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
-M: ##load-indirect generate-insn
- [ dst>> register ] [ obj>> ] bi %load-indirect ;
+M: ##load-reference generate-insn
+ [ dst>> register ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn
[ dst>> register ] [ loc>> ] bi %peek ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
- dupd '[ _ dlsym ] contains?
+ dupd '[ _ dlsym ] any?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
+
+TUPLE: cucumber ;
+
+M: cucumber equal? "The cucumber has no equal" throw ;
+
+[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
\ No newline at end of file
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
+: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
- [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
+ [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
] unit-test
[ t f ] [
[ { "hi" } bleh ] ignore-errors
- \ + stack-trace-contains?
- \ > stack-trace-contains?
+ \ + stack-trace-any?
+ \ > stack-trace-any?
] unit-test
: inline-recursive ( -- ) inline-recursive ; inline recursive
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
+[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test
branch-out get [ ] find nip swap head* >vector datastack set ;
M: #phi check-stack-flow*
- branch-out get [ ] contains? [
+ branch-out get [ ] any? [
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
] [ drop terminated? on ] if ;
[ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
- [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+ [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
] unit-test
[ ] [
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
- children>> [ _ contains-node? ] contains?
+ children>> [ _ contains-node? ] any?
] [
dup #recursive? [
child>> _ contains-node?
] [ drop f ] if
] if
] if
- ] contains? ; inline recursive
+ ] any? ; inline recursive
: select-children ( seq flags -- seq' )
[ [ drop f ] unless ] 2map ;
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
: some-outputs-dead? ( #call -- ? )
- out-d>> [ live-value? not ] contains? ;
+ out-d>> [ live-value? not ] any? ;
: maybe-drop-dead-outputs ( node -- nodes )
dup some-outputs-dead? [
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
- dup [ +bottom+ eq? ] trim-left
+ dup [ +bottom+ eq? ] trim-head
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;
[ class-types length 1 = ]
[ union-class? not ]
bi and
- ] contains? ;
+ ] any? ;
: node-count-bias ( -- n )
45 node-count get [-] 8 /i ;
! These nodes never participate in unboxing
: assert-not-unboxed ( values -- )
dup array?
- [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+ [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
[ "Unboxing wrong value" throw ] when ;
M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
\r
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
mailbox check-disposed\r
- mailbox data>> pred dlist-contains? [\r
+ mailbox data>> pred dlist-any? [\r
mailbox timeout wait-for-mailbox\r
mailbox timeout pred block-unless-pred\r
] unless ; inline recursive\r
HOOK: two-operand? cpu ( -- ? )
HOOK: %load-immediate cpu ( reg obj -- )
-HOOK: %load-indirect cpu ( reg obj -- )
+HOOK: %load-reference cpu ( reg obj -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
-M: ppc %load-indirect ( reg obj -- )
+M: ppc %load-reference ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
M: ppc %alien-global ( register symbol dll -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
"end" define-label
- dst 0 >bignum %load-indirect
+ dst 0 >bignum %load-reference
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 4 scratch@ STW
dst 1 0 scratch@ LFD
- scratch-reg 4503601774854144.0 %load-indirect
+ scratch-reg 4503601774854144.0 %load-reference
fp-scratch-reg scratch-reg float-offset LFD
dst dst fp-scratch-reg FSUB ;
"end" define-label
dst \ f tag-number %load-immediate
"end" get word execute
- dst \ t %load-indirect
+ dst \ t %load-reference
"end" get resolve-label ; inline
: %boolean ( dst temp cc -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
- 3 swap %load-indirect "c_to_factor" f %alien-invoke ;
+ 3 swap %load-reference "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
M: x86.32 %alien-callback ( quot -- )
4 [
- EAX swap %load-indirect
+ EAX swap %load-reference
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
- param-reg-1 swap %load-indirect
+ param-reg-1 swap %load-reference
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
M: x86 %load-immediate MOV ;
-M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
[
"end" define-label
! Load cached zero value
- dst 0 >bignum %load-indirect
+ dst 0 >bignum %load-reference
src 0 CMP
! Is it zero? Then just go to the end and return this zero
"end" get JE
delimiter swap with-variable ; inline
: needs-escaping? ( cell -- ? )
- [ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! "
+ [ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
-"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
+"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
"Executing a SQL command:"
{ $subsection sql-command }
"Executing a query directly:"
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
-"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
+"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
{ $code <"
USING: db.sqlite db io.files ;
: with-book-db ( quot -- )
] if ;
: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains?
+ dup in-params>> [ generator-bind? ] any?
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )
] with-string-writer ;
: can-be-null? ( -- ? )
- "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
+ "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
: delete-cascade? ( -- ? )
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
HELP: ensure-tables
{ $values
- { "classes" null } }
+ { "classes" "a sequence of classes" } }
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
HELP: recreate-table
{ $subsection <count-statement> } ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
-"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
+"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
"We're going to store books in this tutorial."
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
{ $code <" [
book get update-tuple
] with-book-tutorial "> }
-"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
+"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
{ $code <" [
T{ book { title "Factor for Sheeple" } } select-tuples
] with-book-tutorial "> }
kernel sequences strings math ;
IN: db.types
-HELP: +autoincrement+
-{ $description "" } ;
-
HELP: +db-assigned-id+
{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
HELP: +default+
-{ $description "" } ;
-
-HELP: +foreign-id+
-{ $description "" } ;
-
-HELP: +has-many+
-{ $description "" } ;
+{ $description "Allows a default value for a column to be provided." } ;
HELP: +not-null+
-{ $description "" } ;
+{ $description "Ensures that a column is not null." } ;
HELP: +null+
-{ $description "" } ;
+{ $description "Allows a column to be null." } ;
HELP: +primary-key+
-{ $description "" } ;
+{ $description "Makes a column a primary key. Only one column may be a primary key." } ;
HELP: +random-id+
{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
-HELP: +serial+
-{ $description "" } ;
-
-HELP: +unique+
-{ $description "" } ;
-
HELP: +user-assigned-id+
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: bind#
{ $values
- { "spec" null } { "obj" object } }
+ { "spec" "a sql spec" } { "obj" object } }
{ $description "" } ;
HELP: bind%
{ $values
- { "spec" null } }
+ { "spec" "a sql spec" } }
{ $description "" } ;
HELP: compound
HELP: modifiers
{ $values
- { "spec" null }
+ { "spec" "a sql spec" }
{ "string" string } }
{ $description "" } ;
HELP: normalize-spec
{ $values
- { "spec" null } }
+ { "spec" "a sql spec" } }
{ $description "" } ;
HELP: offset-of-slot
HELP: primary-key?
{ $values
- { "spec" null }
+ { "spec" "a sql spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: relation?
{ $values
- { "spec" null }
+ { "spec" "a sql spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: remove-db-assigned-id
{ $values
- { "specs" null }
+ { "specs" "a sequence of sql specs" }
{ "obj" object } }
{ $description "" } ;
HELP: remove-id
{ $values
- { "specs" null }
+ { "specs" "a sequence of sql specs" }
{ "obj" object } }
{ $description "" } ;
-HELP: remove-relations
-{ $values
- { "specs" null }
- { "newcolumns" null } }
-{ $description "" } ;
-
HELP: set-slot-named
{ $values
- { "value" null } { "name" null } { "obj" object } }
+ { "value" object } { "name" string } { "obj" object } }
{ $description "" } ;
HELP: spec>tuple
{ $values
- { "class" class } { "spec" null }
- { "tuple" null } }
+ { "class" class } { "spec" "a sql spec" }
+ { "tuple" tuple } }
{ $description "" } ;
HELP: sql-spec
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +db-assigned-id+? ] contains? ;
+ [ primary-key>> +db-assigned-id+? ] any? ;
: user-assigned-id-spec? ( specs -- ? )
- [ primary-key>> +user-assigned-id+? ] contains? ;
+ [ primary-key>> +user-assigned-id+? ] any? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
dup normalize-spec ;
: spec>tuple ( class spec -- tuple )
- 3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
+ 3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
: number>string* ( n/string -- string )
dup number? [ number>string ] when ;
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
-{ $subsection dlist-contains? }
+{ $subsection dlist-any? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if }
"This operation is O(n)."
} ;
-HELP: dlist-contains?
+HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
-[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-any? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-any? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
: dlist-find ( dlist quot -- obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-contains? ( dlist quot -- ? )
+: dlist-any? ( dlist quot -- ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
- [ = ] with dlist-contains? ;
+ [ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- )
{
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
-urls.encoding assocs xml.utilities ;
+urls.encoding assocs xml.utilities xml.data ;
IN: farkup.tests
relative-link-prefix off
: check-link-escaping ( string -- link )
convert-farkup string>xml-chunk
- "a" deep-tag-named "href" swap at url-decode ;
+ "a" deep-tag-named "href" attr url-decode ;
[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
TUPLE: line-break ;
: absolute-url? ( string -- ? )
- { "http://" "https://" "ftp://" } [ head? ] with contains? ;
+ { "http://" "https://" "ftp://" } [ head? ] with any? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" split1-last swap or ] unless ;
: check-url ( href -- href' )
{
{ [ dup empty? ] [ drop invalid-url ] }
- { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
+ { [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend "" like ]
parse-farkup (write-farkup) ;
: write-farkup ( string -- )
- farkup>xml write-xml-chunk ;
+ farkup>xml write-xml ;
: convert-farkup ( string -- string' )
[ write-farkup ] with-string-writer ;
"string. For example:\n"
{ $list
"\"%.3s\" formats a string to truncate at 3 characters (from the left)."
- "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point."
"\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
}
}
[ 0 ] [ string>number ] if-empty ;
: pad-digits ( string digits -- string' )
- [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
+ [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
10 swap ^ [ * round ] keep / ; inline
[ max-digits ] keep -rot
[
[ 0 < "-" "+" ? ]
- [ abs number>string 2 CHAR: 0 pad-left ] bi
+ [ abs number>string 2 CHAR: 0 pad-head ] bi
"e" -rot 3append
]
[ number>string ] bi*
char = "'" (.) => [[ second ]]
pad-char = (zero|char)? => [[ CHAR: \s or ]]
-pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]]
pad-width = ([0-9])* => [[ >digits ]]
pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
<PRIVATE
-: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
+: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
-: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
+: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline
: >time ( timestamp -- string )
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
: parse-list-11 ( lines -- seq )
[
- 11 f pad-right
+ 11 f pad-tail
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
WHERE
-: WW W twice ; inline
+: WW ( a -- b ) \ W twice ; inline
;FUNCTOR
\ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test
+
+<<
+
+FUNCTOR: wrapper-test-2 ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+: W ( a b -- c ) \ + execute ;
+
+;FUNCTOR
+
+"blah" wrapper-test-2
+
+>>
+
+[ 4 ] [ 1 3 blah ] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser
-locals.rewrite.closures vocabs.parser ;
+locals.rewrite.closures vocabs.parser arrays accessors ;
IN: functors
-: scan-param ( -- obj )
- scan-object dup special? [ literalize ] unless ;
+! This is a hack
+
+<PRIVATE
+
+: scan-param ( -- obj ) scan-object literalize ;
: define* ( word def effect -- ) pick set-word define-declared ;
+TUPLE: fake-quotation seq ;
+
+GENERIC: >fake-quotations ( quot -- fake )
+
+M: callable >fake-quotations
+ >array >fake-quotations fake-quotation boa ;
+
+M: array >fake-quotations [ >fake-quotations ] { } map-as ;
+
+M: object >fake-quotations ;
+
+GENERIC: fake-quotations> ( fake -- quot )
+
+M: fake-quotation fake-quotations>
+ seq>> [ fake-quotations> ] map >quotation ;
+
+M: array fake-quotations> [ fake-quotations> ] map ;
+
+M: object fake-quotations> ;
+
+: parse-definition* ( -- )
+ parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
: `TUPLE:
scan-param parsed
scan-param parsed
\ create-method parsed
- parse-definition parsed
+ parse-definition*
DEFINE* ; parsing
: `C:
: `:
effect off
scan-param parsed
- parse-definition parsed
+ parse-definition*
DEFINE* ; parsing
: `INSTANCE:
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
+PRIVATE>
+
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
DEFER: ;FUNCTOR delimiter
+<PRIVATE
+
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
parse-functor-body swap pop-locals <lambda>
rewrite-closures first ;
+PRIVATE>
+
: FUNCTOR: (FUNCTOR:) define ; parsing
} validate-params
{ "password" "new-password" "verify-password" }
- [ value empty? not ] contains? [
+ [ value empty? not ] any? [
"password" value username check-login
[ "incorrect password" validation-error ] unless
SYMBOL: permit-id\r
\r
: permit-id-key ( realm -- string )\r
- [ >hex 2 CHAR: 0 pad-left ] { } map-as concat\r
+ [ >hex 2 CHAR: 0 pad-head ] { } map-as concat\r
"__p_" prepend ;\r
\r
: client-permit-id ( realm -- id/f )\r
: base-path ( string -- pair )
dup responder-nesting get
- [ second class superclasses [ name>> = ] with contains? ] with find nip
+ [ second class superclasses [ name>> = ] with any? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
$predicate
$class-description
$error-description
- } swap '[ _ elements empty? not ] contains? ;
+ } swap '[ _ elements empty? not ] any? ;
: don't-check-word? ( word -- ? )
{
[ "Missing whitespace between strings" throw ] unless ;
: check-bogus-nl ( element -- )
- { { $nl } { { $nl } } } [ head? ] with contains?
+ { { $nl } { { $nl } } } [ head? ] with any?
[ "Simple element should not begin with a paragraph break" throw ] when ;
: check-elements ( element -- )
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
} cleave ;
+: check-descriptions ( element -- )
+ { $description $class-description $var-description }
+ swap '[
+ _ elements [
+ rest { { } { "" } } member?
+ [ "Empty description" throw ] when
+ ] each
+ ] each ;
+
: check-markup ( element -- )
{
[ check-elements ]
[ check-rendering ]
[ check-examples ]
[ check-modules ]
+ [ check-descriptions ]
} cleave ;
: all-word-help ( words -- seq )
[ f swap ]
if
] 2dip
- render* write-xml-chunk
+ render* write-xml
[ render-error ] when* ;
<PRIVATE
! HTML component
SINGLETON: html
-M: html render* 2drop string>xml-chunk ;
+M: html render* 2drop <unescaped> ;
-! cont-html v0.6
-!
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators present fry ;
+xml.data xml.interpolate urls math math.parser combinators
+present fry io.streams.string xml.writer ;
IN: html.elements
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title head-quot body-quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- spin
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head>
- <title> write </title>
- call
- </head>
- <body> call </body>
- </html> ; inline
+ [ with-string-writer <unescaped> ] bi@
+ <XML
+ <?xml version="1.0"?>
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title><-></title>
+ <->
+ </head>
+ <body><-></body>
+ </html>
+ XML> write-xml ; inline
: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
+ [XML <span class="error"><-></span> XML] write-xml ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
- [ drop url>> chloe-ns = ] assoc-filter ;
+ [ drop chloe-name? ] assoc-filter ;
: non-chloe-attrs-only ( assoc -- assoc' )
- [ drop url>> chloe-ns = not ] assoc-filter ;
+ [ drop chloe-name? not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
- { [ dup url>> chloe-ns = not ] [ f ] }
+ { [ dup chloe-name? not ] [ f ] }
[ t ]
} cond nip ;
: compile-start-tag ( tag -- )
"<" [write]
- [ name>string [write] ] [ compile-attrs ] bi
+ [ name>string [write] ] [ attrs>> compile-attrs ] bi
">" [write] ;
: compile-end-tag ( tag -- )
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
{ [ dup string? ] [ escape-string [write] ] }
{ [ dup comment? ] [ drop ] }
- [ [ write-xml-chunk ] [code-with] ]
+ [ [ write-xml ] [code-with] ]
} cond ;
: with-compiler ( quot -- quot' )
: compile-prologue ( xml -- )
[
- [ prolog>> [ write-prolog ] [code-with] ]
+ [ prolog>> [ write-xml ] [code-with] ]
[ before>> compile-chunk ]
bi
] compile-quot
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-: chloe-name ( string -- name )
- name new
- swap >>main
- chloe-ns >>url ;
+: chloe-name? ( name -- ? )
+ url>> chloe-ns = ;
+
+XML-NS: chloe-name http://factorcode.org/chloe/1.0
: required-attr ( tag name -- value )
- dup chloe-name rot at*
- [ nip ] [ drop " attribute is required" append throw ] if ;
+ tuck chloe-name attr
+ [ nip ] [ " attribute is required" append throw ] if* ;
: optional-attr ( tag name -- value )
- chloe-name swap at ;
+ chloe-name attr ;
math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
-io.encodings.utf8 io.encodings.8-bit io.encodings.binary
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
io.streams.duplex fry ascii urls urls.encoding present
http http.parsers http.client.post-data ;
IN: http.client
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
- read-crlf ";" split1 drop [ blank? ] trim-right
+ read-crlf ";" split1 drop [ blank? ] trim-tail
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunked ( quot: ( chunk -- ) -- )
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
-hashtables accessors namespaces ;
+hashtables accessors namespaces xml.data ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
3 a set-global
-: test-a string>xml "input" tag-named "value" swap at ;
+: test-a string>xml "input" tag-named "value" attr ;
[ "3" ] [
"http://localhost/" add-port http-get
calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary
-io.encodings.8-bit
+io.encodings.8-bit io.crlf
unicode.case unicode.categories
IN: http
-: crlf ( -- ) "\r\n" write ;
-
-: read-crlf ( -- bytes )
- "\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
-
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
io.encodings.ascii
io.encodings.binary
io.streams.limited
+io.streams.string
io.servers.connection
io.timeouts
+io.crlf
fry logging logging.insomniac calendar urls urls.encoding
mime.multipart
unicode.categories
[ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
- file-responder get root>> trim-right-separators\r
+ file-responder get root>> trim-tail-separators\r
"/"\r
- rot "" or trim-left-separators 3append ;\r
+ rot "" or trim-head-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
-M: unix (init-stdio) ( -- )
+M: unix (init-stdio)
<stdin> <input-port>
1 <fd> <output-port>
- 2 <fd> <output-port> ;
+ 2 <fd> <output-port> t ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;
tri
] with-destructors ;
-M: winnt (init-stdio) init-c-stdio ;
+: console-app? ( -- ? ) GetConsoleWindow >boolean ;
+
+M: winnt (init-stdio)
+ console-app? [ init-c-stdio t ] [ f f f f ] if ;
winnt set-io-backend
--- /dev/null
+Daniel Ehrenberg
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup sequences ;
+IN: io.crlf
+
+HELP: crlf
+{ $values }
+{ $description "Prints a carriage return and line feed to the current output stream, used to indicate a newline for certain network protocols." } ;
+
+HELP: read-crlf
+{ $values { "seq" sequence } }
+{ $description "Reads until the next CRLF (carriage return followed by line feed) from the current input stream, throwing an error if there is not a CRLF remaining, or if CR is present without immediately being followed by LF." } ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel ;
+IN: io.crlf
+
+: crlf ( -- )
+ "\r\n" write ;
+
+: read-crlf ( -- seq )
+ "\r" read-until
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
--- /dev/null
+Writing and reading until \r\n
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-path trim-right-separators {
+ normalize-path trim-tail-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
{
{ [ os unix? ] [ "io.directories.unix" require ] }
{ [ os windows? ] [ "io.directories.windows" require ] }
-} cond
\ No newline at end of file
+} cond
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
-ARTICLE: "io.directories.search" "io.directories.search"
+ARTICLE: "io.directories.search" "Searching directories"
"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
"Traversing directories:"
{ $subsection recursive-directory }
[ t ] [ "\\\\" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
+[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
{
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
- { [ dup trim-right-separators { [ length 2 = ]
+ { [ dup trim-tail-separators { [ length 2 = ]
[ second CHAR: : = ] } 1&& ] [ drop t ] }
{ [ dup unicode-prefix head? ]
- [ trim-right-separators length unicode-prefix length 2 + = ] }
+ [ trim-tail-separators length unicode-prefix length 2 + = ] }
[ drop f ]
} cond ;
WHERE
: <mapped-A> ( mapped-file -- direct-array )
- T mapped-file>direct <A> execute ; inline
+ T mapped-file>direct <A> ; inline
: with-mapped-A-file ( path length quot -- )
- '[ <mapped-A> execute @ ] with-mapped-file ; inline
+ '[ <mapped-A> @ ] with-mapped-file ; inline
;FUNCTOR
HELP: with-mapped-file
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: close-mapped-file
USING: io.monitors tools.test io.files io.files.temp
io.directories system sequences continuations namespaces
concurrency.count-downs kernel io threads calendar prettyprint
-destructors io.timeouts ;
+destructors io.timeouts accessors ;
! On Linux, a notification on the directory itself would report an invalid
! path name
"m" get next-change path>>
dup print flush
dup parent-directory
- [ trim-right-separators "xyz" tail? ] either? not
+ [ trim-tail-separators "xyz" tail? ] either? not
] loop
"c1" get count-down
"m" get next-change path>>
dup print flush
dup parent-directory
- [ trim-right-separators "yxy" tail? ] either? not
+ [ trim-tail-separators "yxy" tail? ] either? not
] loop
"c2" get count-down
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: io help.markup help.syntax quotations ;
-IN: io.streams.null
-
-HELP: null-reader
-{ $class-description "Singleton class of null reader streams." } ;
-
-HELP: null-writer
-{ $class-description "Singleton class of null writer streams." } ;
-
-HELP: with-null-reader
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
-
-HELP: with-null-writer
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
-
-ARTICLE: "io.streams.null" "Null streams"
-"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
-$nl
-"Null readers:"
-{ $subsection null-reader }
-{ $subsection with-null-writer }
-"Null writers:"
-{ $subsection null-writer }
-{ $subsection with-null-reader } ;
-
-ABOUT: "io.streams.null"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2007, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io io.timeouts io.styles destructors ;
-IN: io.streams.null
-
-SINGLETONS: null-reader null-writer ;
-UNION: null-stream null-reader null-writer ;
-
-M: null-stream dispose drop ;
-M: null-stream set-timeout 2drop ;
-
-M: null-reader stream-readln drop f ;
-M: null-reader stream-read1 drop f ;
-M: null-reader stream-read-until 2drop f f ;
-M: null-reader stream-read 2drop f ;
-
-M: null-writer stream-write1 2drop ;
-M: null-writer stream-write 2drop ;
-M: null-writer stream-nl drop ;
-M: null-writer stream-flush drop ;
-M: null-writer stream-format 3drop ;
-M: null-writer make-span-stream nip ;
-M: null-writer make-block-stream nip ;
-M: null-writer make-cell-stream nip ;
-M: null-writer stream-write-table 3drop ;
-
-: with-null-reader ( quot -- )
- null-reader swap with-input-stream* ; inline
-
-: with-null-writer ( quot -- )
- null-writer swap with-output-stream* ; inline
\ No newline at end of file
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
+ swap [ CHAR: \s pad-tail ] curry map
] unless ;
: map-last ( seq quot -- seq )
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel calendar alarms io io.encodings accessors\r
-namespaces fry ;\r
+namespaces fry io.streams.null ;\r
IN: io.timeouts\r
\r
GENERIC: timeout ( obj -- dt/f )\r
: timeouts ( dt -- )\r
[ input-stream get set-timeout ]\r
[ output-stream get set-timeout ] bi ;\r
+\r
+M: null-stream set-timeout 2drop ;\r
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
IN: lcs.diff2html.tests
-[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test
+[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
-ARTICLE: "locals-literals" "Locals in array and hashtable literals"
+ARTICLE: "locals-literals" "Locals in literals"
"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
$nl
"The data types which receive this special handling are the following:"
{ $link "hashtables" }
{ $link "vectors" }
{ $link "tuples" }
+ { $link "wrappers" }
}
+{ $heading "Object identity" }
"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
{ $example
"IN: scratchpad"
"f"
}
"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
-$nl
+{ $heading "Example" }
"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
! Discovered by littledan
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
-[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
\ No newline at end of file
+[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
+
+[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
+
+[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
+
+[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
\ No newline at end of file
! We special-case all the :> at the start of a quotation
: load-locals-quot ( args -- quot )
[ [ ] ] [
- dup [ local-reader? ] contains? [
+ dup [ local-reader? ] any? [
dup [ local-reader? [ 1array ] [ ] ? ] map
spread>quot
] [ [ ] ] if swap length [ load-locals ] curry append
M: special rewrite-literal? drop t ;
-M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+M: array rewrite-literal? [ rewrite-literal? ] any? ;
-M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
-M: wrapper rewrite-literal? drop t ;
+M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
M: hashtable rewrite-literal? drop t ;
[ rewrite-element ] each ;
: rewrite-sequence ( seq -- )
- [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
+ [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
- [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
+ [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
M: quotation rewrite-element rewrite-sugar* ;
M: local-word rewrite-element
local-word-in-literal-error ;
-M: word rewrite-element literalize , ;
+M: word rewrite-element <wrapper> , ;
+
+: rewrite-wrapper ( wrapper -- )
+ dup rewrite-literal?
+ [ wrapped>> rewrite-element ] [ , ] if ;
M: wrapper rewrite-element
- dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
+ rewrite-wrapper \ <wrapper> , ;
M: object rewrite-element , ;
M: hashtable rewrite-sugar* rewrite-element ;
-M: wrapper rewrite-sugar* rewrite-element ;
+M: wrapper rewrite-sugar*
+ rewrite-wrapper ;
M: word rewrite-sugar*
dup { load-locals get-local drop-locals } memq?
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel sequences words ;
+USING: accessors combinators kernel sequences words
+quotations ;
IN: locals.types
TUPLE: lambda vars body ;
f <word>
dup t "local?" set-word-prop ;
+M: local literalize ;
+
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word>
dup t "local-reader?" set-word-prop ;
+M: local-reader literalize ;
+
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
math
bindings
-unportable
M: MATRIX element-type
drop TYPE ;
M: MATRIX (blas-matrix-like)
- drop <MATRIX> execute ;
+ drop <MATRIX> ;
M: VECTOR (blas-matrix-like)
- drop <MATRIX> execute ;
+ drop <MATRIX> ;
M: MATRIX (blas-vector-like)
- drop <VECTOR> execute ;
+ drop <VECTOR> ;
: >MATRIX ( arrays -- matrix )
- [ >ARRAY execute underlying>> ] (>matrix)
- <MATRIX> execute ;
+ [ >ARRAY underlying>> ] (>matrix)
+ <MATRIX> ;
M: VECTOR n*M.V+n*V!
- [ TYPE>ARG execute ] (prepare-gemv)
- [ XGEMV execute ] dip ;
+ [ TYPE>ARG ] (prepare-gemv)
+ [ XGEMV ] dip ;
M: MATRIX n*M.M+n*M!
- [ TYPE>ARG execute ] (prepare-gemm)
- [ XGEMM execute ] dip ;
+ [ TYPE>ARG ] (prepare-gemm)
+ [ XGEMM ] dip ;
M: MATRIX n*V(*)V+M!
- [ TYPE>ARG execute ] (prepare-ger)
- [ XGERU execute ] dip ;
+ [ TYPE>ARG ] (prepare-ger)
+ [ XGERU ] dip ;
M: MATRIX n*V(*)Vconj+M!
- [ TYPE>ARG execute ] (prepare-ger)
- [ XGERC execute ] dip ;
+ [ TYPE>ARG ] (prepare-ger)
+ [ XGERC ] dip ;
;FUNCTOR
math
bindings
-unportable
USING: kernel math.blas.vectors math.blas.matrices parser
-arrays prettyprint.backend sequences ;
+arrays prettyprint.backend prettyprint.custom sequences ;
IN: math.blas.syntax
: svector{
: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
: >VECTOR ( seq -- v )
- [ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
+ [ >ARRAY underlying>> ] [ length ] bi 1 <VECTOR> ;
M: VECTOR clone
TYPE heap-size (prepare-copy)
- [ XCOPY execute ] 3dip <VECTOR> execute ;
+ [ XCOPY ] 3dip <VECTOR> ;
M: VECTOR element-type
drop TYPE ;
M: VECTOR Vswap
- (prepare-swap) [ XSWAP execute ] 2dip ;
+ (prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax
- (prepare-nrm2) IXAMAX execute ;
+ (prepare-nrm2) IXAMAX ;
M: VECTOR (blas-vector-like)
- drop <VECTOR> execute ;
+ drop <VECTOR> ;
M: VECTOR (blas-direct-array)
[ underlying>> ]
[ [ length>> ] [ inc>> ] bi * ] bi
- <DIRECT-ARRAY> execute ;
+ <DIRECT-ARRAY> ;
;FUNCTOR
WHERE
M: VECTOR V.
- (prepare-dot) XDOT execute ;
+ (prepare-dot) XDOT ;
M: VECTOR V.conj
- (prepare-dot) XDOT execute ;
+ (prepare-dot) XDOT ;
M: VECTOR Vnorm
- (prepare-nrm2) XNRM2 execute ;
+ (prepare-nrm2) XNRM2 ;
M: VECTOR Vasum
- (prepare-nrm2) XASUM execute ;
+ (prepare-nrm2) XASUM ;
M: VECTOR n*V+V!
- (prepare-axpy) [ XAXPY execute ] dip ;
+ (prepare-axpy) [ XAXPY ] dip ;
M: VECTOR n*V!
- (prepare-scal) [ XSCAL execute ] dip ;
+ (prepare-scal) [ XSCAL ] dip ;
;FUNCTOR
WHERE
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
- 1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
+ 1 shift <DIRECT-ARRAY> <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence )
- <complex-components> >ARRAY execute ;
+ <complex-components> >ARRAY ;
: COMPLEX>ARG ( complex -- alien )
- >rect 2array >ARRAY execute underlying>> ;
+ >rect 2array >ARRAY underlying>> ;
: ARG>COMPLEX ( alien -- complex )
- 2 <DIRECT-ARRAY> execute first2 rect> ;
+ 2 <DIRECT-ARRAY> first2 rect> ;
;FUNCTOR
M: VECTOR V.
(prepare-dot) TYPE <c-object>
- [ XDOTU_SUB execute ] keep
- ARG>TYPE execute ;
+ [ XDOTU_SUB ] keep
+ ARG>TYPE ;
M: VECTOR V.conj
(prepare-dot) TYPE <c-object>
- [ XDOTC_SUB execute ] keep
- ARG>TYPE execute ;
+ [ XDOTC_SUB ] keep
+ ARG>TYPE ;
M: VECTOR Vnorm
- (prepare-nrm2) XXNRM2 execute ;
+ (prepare-nrm2) XXNRM2 ;
M: VECTOR Vasum
- (prepare-nrm2) XXASUM execute ;
+ (prepare-nrm2) XXASUM ;
M: VECTOR n*V+V!
- [ TYPE>ARG execute ] 2dip
- (prepare-axpy) [ XAXPY execute ] dip ;
+ [ TYPE>ARG ] 2dip
+ (prepare-axpy) [ XAXPY ] dip ;
M: VECTOR n*V!
- [ TYPE>ARG execute ] dip
- (prepare-scal) [ XSCAL execute ] dip ;
+ [ TYPE>ARG ] dip
+ (prepare-scal) [ XSCAL ] dip ;
;FUNCTOR
reverse 1 cut [ (>permutation) ] each ;
: permutation-indices ( n seq -- permutation )
- length [ factoradic ] dip 0 pad-left >permutation ;
+ length [ factoradic ] dip 0 pad-head >permutation ;
PRIVATE>
[ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval )
- dup [ first fp-nan? ] contains?
+ dup [ first fp-nan? ] any?
[ drop [-inf,inf] ] [
dup first
[ [ endpoint-min ] reduce ]
<PRIVATE
-: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
-: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
-: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
-: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
+: 2pad-head ( p q n -- p q ) [ 0 pad-head ] curry bi@ ;
+: 2pad-tail ( p q n -- p q ) [ 0 pad-tail ] curry bi@ ;
+: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-tail ;
+: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-head ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
: p= ( p q -- ? ) pextend = ;
: ptrim ( p -- p )
- dup length 1 = [ [ zero? ] trim-right ] unless ;
+ dup length 1 = [ [ zero? ] trim-tail ] unless ;
: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
: p+ ( p q -- r ) pextend v+ ;
: n*p ( n p -- n*p ) n*v ;
: pextend-conv ( p q -- p q )
- 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
+ 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
2unempty pextend-conv <reversed> dup length
2ptrim
2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
- [ over length + 0 pad-left pextend ] keep 1+ ;
+ [ over length + 0 pad-head pextend ] keep 1+ ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
-USING: math.ranges sequences tools.test arrays ;
+USING: math math.ranges sequences sets tools.test arrays ;
IN: math.ranges.tests
[ { } ] [ 1 1 (a,b) >array ] unit-test
[ { 1 } ] [ 1 2 [a,b) >array ] unit-test
[ { 1 2 } ] [ 1 2 [a,b] >array ] unit-test
-[ { } ] [ 2 1 (a,b) >array ] unit-test
+[ { } ] [ 2 1 (a,b) >array ] unit-test
[ { 1 } ] [ 2 1 (a,b] >array ] unit-test
[ { 2 } ] [ 2 1 [a,b) >array ] unit-test
[ { 2 1 } ] [ 2 1 [a,b] >array ] unit-test
[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test
+
+[ 100 ] [
+ 1 100 [a,b] [ 2^ [1,b] ] map prune length
+] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
-sequences.private accessors ;
+sequences.private accessors classes.tuple arrays ;
IN: math.ranges
TUPLE: range
M: range nth-unsafe ( n range -- obj )
[ step>> * ] keep from>> + ;
+! For ranges with many elements, the default element-wise methods
+! sequences define are unsuitable because they're O(n)
+M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
+
+M: range hashcode* tuple-hashcode ;
+
INSTANCE: range immutable-sequence
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
CONSTANT: GL_RGB HEX: 1907
CONSTANT: GL_RGBA HEX: 1908
+! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt
+CONSTANT: GL_BGR_EXT HEX: 80E0
+CONSTANT: GL_BGRA_EXT HEX: 80E1
+
! Implementation limits
CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
- input-slice [ blank? ] trim-left-slice input-from pos set @
+ input-slice [ blank? ] trim-head-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings byte-arrays io.encodings.string ;
+IN: quoted-printable
+
+ABOUT: "quoted-printable"
+
+ARTICLE: "quoted-printable" "Quoted printable encoding"
+"The " { $vocab-link "quoted-printable" } " vocabulary implements RFC 2045 part 6.7, providing words for reading and generating quotable printed text."
+{ $subsection >quoted }
+{ $subsection >quoted-lines }
+{ $subsection quoted> } ;
+
+HELP: >quoted
+{ $values { "byte-array" byte-array } { "string" string } }
+{ $description "Encodes a byte array as quoted printable, on a single line." }
+{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word." } ;
+
+HELP: >quoted-lines
+{ $values { "byte-array" byte-array } { "string" string } }
+{ $description "Encodes a byte array as quoted printable, with soft line breaks inserted so the output lines are no longer than 76 characters." }
+{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word with a specific encoding." } ;
+
+HELP: quoted>
+{ $values { "string" string } { "byte-array" byte-array } }
+{ $description "Decodes a quoted printable string into an array of the bytes represented." }
+{ $warning "When decoding something in quoted printable form and using it as a string, be sure to use the " { $link decode } " word rather than simply converting the byte array to a string." } ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test quoted-printable multiline io.encodings.string
+sequences io.encodings.8-bit splitting kernel ;
+IN: quoted-printable.tests
+
+[ <" José was the
+person who knew how to write the letters:
+ ő and ü
+and we didn't know hów tö do thât"> ]
+[ <" Jos=E9 was the
+person who knew how to write the letters:
+ =F5 and =FC=20
+and w=
+e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test
+
+[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ]
+[ <" José was the
+person who knew how to write the letters:
+ ő and ü
+and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test
+
+: message ( -- str )
+ 55 [ "hello" ] replicate concat ;
+
+[ f ] [ message >quoted "=\r\n" swap subseq? ] unit-test
+[ 1 ] [ message >quoted string-lines length ] unit-test
+[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test
+[ 4 ] [ message >quoted-lines string-lines length ] unit-test
+[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences strings kernel io.encodings.string
+math.order ascii math io io.encodings.utf8 io.streams.string
+combinators.short-circuit math.parser arrays ;
+IN: quoted-printable
+
+! This implements RFC 2045 section 6.7
+
+<PRIVATE
+
+: assure-small ( ch -- ch )
+ dup 256 <
+ [ "Cannot quote a character greater than 255" throw ] unless ;
+
+: printable? ( ch -- ? )
+ {
+ [ CHAR: \s CHAR: < between? ]
+ [ CHAR: > CHAR: ~ between? ]
+ [ CHAR: \t = ]
+ } 1|| ;
+
+: char>quoted ( ch -- str )
+ dup printable? [ 1string ] [
+ assure-small >hex >upper
+ 2 CHAR: 0 pad-head
+ CHAR: = prefix
+ ] if ;
+
+: take-some ( seqs -- seqs seq )
+ 0 over [ length + dup 76 >= ] find drop nip
+ [ 1- cut-slice swap ] [ f swap ] if* concat ;
+
+: divide-lines ( strings -- strings )
+ [ dup ] [ take-some ] [ ] produce nip ;
+
+PRIVATE>
+
+: >quoted ( byte-array -- string )
+ [ char>quoted ] { } map-as concat "" like ;
+
+: >quoted-lines ( byte-array -- string )
+ [ char>quoted ] { } map-as
+ divide-lines "=\r\n" join ;
+
+<PRIVATE
+
+: read-char ( byte -- ch )
+ dup CHAR: = = [
+ drop read1 dup CHAR: \n =
+ [ drop read1 read-char ]
+ [ read1 2array hex> ] if
+ ] when ;
+
+: read-quoted ( -- bytes )
+ [ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ;
+
+PRIVATE>
+
+: quoted> ( string -- byte-array )
+ ! Input should already be normalized to make \r\n into \n
+ [ read-quoted ] with-string-reader ;
--- /dev/null
+Quoted printable encoding/decoding
--- /dev/null
+parsing
+web
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
{ $see-also find } ;
-HELP: deep-contains?
+HELP: deep-any?
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
-{ $see-also contains? } ;
+{ $see-also any? } ;
HELP: flatten
{ $values { "obj" object } { "seq" "a sequence" } }
{ $subsection deep-map }
{ $subsection deep-filter }
{ $subsection deep-find }
-{ $subsection deep-contains? }
+{ $subsection deep-any? }
{ $subsection deep-change-each }
"A utility word to collapse nested subsequences:"
{ $subsection flatten } ;
[ { { "heyhello" "hihello" } } ]
[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test
-[ t ] [ "foo" [ string? ] deep-contains? ] unit-test
+[ t ] [ "foo" [ string? ] deep-any? ] unit-test
[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
-: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
+: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
- '[ @ not ] deep-contains? not ; inline
+ '[ @ not ] deep-any? not ; inline
: deep-member? ( obj seq -- ? )
swap '[
namespaces io.sockets io.sockets.secure continuations calendar
io.encodings.ascii io.streams.duplex destructors locals
concurrency.promises threads accessors smtp.private
-io.sockets.secure.unix.debug ;
+io.sockets.secure.unix.debug io.crlf ;
IN: smtp.server
! Mock SMTP server for testing purposes.
io.encodings.ascii kernel logging sequences combinators
splitting assocs strings math.order math.parser random system
calendar summary calendar.format accessors sets hashtables
-base64 debugger classes prettyprint ;
+base64 debugger classes prettyprint io.crlf ;
IN: smtp
SYMBOL: smtp-domain
<PRIVATE
-: crlf ( -- ) "\r\n" write ;
-
-: read-crlf ( -- bytes )
- "\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
-
: command ( string -- ) write crlf flush ;
\ command DEBUG add-input-logging
[ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
: first>upper ( seq -- seq' ) 1 head >upper ;
-: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ;
+: trim-first ( seq -- seq' ) dup first [ = ] curry trim-head ;
: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
: pad-4 ( first seq -- seq' ) "000" 3append 4 head ;
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
M: A set-nth-unsafe underlying>> SET-NTH call ;
-M: A like drop dup A instance? [ >A' execute ] unless ;
-M: A new-sequence drop <A'> execute ;
+M: A like drop dup A instance? [ >A' ] unless ;
+M: A new-sequence drop <A'> ;
INSTANCE: A sequence
: >A ( seq -- specialized-array ) A new clone-like ; inline
-M: A like drop dup A instance? [ >A execute ] unless ;
+M: A like drop dup A instance? [ >A ] unless ;
-M: A new-sequence drop (A) execute ;
+M: A new-sequence drop (A) ;
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
M: A byte-length underlying>> length ;
-M: A pprint-delims drop A{ \ } ;
+M: A pprint-delims drop \ A{ \ } ;
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
-: A{ \ } [ >A execute ] parse-literal ; parsing
+: A{ \ } [ >A ] parse-literal ; parsing
INSTANCE: A sequence
TUPLE: V { underlying A } { length array-capacity } ;
-: <V> ( capacity -- vector ) <A> execute 0 V boa ; inline
+: <V> ( capacity -- vector ) <A> 0 V boa ; inline
M: V like
drop dup V instance? [
- dup A instance? [ dup length V boa ] [ >V execute ] if
+ dup A instance? [ dup length V boa ] [ >V ] if
] unless ;
-M: V new-sequence drop [ <A> execute ] [ >fixnum ] bi V boa ;
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
-M: A new-resizable drop <V> execute ;
+M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
-M: V pprint-delims drop V{ \ } ;
+M: V pprint-delims drop \ V{ \ } ;
M: V >pprint-sequence ;
M: V pprint* pprint-object ;
-: V{ \ } [ >V execute ] parse-literal ; parsing
+: V{ \ } [ >V ] parse-literal ; parsing
INSTANCE: V growable
{
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
- [ def>> [ word? ] contains? ]
+ [ def>> [ word? ] any? ]
} cond ;
: ?missing-effect ( word -- )
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
- '[ _ +bottom+ pad-left ] map
+ '[ _ +bottom+ pad-head ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq )
(infer-if)
] [
drop 2 consume-d
- dup [ known [ curried? ] [ composed? ] bi or ] contains? [
+ dup [ known [ curried? ] [ composed? ] bi or ] any? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
#! Can we use a fast byte array test here?
{
{ [ dup length 8 < ] [ f ] }
- { [ dup [ integer? not ] contains? ] [ f ] }
- { [ dup [ 0 < ] contains? ] [ f ] }
- { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+ { [ dup [ integer? not ] any? ] [ f ] }
+ { [ dup [ 0 < ] any? ] [ f ] }
+ { [ dup [ bit-member-n >= ] any? ] [ f ] }
[ t ]
} cond nip ;
tri ;
: atom-entry-link ( tag -- url/f )
- "link" tags-named [ "rel" swap at "alternate" = ] find nip
- dup [ "href" swap at >url ] when ;
+ "link" tags-named [ "rel" attr "alternate" = ] find nip
+ dup [ "href" attr >url ] when ;
: atom1.0-entry ( tag -- entry )
entry new
[ atom-entry-link >>url ]
[
{ "content" "summary" } any-tag-named
- dup children>> [ string? not ] contains?
- [ children>> [ write-xml-chunk ] with-string-writer ]
+ dup children>> [ string? not ] any?
+ [ children>> xml>string ]
[ children>string ] if >>description
]
[
feed new
swap
[ "title" tag-named children>string >>title ]
- [ "link" tag-named "href" swap at >url >>url ]
+ [ "link" tag-named "href" attr >url >>url ]
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
tri ;
"resource:basis/tools/crossref/test/foo.factor" run-file
[ t ] [ integer \ foo method \ + usage member? ] unit-test
-[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
+[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
dup [ second length ] map supremum
'[
[
- [ first >hex cell 2 * CHAR: 0 pad-left % ": " % ]
- [ second _ CHAR: \s pad-right % " " % ]
+ [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
+ [ second _ CHAR: \s pad-tail % " " % ]
[ third % ]
tri
] "" make
: dir-or-size ( file-info -- str )
dup directory? [
- drop "<DIR>" 20 CHAR: \s pad-right
+ drop "<DIR>" 20 CHAR: \s pad-tail
] [
- size>> number>string 20 CHAR: \s pad-left
+ size>> number>string 20 CHAR: \s pad-head
] if ;
: listing-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
- [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
+ [ number>string 2 CHAR: 0 pad-head ] bi@ ":" glue ;
: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
- [ day>> number>string 2 CHAR: \s pad-left ]
+ [ day>> number>string 2 CHAR: \s pad-head ]
[
dup year>> dup now year>> =
[ drop listing-time ] [ nip number>string ] if
- 5 CHAR: \s pad-left
+ 5 CHAR: \s pad-head
] tri 3array " " join ;
: read>string ( ? -- string ) "r" "-" ? ; inline
[ >hex write "h" write nl ] bi ;
: write-offset ( lineno -- )
- 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
+ 16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-left " " append ;
+ >hex 2 CHAR: 0 pad-head " " append ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+ [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
-: contains-separator? ( string -- ? ) [ path-separator? ] contains? ;
+: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
: check-vocab-name ( string -- string )
dup contains-dot? [ vocab-name-contains-dot ] when
] if ;
: lookup-type ( string -- object/string ? )
- "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right
+ "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail
H{
{ "object" object } { "obj" object }
{ "quot" quotation }
TR: convert-separators "/\\" ".." ;\r
\r
: vocab-dir>vocab-name ( path -- vocab )\r
- trim-left-separators\r
- trim-right-separators\r
+ trim-head-separators\r
+ trim-tail-separators\r
convert-separators ;\r
\r
: path>vocab-name ( path -- vocab )\r
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with contains? ;
+ [ x-atom = ] with any? ;
: clipboard-for-atom ( atom -- clipboard )
{
-USING: help.syntax help.markup strings byte-arrays ;
+USING: help.syntax help.markup strings byte-arrays math.order ;
IN: unicode.collation
ARTICLE: "unicode.collation" "Collation and weak comparison"
-"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
+"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are useful for collation directly:"
{ $subsection sort-strings }
{ $subsection collation-key }
{ $subsection string<=> }
+"Predicates for weak equality testing:"
{ $subsection primary= }
{ $subsection secondary= }
{ $subsection tertiary= }
ABOUT: "unicode.collation"
HELP: sort-strings
-{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
-{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
+{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in lexicographical order" } }
+{ $description "This word takes a sequence of strings and sorts them according to the Unicode Collation Algorithm with the default collation order described in the DUCET. It uses code point order as a tie-breaker." } ;
HELP: collation-key
{ $values { "string" string } { "key" byte-array } }
-{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ;
+{ $description "This takes a string and gives a representation of the collation key, which can be compared with " { $link <=> } ". The representation is according to the DUCET." } ;
HELP: string<=>
{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } }
HELP: primary=
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
-{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ;
+{ $description "This checks whether the first level of collation key is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation, whitespace and accent marks." } ;
HELP: secondary=
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
-{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ;
+{ $description "This checks whether the first two levels of collation key are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to " { $link primary= } "." } ;
HELP: tertiary=
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
-{ $description "Along the same lines as secondary=, but case is significant." } ;
+{ $description "This checks if the first three levels of collation key are equal. For Latin-based scripts, it can be understood as testing for what " { $link secondary= } " tests for, but case is significant." } ;
HELP: quaternary=
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
-{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
+{ $description "This checks if the first four levels of collation key are equal. This is similar to " { $link tertiary= } " but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
dup possible-bases dup length\r
- [ ?combine ] with with contains?\r
+ [ ?combine ] with with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
\r
: insensitive= ( str1 str2 levels-removed -- ? )\r
[\r
[ collation-key ] dip\r
- [ [ 0 = not ] trim-right but-last ] times\r
+ [ [ 0 = not ] trim-tail but-last ] times\r
] curry bi@ = ;\r
PRIVATE>\r
\r
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-right hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
: remove-exclusions ( alist -- alist )
exclusions [ dup ] H{ } map>assoc assoc-diff ;
HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
: memory>string ( alien n -- string )
- memory>byte-array utf8 decode [ 0 = ] trim-right ;
+ memory>byte-array utf8 decode [ 0 = ] trim-tail ;
M: unix new-utmpx-record
utmpx-record new ;
: push-utf8 ( ch -- )
1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+ [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ;
PRIVATE>
] dip 76 shift bitor ;
: uuid>string ( n -- string )
- >hex 32 CHAR: 0 pad-left
+ >hex 32 CHAR: 0 pad-head
[ CHAR: - 20 ] dip insert-nth
[ CHAR: - 16 ] dip insert-nth
[ CHAR: - 12 ] dip insert-nth
! FUNCTION: AddRefActCtx
! FUNCTION: AddVectoredExceptionHandler
! FUNCTION: AllocateUserPhysicalPages
-! FUNCTION: AllocConsole
+FUNCTION: BOOL AllocConsole ( ) ;
! FUNCTION: AreFileApisANSI
! FUNCTION: AssignProcessToJobObject
! FUNCTION: AttachConsole
! FUNCTION: FoldStringW
! FUNCTION: FormatMessageA
! FUNCTION: FormatMessageW
-! FUNCTION: FreeConsole
+FUNCTION: BOOL FreeConsole ( ) ;
! FUNCTION: FreeEnvironmentStringsA
FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
! FUNCTION: GetConsoleSelectionInfo
FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ;
ALIAS: GetConsoleTitle GetConsoleTitleW
-! FUNCTION: GetConsoleWindow
+FUNCTION: HWND GetConsoleWindow ( ) ;
! FUNCTION: GetCPFileNameFromRegistry
! FUNCTION: GetCPInfo
! FUNCTION: GetCPInfoExA
] keep ;
: (guid-section%) ( guid quot len -- )
- [ call >hex ] dip CHAR: 0 pad-left % ; inline
+ [ call >hex ] dip CHAR: 0 pad-head % ; inline
: (guid-byte%) ( guid byte -- )
- swap nth >hex 2 CHAR: 0 pad-left % ; inline
+ swap nth >hex 2 CHAR: 0 pad-head % ; inline
: guid>string ( guid -- string )
[
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces xml.name io.encodings.utf8 xml.elements
io.encodings.utf16 xml.tokenize xml.state math ascii sequences
-io.encodings.string io.encodings combinators ;
+io.encodings.string io.encodings combinators accessors
+xml.data io.encodings.iana ;
IN: xml.autoencoding
: continue-make-tag ( str -- tag )
parse-name-starting middle-tag end-tag ;
: start-utf16le ( -- tag )
- utf16le decode-input-if
+ utf16le decode-input
"?\0" expect
check instruct ;
-6 shift 3 bitand 2 = ;
: start<name ( ch -- tag )
+ ! This is unfortunate, and exists for the corner case
+ ! that the first letter of the document is < and second is
+ ! not ASCII
ascii?
- [ utf8 decode-input-if next make-tag ] [
+ [ utf8 decode-input next make-tag ] [
next
[ get-next 10xxxxxx? not ] take-until
get-char suffix utf8 decode
- utf8 decode-input-if next
+ utf8 decode-input next
continue-make-tag
] if ;
-
+
+: prolog-encoding ( prolog -- )
+ encoding>> dup "UTF-16" =
+ [ drop ] [ name>encoding [ decode-input ] when* ] if ;
+
+: instruct-encoding ( instruct/prolog -- )
+ dup prolog?
+ [ prolog-encoding ]
+ [ drop utf8 decode-input ] if ;
+
+: go-utf8 ( -- )
+ check utf8 decode-input next next ;
+
: start< ( -- tag )
+ ! What if first letter of processing instruction is non-ASCII?
get-next {
{ 0 [ next next start-utf16le ] }
- { CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding
- { CHAR: ! [ check utf8 decode-input next next direct ] }
+ { CHAR: ? [ go-utf8 instruct dup instruct-encoding ] }
+ { CHAR: ! [ go-utf8 direct ] }
[ check start<name ]
} case ;
"<" expect check make-tag ;
: decode-expecting ( encoding string -- tag )
- [ decode-input-if next ] [ expect ] bi* check make-tag ;
+ [ decode-input next ] [ expect ] bi* check make-tag ;
: start-utf16be ( -- tag )
utf16be "<" decode-expecting ;
{ HEX: EF [ skip-utf8-bom ] }
{ HEX: FF [ skip-utf16le-bom ] }
{ HEX: FE [ skip-utf16be-bom ] }
- { f [ "" ] }
- [ drop utf8 decode-input-if f ]
- ! Same problem as with <e`>, in the case of XML chunks?
- } case check ;
+ [ drop utf8 decode-input check f ]
+ } case ;
! 1.1:
! [#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
{
- { [ dup HEX: 20 < ] [ "\t\r\n" member? and ] }
+ { [ dup HEX: 20 < ] [ swap [ "\t\r\n" member? ] [ zero? not ] if ] }
{ [ nip dup HEX: D800 < ] [ drop t ] }
{ [ dup HEX: E000 < ] [ drop f ] }
[ { HEX: FFFE HEX: FFFF } member? not ]
"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
ARTICLE: { "xml.data" "classes" } "XML data classes"
- "Data types that XML documents are made of:"
- { $subsection name }
+ "XML documents and chunks are made of the following classes:"
+ { $subsection xml }
+ { $subsection xml-chunk }
{ $subsection tag }
+ { $subsection name }
{ $subsection contained-tag }
{ $subsection open-tag }
- { $subsection xml }
{ $subsection prolog }
{ $subsection comment }
{ $subsection instruction }
+ { $subsection unescaped }
{ $subsection element-decl }
{ $subsection attlist-decl }
{ $subsection entity-decl }
ARTICLE: { "xml.data" "constructors" } "XML data constructors"
"These data types are constructed with:"
- { $subsection <name> }
+ { $subsection <xml> }
+ { $subsection <xml-chunk> }
{ $subsection <tag> }
+ { $subsection <name> }
{ $subsection <contained-tag> }
- { $subsection <xml> }
{ $subsection <prolog> }
{ $subsection <comment> }
{ $subsection <instruction> }
+ { $subsection <unescaped> }
{ $subsection <simple-name> }
{ $subsection <element-decl> }
{ $subsection <attlist-decl> }
HELP: <xml>
{ $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" }
{ "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } }
-{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" }
+{ $description "Creates an XML document. The " { $snippet "before" } " and " { $snippet "after" } " slots store what comes before and after the main tag, and " { $snippet "body" } "contains the main tag itself." }
{ $see-also xml <tag> } ;
HELP: prolog
HELP: <prolog>
{ $values { "version" "a string, 1.0 or 1.1" }
{ "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } }
-{ $description "creates an XML prolog tuple" }
+{ $description "Creates an XML prolog tuple." }
{ $see-also prolog <xml> } ;
HELP: comment
-{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" }
+{ $class-description "Represents a comment in XML. This tuple has one slot, " { $snippet "text" } ", which contains the string of the comment." }
{ $see-also <comment> } ;
HELP: <comment>
-{ $values { "text" "a string" } { "comment" "a comment" } }
-{ $description "creates an XML comment tuple" }
+{ $values { "text" string } { "comment" comment } }
+{ $description "Creates an XML " { $link comment } " tuple." }
{ $see-also comment } ;
HELP: instruction
-{ $class-description "represents an XML instruction, such as <?xsl stylesheet='foo.xml'?>. Contains one slot, text, which contains the string between the question marks." }
+{ $class-description "Represents an XML instruction, such as " { $snippet "<?xsl stylesheet='foo.xml'?>" } ". Contains one slot, " { $snippet "text" } ", which contains the string between the question marks." }
{ $see-also <instruction> } ;
HELP: <instruction>
{ $values { "text" "a string" } { "instruction" "an XML instruction" } }
-{ $description "creates an XML parsing instruction, such as <?xsl stylesheet='foo.xml'?>." }
+{ $description "Creates an XML parsing instruction, like " { $snippet "<?xsl stylesheet='foo.xml'?>" } "." }
{ $see-also instruction } ;
HELP: opener
-{ $class-description "describes an opening tag, like <a>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
-{ $see-also closer contained } ;
+{ $class-description "Describes an opening tag, like " { $snippet "<a>" } ". Contains two slots, " { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ;
HELP: closer
-{ $class-description "describes a closing tag, like </a>. Contains one slot, name, containing the tag's name. Usually, the name-url will be f." }
-{ $see-also opener contained } ;
+{ $class-description "Describes a closing tag, like " { $snippet "</a>" } ". Contains one slot, " { $snippet "name" } ", containing the closer's name." } ;
HELP: contained
-{ $class-description "represents a self-closing tag, like <a/>. Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." }
-{ $see-also opener closer } ;
+{ $class-description "Represents a self-closing tag, like " { $snippet "<a/>" } ". Contains two slots," { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ;
+
+{ opener closer contained } related-words
HELP: open-tag
-{ $class-description "represents a tag that does have children, ie is not a contained tag" }
-{ $notes "the constructor used for this class is simply " { $link <tag> } "." }
+{ $class-description "Represents a tag that does have children, ie. is not a contained tag" }
+{ $notes "The constructor used for this class is simply " { $link <tag> } "." }
{ $see-also tag contained-tag } ;
HELP: names-match?
{ $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } }
-{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." }
+{ $description "Checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." }
{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }
{ $see-also name } ;
{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like " { $snippet "<!ENTITY % foo 'bar'>" } " and f if the object is like " { $snippet "<!ENTITY foo 'bar'>" } ", that is, it can be used outside of the DTD." } ;
HELP: system-id
-{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } } ;
+{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "<!DOCTYPE greeting " { $emphasis "SYSTEM 'hello.dtd'" } ">" } "." } ;
HELP: <system-id>
{ $values { "system-literal" string } { "system-id" system-id } }
HELP: <doctype-decl>
{ $values { "name" name } { "external-id" id } { "internal-subset" sequence } { "doctype-decl" doctype-decl } }
{ $description "Creates a new doctype declaration object, of the class " { $link doctype-decl } ". Only one of external-id or internal-subset will be non-null." } ;
+
+HELP: unescaped
+{ $class-description "When constructing XML documents to write to output, it can be useful to splice in a string which is already written. This tuple type allows for that. Printing an " { $snippet "unescaped" } " is the same is printing its " { $snippet "string" } " slot." } ;
+
+HELP: <unescaped>
+{ $values { "string" string } { "unescaped" unescaped } }
+{ $description "Constructs an " { $link unescaped } " tuple, given a string." } ;
+
+HELP: xml-chunk
+{ $class-description "Encapsulates a balanced fragment of an XML document. This is a sequence (following the sequence protocol) of XML data types, eg " { $link string } "s and " { $link tag } "s." } ;
+
+HELP: <xml-chunk>
+{ $values { "seq" sequence } { "xml-chunk" xml-chunk } }
+{ $description "Constructs an " { $link xml-chunk } " tuple, given a sequence to be its contents." } ;
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
tag boa ;
-! For convenience, tags follow the assoc protocol too (for attrs)
-CONSULT: assoc-protocol tag attrs>> ;
-INSTANCE: tag assoc
+: attr ( tag/xml name -- string )
+ swap attrs>> at ;
+
+: set-attr ( tag/xml value name -- )
+ rot attrs>> set-at ;
! They also follow the sequence protocol (for children)
CONSULT: sequence-protocol tag children>> ;
CONSULT: sequence-protocol xml body>> ;
INSTANCE: xml sequence
-CONSULT: assoc-protocol xml body>> ;
-INSTANCE: xml assoc
-
CONSULT: tag xml body>> ;
CONSULT: name xml body>> ;
PREDICATE: contained-tag < tag children>> not ;
PREDICATE: open-tag < tag children>> ;
-UNION: xml-data
- tag comment string directive instruction ;
-
TUPLE: unescaped string ;
C: <unescaped> unescaped
+
+UNION: xml-data
+ tag comment string directive instruction unescaped ;
+
+TUPLE: xml-chunk seq ;
+C: <xml-chunk> xml-chunk
+
+CONSULT: sequence-protocol xml-chunk seq>> ;
+INSTANCE: xml-chunk sequence
parse-name swap ;
: (middle-tag) ( -- )
- pass-blank version=1.0? get-char name-start?
+ pass-blank version-1.0? get-char name-start?
[ parse-attr (middle-tag) ] when ;
: assure-no-duplicates ( attrs-alist -- attrs-alist )
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
- T{ name f "" "version" f } swap at
- [ good-version ] [ versionless-prolog ] if* ;
+ T{ name { space "" } { main "version" } } swap at
+ [ good-version ] [ versionless-prolog ] if*
+ dup set-version ;
: prolog-encoding ( alist -- encoding )
- T{ name f "" "encoding" f } swap at "UTF-8" or ;
+ T{ name { space "" } { main "encoding" } } swap at
+ "UTF-8" or ;
: yes/no>bool ( string -- t/f )
{
} case ;
: prolog-standalone ( alist -- version )
- T{ name f "" "standalone" f } swap at
+ T{ name { space "" } { main "standalone" } } swap at
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
[ prolog-standalone ]
tri <prolog> ;
-SYMBOL: string-input?
-: decode-input-if ( encoding -- )
- string-input? get [ drop ] [ decode-input ] if ;
-
: parse-prolog ( -- prolog )
pass-blank middle-tag "?>" expect
- dup assure-no-extra prolog-attrs
- dup encoding>> dup "UTF-16" =
- [ drop ] [ name>encoding [ decode-input-if ] when* ] if
- dup prolog-data set ;
+ dup assure-no-extra prolog-attrs ;
: instruct ( -- instruction )
take-name {
"For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ;
HELP: entities
-{ $description "a hash table from default XML entity names (like & and <) to the characters they represent. This is automatically included when parsing any XML document." }
+{ $description "A hash table from default XML entity names (like " { $snippet "&" } " and " { $snippet "<" } ") to the characters they represent. This is automatically included when parsing any XML document." }
{ $see-also with-entities } ;
HELP: with-entities
-{ $values { "entities" "a hash table of strings to chars" }
- { "quot" "a quotation ( -- )" } }
-{ $description "calls the quotation using the given table of entity values (symbolizing, eg, that &foo; represents CHAR: a) on top of the default XML entities" } ;
+{ $values { "entities" "a hash table of strings to strings" } { "quot" "a quotation ( -- )" } }
+{ $description "Calls the quotation using the given table of entity values (symbolizing, eg, that " { $snippet "&foo;" } " represents " { $snippet "\"a\"" } ") on top of the default XML entities" } ;
ARTICLE: "xml.entities.html" "HTML entities"
{ $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML."
- { $subsection html-entities }
- { $subsection with-html-entities } ;
+{ $subsection html-entities }
+{ $subsection with-html-entities } ;
HELP: html-entities
-{ $description "a hash table from HTML entity names to their character values" }
+{ $description "A hash table from HTML entity names to their character values." }
{ $see-also entities with-html-entities } ;
HELP: with-html-entities
{ $values { "quot" "a quotation ( -- )" } }
-{ $description "calls the given quotation using HTML entity values" }
+{ $description "Calls the given quotation using HTML entity values." }
{ $see-also html-entities with-entities } ;
USING: help.markup help.syntax ;
IN: xml.errors
+<PRIVATE
+
+: $xml-error ( element -- )
+ "Bad XML document for the error" $heading $code ;
+
+PRIVATE>
+
HELP: multitags
-{ $class-description "XML parsing error describing the case where there is more than one main tag in a document. Contains no slots" } ;
+{ $class-description "XML parsing error describing the case where there is more than one main tag in a document." }
+{ $xml-error "<a/>\n<b/>" } ;
HELP: notags
-{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ;
+{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" }
+{ $xml-error "<?xml version='1.0'?>" } ;
HELP: extra-attrs
-{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link xml-error-at } "." } ;
+{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "<?xml ...?>" } ") contains attributes other than the three allowed ones, " { $snippet "standalone" } ", " { $snippet "version" } " and " { $snippet "encoding" } ". Contains one slot, " { $snippet "attrs" } ", which is a hashtable of all the extra attributes' names. This is a subclass of " { $link xml-error-at } "." }
+{ $xml-error "<?xml version='1.0' reason='because I said so'?>\n<foo/>" } ;
HELP: nonexist-ns
-{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link xml-error-at } "." } ;
+{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, " { $snippet "name" } ", which contains the name of the undeclared namespace, and is a subclass of " { $link xml-error-at } "." }
+{ $xml-error "<a:b>c</a:b>" } ;
HELP: not-yes/no
-{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link xml-error-at } " and contains one slot, text, which contains offending value." } ;
+{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than " { $snippet "yes" } " or " { $snippet "no" } ". This is a subclass of " { $link xml-error-at } " and contains one slot, text, which contains offending value." }
+{ $xml-error "<?xml version='1.0' standalone='maybe'?>\n<x/>" } ;
HELP: unclosed
-{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ;
+{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, " { $snippet "tags" } ", a sequence of names." }
+{ $xml-error "<x>some text" } ;
HELP: mismatched
-{ $class-description "XML parsing error describing mismatched tags, eg " { $snippet "<a></c>" } ". Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link xml-error-at } " showing the location of the closing tag" } ;
+{ $class-description "XML parsing error describing mismatched tags. Contains two slots: " { $snippet "open" } " is the name of the opening tag and " { $snippet "close" } " is the name of the closing tag. This is a subclass of " { $link xml-error-at } " showing the location of the closing tag" }
+{ $xml-error "<a></c>" } ;
HELP: expected
-{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ;
+{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, " { $snippet "should-be" } ", which has the expected string, and " { $snippet "was" } ", which has the actual string." } ;
HELP: no-entity
-{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } ;
+{ $class-description "XML parsing error describing the use of an undefined entity. This is a subclass of " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." }
+{ $xml-error "<x>&foo;</x>" } ;
HELP: pre/post-content
-{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ;
-
-HELP: unclosed-quote
-{ $class-description "Describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ;
+{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: " { $snippet "string" } " contains the offending string, and " { $snippet "pre?" } " is " { $snippet "t" } " if it occured before the main tag and " { $snippet "f" } " if it occured after." }
+{ $xml-error "hello\n<main-tag/>" } ;
HELP: bad-name
-{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ;
+{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." }
+{ $xml-error "<%>\n</%>" } ;
HELP: quoteless-attr
-{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } ;
+{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." }
+{ $xml-error "<tag foo=bar/>" } ;
HELP: disallowed-char
{ $class-description "Describes the error where a disallowed character occurs in an XML document." } ;
{ $class-description "Describes the error where a document unexpectedly ends, and the XML parser expected it to continue." } ;
HELP: duplicate-attr
-{ $class-description "Describes the error where there is more than one attribute of the same key." } ;
+{ $class-description "Describes the error where there is more than one attribute of the same key." }
+{ $xml-error "<tag value='1' value='2'/>" } ;
HELP: bad-cdata
-{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } ;
+{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." }
+{ $xml-error "<x>y</x>\n<![CDATA[]]>" } ;
HELP: text-w/]]>
-{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } ;
+{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." }
+{ $xml-error "<x>Here's some text: ]]> there it was</x>" } ;
HELP: attr-w/<
-{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } ;
+{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." }
+{ $xml-error "<x value='bar<baz'/>" } ;
HELP: misplaced-directive
-{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } ;
+{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." }
+{ $xml-error "<x><!ENTITY foo 'bar'></x>" } ;
HELP: xml-error
{ $class-description "The exception class that all parsing errors in XML documents are in." } ;
ARTICLE: "xml.errors" "XML parsing errors"
-"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } " but there are many classes contained in that:"
+"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } "."
{ $subsection multitags }
{ $subsection notags }
{ $subsection extra-attrs }
{ $subsection text-w/]]> }
{ $subsection attr-w/< }
{ $subsection misplaced-directive }
- "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information"
+ "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred."
$nl
"Note that, in parsing an XML document, only the first error is reported." ;
[
dup call-next-method write
"Misplaced XML prolog" print
- prolog>> write-prolog nl
+ prolog>> write-xml nl
] with-string-writer ;
TUPLE: capitalized-prolog < xml-error-at name ;
[
dup call-next-method write
"Misplaced directive:" print
- dir>> write-xml-chunk nl
+ dir>> write-xml nl
] with-string-writer ;
TUPLE: bad-name < xml-error-at name ;
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.interpolate multiline kernel assocs
sequences accessors xml.writer xml.interpolate.private
-locals splitting urls ;
+locals splitting urls xml.data classes ;
IN: xml.interpolate.tests
[ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
string>doc
[ second var>> ]
- [ fourth "val" swap at var>> ]
+ [ fourth "val" attr var>> ]
[ extract-variables ] tri
] unit-test
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
-[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
-[ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
+[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
+[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
-\ parse-def must-infer
-[ "" interpolate-chunk ] must-infer
+\ <XML must-infer
+[ { } "" interpolate-xml ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
+
+[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
+[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
+[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
+[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
+[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
+[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
+
+[ "" ] [ [XML XML] concat ] unit-test
USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros
sequences.deep generalizations words combinators
-math present arrays ;
+math present arrays unicode.categories ;
IN: xml.interpolate
<PRIVATE
M: xml-data push-item , ;
M: object push-item present , ;
M: sequence push-item
- [ dup array? [ % ] [ , ] if ] each ;
+ dup xml-data? [ , ] [ [ push-item ] each ] if ;
M: number push-item present , ;
+M: xml-chunk push-item % ;
GENERIC: interpolate-item ( table item -- )
M: object interpolate-item nip , ;
: number<-> ( doc -- dup )
0 over [
- dup var>> [ over >>var [ 1+ ] dip ] unless drop
+ dup var>> [
+ over >>var [ 1+ ] dip
+ ] unless drop
] each-interpolated drop ;
-MACRO: interpolate-xml ( string -- doc )
- string>doc number<-> '[ _ interpolate-xml-doc ] ;
+GENERIC: interpolate-xml ( table xml -- xml )
-MACRO: interpolate-chunk ( string -- chunk )
- string>chunk number<-> '[ _ interpolate-sequence ] ;
+M: xml interpolate-xml
+ interpolate-xml-doc ;
+
+M: xml-chunk interpolate-xml
+ interpolate-sequence <xml-chunk> ;
: >search-hash ( seq -- hash )
[ dup search ] H{ } map>assoc ;
: nenum ( ... n -- assoc )
narray <enum> ; inline
-: collect ( accum seq -- accum )
+: collect ( accum variables -- accum ? )
{
- { [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
- { [ dup [ not ] all? ] [ ! fry
- length parsed \ nenum parsed
- ] }
+ { [ dup empty? ] [ drop f ] } ! Just a literal
+ { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
+ { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
} cond ;
-: parse-def ( accum delimiter word -- accum )
- [
- parse-multiline-string but-last
- [ string>chunk extract-variables collect ] keep
- parsed
- ] dip parsed ;
+: parse-def ( accum delimiter quot -- accum )
+ [ parse-multiline-string [ blank? ] trim ] dip call
+ [ extract-variables collect ] keep swap
+ [ number<-> parsed ] dip
+ [ \ interpolate-xml parsed ] when ; inline
PRIVATE>
: <XML
- "XML>" \ interpolate-xml parse-def ; parsing
+ "XML>" [ string>doc ] parse-def ; parsing
: [XML
- "XML]" \ interpolate-chunk parse-def ; parsing
+ "XML]" [ string>chunk ] parse-def ; parsing
: valid-name? ( str -- ? )
[ f ] [
- version=1.0? swap {
+ version-1.0? swap {
[ first name-start? ]
[ rest-slice [ name-char? ] with all? ]
} 2&&
] ?if ;
: take-name ( -- string )
- version=1.0? '[ _ get-char name-char? not ] take-until ;
+ version-1.0? '[ _ get-char name-char? not ] take-until ;
: parse-name ( -- name )
take-name interpret-name ;
USING: accessors kernel namespaces io ;
IN: xml.state
-TUPLE: spot char line column next check ;
+TUPLE: spot char line column next check version-1.0? ;
C: <spot> spot
: set-next ( char -- ) spot get swap >>next drop ;
: get-check ( -- ? ) spot get check>> ;
: check ( -- ) spot get t >>check drop ;
+: version-1.0? ( -- ? ) spot get version-1.0?>> ;
+: set-version ( string -- )
+ spot get swap "1.0" = >>version-1.0? drop ;
SYMBOL: xml-stack
-SYMBOL: prolog-data
-
SYMBOL: depth
SYMBOL: interpolating?
GENERIC: (r-ref) ( xml -- )
M: tag (r-ref)
- sub-tag over at* [
+ dup sub-tag attr [
ref-table get at
>>children drop
- ] [ 2drop ] if ;
+ ] [ drop ] if* ;
M: object (r-ref) drop ;
: template ( xml -- )
[ "a" ] [ xml-file get space>> ] unit-test
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
[ "that" ] [
- xml-file get T{ name f "" "this" "http://d.de" } swap at
+ xml-file get T{ name f "" "this" "http://d.de" } attr
] unit-test
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
xml-file get after>> [ instruction? ] find nip text>>
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
-[ "that" ] [ xml-file get "this" swap at ] unit-test
+[ "that" ] [ xml-file get "this" attr ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
"c" get-id children>string
] unit-test
-[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
- at swap "z" [ tuck ] dip swap set-at
- T{ name f "blah" "z" f } swap at ] unit-test
+[ "foo" ] [
+ "<x y='foo'/>" string>xml
+ dup dup "y" attr "z" set-attr
+ T{ name { space "blah" } { main "z" } } attr
+] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
[ "<!-- B+, B, or B--->" string>xml ] must-fail
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
-[ T{ element-decl f "br" "EMPTY" } ] [ "<!ELEMENT br EMPTY>" string>dtd directives>> first ] unit-test
-[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "<!ELEMENT p (#PCDATA|emph)*>" string>dtd directives>> first ] unit-test
-[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "<!ELEMENT %name.para; %content.para;>" string>dtd directives>> first ] unit-test
-[ T{ element-decl f "container" "ANY" } ] [ "<!ELEMENT container ANY>" string>dtd directives>> first ] unit-test
-[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo>" string>xml-chunk first ] unit-test
-[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk first ] unit-test
-[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
-[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
+
+: first-thing ( seq -- elt )
+ [ "" = not ] filter first ;
+
+[ T{ element-decl f "br" "EMPTY" } ] [ "<!ELEMENT br EMPTY>" string>dtd directives>> first-thing ] unit-test
+[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "<!ELEMENT p (#PCDATA|emph)*>" string>dtd directives>> first-thing ] unit-test
+[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "<!ELEMENT %name.para; %content.para;>" string>dtd directives>> first-thing ] unit-test
+[ T{ element-decl f "container" "ANY" } ] [ "<!ELEMENT container ANY>" string>dtd directives>> first-thing ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo>" string>xml-chunk first-thing ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk first-thing ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first-thing ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first-thing ] unit-test
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
-[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
+[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
+[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.utilities xml.writer arrays ;
+xml.utilities xml.writer arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
: >xml-test ( tag -- test )
xml-test new swap {
- [ "TYPE" swap at >>type ]
- [ "ID" swap at >>id ]
- [ "URI" swap at >>uri ]
- [ "SECTIONS" swap at >>sections ]
- [ children>> xml-chunk>string >>description ]
+ [ "TYPE" attr >>type ]
+ [ "ID" attr >>id ]
+ [ "URI" attr >>uri ]
+ [ "SECTIONS" attr >>sections ]
+ [ children>> xml>string >>description ]
} cleave ;
: parse-tests ( xml -- tests )
: failing-valids ( -- tests )
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
+
+[ ] [ partition-xml-tests 2drop ] unit-test
locals combinators arrays ;
IN: xml.tokenize
-: version=1.0? ( -- ? )
- prolog-data get [ version>> "1.0" = ] [ t ] if* ;
-
: assure-good-char ( ch -- ch )
[
- version=1.0? over text? not get-check and
+ version-1.0? over text? not get-check and
[ disallowed-char ] when
] [ f ] if* ;
get-char [ unexpected-end ] unless (next) record ;
: init-parser ( -- )
- 0 1 0 f f <spot> spot set
+ 0 1 0 f f t <spot> spot set
read1 set-next next ;
: with-state ( stream quot -- )
: children>string ( tag -- string )
children>> {
{ [ dup empty? ] [ drop "" ] }
- { [ dup [ string? not ] contains? ]
+ { [ dup [ string? not ] any? ]
[ "XML tag unexpectedly contains non-text children" throw ] }
[ concat ]
} cond ;
: first-child-tag ( tag -- tag )
children>> [ tag? ] find nip ;
-! * Accessing part of an XML document
-! for tag- words, a start means that it searches all children
-! and no star searches only direct children
-
: tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ;
tags@ '[ _ swap tag-named? ] deep-filter ;
: tag-named ( tag name/string -- matching-tag )
- ! like get-name-tag but only looks at direct children,
- ! not all the children down the tree.
assure-name swap [ tag-named? ] with find nip ;
: tags-named ( tag name/string -- tags-seq )
tags@ swap [ tag-named? ] with filter ;
: tag-with-attr? ( elem attr-value attr-name -- ? )
- rot dup tag? [ at = ] [ 3drop f ] if ;
+ rot dup tag? [ swap attr = ] [ 3drop f ] if ;
: tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name '[ _ _ tag-with-attr? ] find nip ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] deep-filter ;
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
+: get-id ( tag id -- elem )
"id" deep-tag-with-attr ;
: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup io strings ;
+USING: help.syntax help.markup io strings xml.data multiline ;
IN: xml.writer
ABOUT: "xml.writer"
ARTICLE: "xml.writer" "Writing XML"
- "These words are used in implementing prettyprint"
- { $subsection write-xml-chunk }
- "These words are used to print XML normally"
- { $subsection xml>string }
+ "These words are used to print XML preserving whitespace in text nodes"
{ $subsection write-xml }
+ { $subsection xml>string }
"These words are used to prettyprint XML"
{ $subsection pprint-xml>string }
- { $subsection pprint-xml>string-but }
{ $subsection pprint-xml }
- { $subsection pprint-xml-but } ;
-
-HELP: write-xml-chunk
-{ $values { "object" "an XML element" } }
-{ $description "writes an XML element to " { $link output-stream } "." }
-{ $see-also write-xml-chunk write-xml } ;
+ "Certain variables can be changed to mainpulate prettyprinting"
+ { $subsection sensitive-tags }
+ { $subsection indenter }
+ "All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ;
HELP: xml>string
-{ $values { "xml" "an xml document" } { "string" "a string" } }
-{ $description "converts an XML document into a string" }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $values { "xml" "an XML document" } { "string" "a string" } }
+{ $description "This converts an XML document " { $link xml } " into a string. It can also be used to convert any piece of XML to a string, eg an " { $link xml-chunk } " or " { $link comment } "." }
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: pprint-xml>string
-{ $values { "xml" "an xml document" } { "string" "a string" } }
+{ $values { "xml" "an XML document" } { "string" "a string" } }
{ $description "converts an XML document into a string in a prettyprinted form." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: write-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document to " { $link output-stream } "." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ;
HELP: pprint-xml
{ $values { "xml" "an XML document" } }
{ $description "prints the contents of an XML document to " { $link output-stream } " in a prettyprinted form." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
-
-HELP: pprint-xml-but
-{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } }
-{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. Whitespace is also not preserved." } ;
-HELP: pprint-xml>string-but
-{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } }
-{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+{ xml>string write-xml pprint-xml pprint-xml>string } related-words
-{ xml>string write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words
+HELP: indenter
+{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
+{ $example {" USING: xml.interpolate xml.writer namespaces ;
+[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
+<foo>
+%%%%bar
+</foo>"} } ;
+HELP: sensitive-tags
+{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
+{ $example {" USING: xml.interpolate xml.writer namespaces ;
+[XML <html> <head> <title> something</title></head><body><pre>bing
+bang
+ bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+<html>
+ <head>
+ <title>
+ something
+ </title>
+ </head>
+ <body>
+ <pre>bing
+bang
+ bong</pre>
+ </body>
+</html>"} } ;
\ write-xml must-infer
\ xml>string must-infer
\ pprint-xml must-infer
-\ pprint-xml-but must-infer
+! Add a test for pprint-xml with sensitive-tags
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ "foo" ] [ T{ name { space "" } { main "foo" } } name>string ] unit-test
]>
<x>&foo;</x>"} pprint-reprints-as
-[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
-[ V{ "hello" } ] [ "hello" string>xml-chunk ] 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 xml>string = ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
-[ "<foo'>" ] [ "<foo'>" <unescaped> xml-chunk>string ] unit-test
+[ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
xml.data wrap xml.entities unicode.categories fry ;\r
IN: xml.writer\r
\r
-SYMBOL: xml-pprint?\r
SYMBOL: sensitive-tags\r
-SYMBOL: indentation\r
SYMBOL: indenter\r
" " indenter set-global\r
\r
<PRIVATE\r
\r
+SYMBOL: xml-pprint?\r
+SYMBOL: indentation\r
+\r
: sensitive? ( tag -- ? )\r
- sensitive-tags get swap '[ _ names-match? ] contains? ;\r
+ sensitive-tags get swap '[ _ names-match? ] any? ;\r
\r
: indent-string ( -- string )\r
xml-pprint? get\r
\r
<PRIVATE\r
\r
+: write-quoted ( string -- )\r
+ CHAR: " write1 write CHAR: " write1 ;\r
+\r
: print-attrs ( assoc -- )\r
[\r
- " " write\r
- swap print-name\r
- "=\"" write\r
- escape-quoted-string write\r
- "\"" write\r
+ [ bl print-name "=" write ]\r
+ [ escape-quoted-string write-quoted ] bi*\r
] assoc-each ;\r
\r
PRIVATE>\r
\r
-GENERIC: write-xml-chunk ( object -- )\r
+GENERIC: write-xml ( xml -- )\r
\r
<PRIVATE\r
\r
-M: string write-xml-chunk\r
+M: string write-xml\r
escape-string xml-pprint? get [\r
dup [ blank? ] all?\r
[ drop "" ]\r
: write-start-tag ( tag -- )\r
write-tag ">" write ;\r
\r
-M: contained-tag write-xml-chunk\r
+M: contained-tag write-xml\r
write-tag "/>" write ;\r
\r
: write-children ( tag -- )\r
indent children>> ?filter-children\r
- [ write-xml-chunk ] each unindent ;\r
+ [ write-xml ] each unindent ;\r
\r
: write-end-tag ( tag -- )\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
-M: open-tag write-xml-chunk\r
+M: open-tag write-xml\r
xml-pprint? get [\r
{\r
- [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
[ write-start-tag ]\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
[ write-children ]\r
[ write-end-tag ]\r
} cleave\r
] dip xml-pprint? set ;\r
\r
-M: unescaped write-xml-chunk\r
+M: unescaped write-xml\r
string>> write ;\r
\r
-M: comment write-xml-chunk\r
+M: comment write-xml\r
"<!--" write text>> write "-->" write ;\r
\r
-M: element-decl write-xml-chunk\r
- "<!ELEMENT " write\r
- [ name>> write " " write ]\r
- [ content-spec>> write ">" write ]\r
- bi ;\r
+: write-decl ( decl name quot: ( decl -- slot ) -- )\r
+ "<!" write swap write bl\r
+ [ name>> write bl ]\r
+ swap '[ @ write ">" write ] bi ; inline\r
\r
-M: attlist-decl write-xml-chunk\r
- "<!ATTLIST " write\r
- [ name>> write " " write ]\r
- [ att-defs>> write ">" write ]\r
- bi ;\r
+M: element-decl write-xml\r
+ "ELEMENT" [ content-spec>> ] write-decl ;\r
\r
-M: notation-decl write-xml-chunk\r
- "<!NOTATION " write\r
- [ name>> write " " write ]\r
- [ id>> write ">" write ]\r
- bi ;\r
+M: attlist-decl write-xml\r
+ "ATTLIST" [ att-defs>> ] write-decl ;\r
+\r
+M: notation-decl write-xml\r
+ "NOTATION" [ id>> ] write-decl ;\r
\r
-M: entity-decl write-xml-chunk\r
+M: entity-decl write-xml\r
"<!ENTITY " write\r
[ pe?>> [ " % " write ] when ]\r
[ name>> write " \"" write ] [\r
def>> f xml-pprint?\r
- [ write-xml-chunk ] with-variable\r
+ [ write-xml ] with-variable\r
"\">" write\r
] tri ;\r
\r
-M: system-id write-xml-chunk\r
- "SYSTEM '" write system-literal>> write "'" write ;\r
+M: system-id write-xml\r
+ "SYSTEM" write bl system-literal>> write-quoted ;\r
\r
-M: public-id write-xml-chunk\r
- "PUBLIC '" write\r
- [ pubid-literal>> write "' '" write ]\r
- [ system-literal>> write "'" write ] bi ;\r
+M: public-id write-xml\r
+ "PUBLIC" write bl\r
+ [ pubid-literal>> write-quoted bl ]\r
+ [ system-literal>> write-quoted ] bi ;\r
\r
: write-internal-subset ( dtd -- )\r
[\r
"[" write indent\r
- directives>> [ ?indent write-xml-chunk ] each\r
+ directives>> [ ?indent write-xml ] each\r
unindent ?indent "]" write\r
] when* ;\r
\r
-M: doctype-decl write-xml-chunk\r
+M: doctype-decl write-xml\r
?indent "<!DOCTYPE " write\r
[ name>> write " " write ]\r
- [ external-id>> [ write-xml-chunk " " write ] when* ]\r
+ [ external-id>> [ write-xml " " write ] when* ]\r
[ internal-subset>> write-internal-subset ">" write ] tri ;\r
\r
-M: directive write-xml-chunk\r
+M: directive write-xml\r
"<!" write text>> write CHAR: > write1 nl ;\r
\r
-M: instruction write-xml-chunk\r
+M: instruction write-xml\r
"<?" write text>> write "?>" write ;\r
\r
-M: number write-xml-chunk\r
+M: number write-xml\r
"Numbers are not allowed in XML" throw ;\r
\r
-M: sequence write-xml-chunk\r
- [ write-xml-chunk ] each ;\r
+M: sequence write-xml\r
+ [ write-xml ] each ;\r
\r
-PRIVATE>\r
+M: prolog write-xml\r
+ "<?xml version=" write\r
+ [ version>> write-quoted ]\r
+ [ " encoding=" write encoding>> write-quoted ]\r
+ [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
+ "?>" write ;\r
\r
-: write-prolog ( xml -- )\r
- "<?xml version=\"" write dup version>> write\r
- "\" encoding=\"" write dup encoding>> write\r
- standalone>> [ "\" standalone=\"yes" write ] when\r
- "\"?>" write ;\r
-\r
-: write-xml ( xml -- )\r
+M: xml write-xml\r
{\r
- [ prolog>> write-prolog ]\r
- [ before>> write-xml-chunk ]\r
- [ body>> write-xml-chunk ]\r
- [ after>> write-xml-chunk ]\r
+ [ prolog>> write-xml ]\r
+ [ before>> write-xml ]\r
+ [ body>> write-xml ]\r
+ [ after>> write-xml ]\r
} cleave ;\r
\r
-M: xml write-xml-chunk\r
- body>> write-xml-chunk ;\r
+PRIVATE>\r
\r
: xml>string ( xml -- string )\r
[ write-xml ] with-string-writer ;\r
\r
-: xml-chunk>string ( object -- string )\r
- [ write-xml-chunk ] with-string-writer ;\r
-\r
-: pprint-xml-but ( xml sensitive-tags -- )\r
+: pprint-xml ( xml -- )\r
[\r
- [ assure-name ] map sensitive-tags set\r
+ sensitive-tags [ [ assure-name ] map ] change\r
0 indentation set\r
xml-pprint? on\r
write-xml\r
] with-scope ;\r
\r
-: pprint-xml ( xml -- )\r
- f pprint-xml-but ;\r
-\r
-: pprint-xml>string-but ( xml sensitive-tags -- string )\r
- [ pprint-xml-but ] with-string-writer ;\r
-\r
: pprint-xml>string ( xml -- string )\r
- f pprint-xml>string-but ;\r
+ [ pprint-xml ] with-string-writer ;\r
\r
HELP: read-xml-chunk\r
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }\r
-{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." }\r
+{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." }\r
{ $see-also read-xml } ;\r
\r
HELP: each-element\r
{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } }\r
-{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly, and it is advised that generic words be used in dispatching on the event class." }\r
-{ $notes "It is important to note that this is not SAX, merely an event-based XML view" }\r
+{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." }\r
{ $see-also read-xml } ;\r
\r
HELP: pull-xml\r
-{ $class-description "Represents the state of a pull-parser for XML. Has one slot, scope, which is a namespace which contains all relevant state information." }\r
+{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." }\r
{ $see-also <pull-xml> pull-event pull-elem } ;\r
\r
HELP: <pull-xml>\r
-{ $values { "pull-xml" "a pull-xml tuple" } }\r
+{ $values { "pull-xml" pull-xml } }\r
{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }\r
{ $see-also pull-xml pull-elem pull-event } ;\r
\r
{ $subsection pull-elem } ;\r
\r
ARTICLE: "xml" "XML parser"\r
-"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."\r
+"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs."\r
{ $subsection { "xml" "reading" } }\r
{ $subsection { "xml" "events" } }\r
{ $vocab-subsection "Writing XML" "xml.writer" }\r
USING: accessors arrays io io.encodings.binary io.files
io.streams.string kernel namespaces sequences strings io.encodings.utf8
xml.data xml.errors xml.elements ascii xml.entities
-xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ;
+xml.writer xml.state xml.autoencoding assocs xml.tokenize
+combinators.short-circuit xml.name ;
IN: xml
<PRIVATE
M: object process add-child ;
M: prolog process
- xml-stack get V{ { f V{ } } } =
+ xml-stack get
+ { V{ { f V{ "" } } } V{ { f V{ } } } } member?
[ bad-prolog ] unless drop ;
+: before-main? ( -- ? )
+ xml-stack get {
+ [ length 1 = ]
+ [ first second [ tag? ] any? not ]
+ } 1&& ;
+
M: directive process
- xml-stack get dup length 1 =
- swap first second [ tag? ] contains? not and
- [ misplaced-directive ] unless
- add-child ;
+ before-main? [ misplaced-directive ] unless add-child ;
M: contained process
[ name>> ] [ attrs>> ] bi
: init-xml-stack ( -- )
V{ } clone xml-stack set
- extra-entities [ H{ } assoc-like ] change
f push-xml ;
: default-prolog ( -- prolog )
"1.0" "UTF-8" f <prolog> ;
-: reset-prolog ( -- )
- default-prolog prolog-data set ;
-
: init-xml ( -- )
- reset-prolog init-xml-stack init-ns-stack ;
+ init-ns-stack
+ extra-entities [ H{ } assoc-like ] change ;
: assert-blanks ( seq pre? -- )
swap [ string? ] filter
: no-post-tags ( post -- post/* )
! this does *not* affect the contents of the stack
- dup [ tag? ] contains? [ multitags ] when ;
+ dup [ tag? ] any? [ multitags ] when ;
: assure-tags ( seq -- seq )
! this does *not* affect the contents of the stack
[ notags ] unless* ;
-: make-xml-doc ( prolog seq -- xml-doc )
+: get-prolog ( seq -- prolog )
+ first dup prolog? [ drop default-prolog ] unless ;
+
+: make-xml-doc ( seq -- xml-doc )
+ [ get-prolog ] keep
dup [ tag? ] find
[ assure-tags cut rest no-pre/post no-post-tags ] dip
swap <xml> ;
: <pull-xml> ( -- pull-xml )
[
input-stream [ ] change ! bring var in this scope
- init-parser reset-prolog init-ns-stack
- text-now? on
+ init-xml text-now? on
] H{ } make-assoc
pull-xml boa ;
! pull-xml needs to call start-document somewhere
get-char [ make-tag call-under xml-loop ]
[ drop ] if ; inline recursive
+: read-seq ( stream quot n -- seq )
+ rot [
+ depth set
+ init-xml init-xml-stack
+ call
+ [ process ] xml-loop
+ done? [ unclosed ] unless
+ xml-stack get first second
+ ] with-state ; inline
+
PRIVATE>
: each-element ( stream quot: ( xml-elem -- ) -- )
swap [
- reset-prolog init-ns-stack
+ init-xml
start-document [ call-under ] when*
xml-loop
] with-state ; inline
-: (read-xml) ( -- )
- start-document [ process ] when*
- [ process ] xml-loop ; inline
-
-: (read-xml-chunk) ( stream -- prolog seq )
- [
- init-xml (read-xml)
- done? [ unclosed ] unless
- xml-stack get first second
- prolog-data get swap
- ] with-state ;
-
: read-xml ( stream -- xml )
- 0 depth
- [ (read-xml-chunk) make-xml-doc ] with-variable ;
+ [ start-document [ process ] when* ]
+ 0 read-seq make-xml-doc ;
: read-xml-chunk ( stream -- seq )
- 1 depth
- [ (read-xml-chunk) nip ] with-variable ;
+ [ check ] 1 read-seq <xml-chunk> ;
: string>xml ( string -- xml )
- t string-input?
- [ <string-reader> read-xml ] with-variable ;
+ <string-reader> [ check ] 0 read-seq make-xml-doc ;
: string>xml-chunk ( string -- xml )
- t string-input?
- [ <string-reader> read-xml-chunk ] with-variable ;
+ <string-reader> read-xml-chunk ;
: file>xml ( filename -- xml )
binary <file-reader> read-xml ;
: read-dtd ( stream -- dtd )
[
- reset-prolog
H{ } clone extra-entities set
take-internal-subset
] with-state ;
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors ;
+words globs combinators io.encodings.utf8 sorting accessors xml.data ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
- "NAME" over at [
+ dup "NAME" attr [
mode new {
{ "FILE" f (>>file) }
{ "FILE_NAME_GLOB" f (>>file-name-glob) }
--- /dev/null
+IN: xmode.code2html.tests
+USING: xmode.code2html xmode.catalog
+tools.test multiline splitting memoize
+kernel ;
+
+[ ] [ \ (load-mode) reset-memoized ] unit-test
+
+[ ] [
+ <" <style type="text/css" media="screen" >
+ * {margin:0; padding:0; border:0;} ">
+ string-lines "html" htmlize-lines drop
+] unit-test
\ No newline at end of file
parse-props-tag >>props drop ;
TAG: IMPORT
- "DELEGATE" swap at swap import-rule-set ;
+ "DELEGATE" attr swap import-rule-set ;
TAG: TERMINATE
- "AT_CHAR" swap at string>number >>terminate-char drop ;
+ "AT_CHAR" attr string>number >>terminate-char drop ;
RULE: SEQ seq-rule
shared-tag-attrs delegate-attr literal-start ;
! PROP, PROPS
: parse-prop-tag ( tag -- key value )
- "NAME" over at "VALUE" rot at ;
+ [ "NAME" attr ] [ "VALUE" attr ] bi ;
: parse-props-tag ( tag -- assoc )
child-tags
: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
! XXX Wrong logic!
{ "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" }
- swap [ at string>boolean ] curry map first3 ;
+ [ attr string>boolean ] with map first3 ;
: parse-literal-matcher ( tag -- matcher )
dup children>string
: keyword-number? ( keyword -- ? )
{
[ current-rule-set highlight-digits?>> ]
- [ dup [ digit? ] contains? ]
+ [ dup [ digit? ] any? ]
[
dup [ digit? ] all? [
current-rule-set digit-re>>
] }
{ [ dup length 3 = ] [
first3 '[
- _ tag get at
+ tag get _ attr
_ [ execute ] when* object get _ execute
]
] }
set_factor_binary() {
case $OS in
- winnt) FACTOR_BINARY=factor.exe;;
+ winnt) FACTOR_BINARY=factor-console.exe;;
*) FACTOR_BINARY=factor;;
esac
}
{ $subsection substitute }
{ $subsection substitute-here }
{ $subsection extract-keys }
-{ $see-also key? assoc-contains? assoc-all? "sets" } ;
+{ $see-also key? assoc-any? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection assoc-map }
{ $subsection assoc-filter }
{ $subsection assoc-filter-as }
-{ $subsection assoc-contains? }
+{ $subsection assoc-any? }
{ $subsection assoc-all? }
"Additional combinators:"
{ $subsection cache }
{ assoc-filter assoc-filter-as } related-words
-HELP: assoc-contains?
+HELP: assoc-any?
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
[ (assoc-each) partition ] [ drop ] 2bi
tuck [ assoc-like ] 2bi@ ; inline
-: assoc-contains? ( assoc quot -- ? )
+: assoc-any? ( assoc quot -- ? )
assoc-find 2nip ; inline
: assoc-all? ( assoc quot -- ? )
- [ not ] compose assoc-contains? not ; inline
+ [ not ] compose assoc-any? not ; inline
: at ( key assoc -- value/f )
at* drop ; inline
[ normalize-path (file-reader) ] dip checksum-stream ;
: hex-string ( seq -- str )
- [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
+ [ >hex 2 CHAR: 0 pad-head ] { } map-as concat ;
[ members>> ] dip [ class<= ] curry all? ;\r
\r
: right-anonymous-union<= ( first second -- ? )\r
- members>> [ class<= ] with contains? ;\r
+ members>> [ class<= ] with any? ;\r
\r
: left-anonymous-intersection<= ( first second -- ? )\r
- [ participants>> ] dip [ class<= ] curry contains? ;\r
+ [ participants>> ] dip [ class<= ] curry any? ;\r
\r
: right-anonymous-intersection<= ( first second -- ? )\r
participants>> [ class<= ] with all? ;\r
] if ;\r
\r
M: anonymous-union (classes-intersect?)\r
- members>> [ classes-intersect? ] with contains? ;\r
+ members>> [ classes-intersect? ] with any? ;\r
\r
M: anonymous-intersection (classes-intersect?)\r
participants>> [ classes-intersect? ] with all? ;\r
[ class<= ] [ swap class<= ] 2bi and ;\r
\r
: largest-class ( seq -- n elt )\r
- dup [ [ class< ] with contains? not ] curry find-last\r
+ dup [ [ class< ] with any? not ] curry find-last\r
[ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
[
[ name>> "f?" = ]
[ vocabulary>> "syntax" = ] bi and
- ] contains?
+ ] any?
] unit-test
ERROR: bad-superclass class ;
-<PRIVATE
-
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ layout-of ] bi@ eq? [
- [ drop tuple-size ]
- [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
- 2bi all-integers?
- ] [
- 2drop f
- ] if ; inline
+ 2dup [ tuple? ] both? [
+ 2dup [ layout-of ] bi@ eq? [
+ [ drop tuple-size ]
+ [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
+ 2bi all-integers?
+ ] [ 2drop f ] if
+ ] [ 2drop f ] if ; inline
+
+<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
#! Fast path for tuples with no superclass
: tuple-prototype ( class -- prototype )
[ initial-values ] keep
- over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
+ over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
-M: tuple hashcode*
+GENERIC: tuple-hashcode ( n tuple -- x )
+
+M: tuple tuple-hashcode
[
[ class hashcode ] [ tuple-size ] [ ] tri
[ rot ] dip [
] 2curry each
] recursive-hashcode ;
+M: tuple hashcode* tuple-hashcode ;
+
M: tuple-class new
dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: union-class rank-class drop 2 ;
M: union-class instance?
- "members" word-prop [ instance? ] with contains? ;
+ "members" word-prop [ instance? ] with any? ;
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;
: case>quot ( default assoc -- quot )
dup keys {
{ [ dup empty? ] [ 2drop ] }
- { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
+ { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
- { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
+ { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] }
{ [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
[ drop linear-case-quot ]
} cond ;
[ t ] [
\ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] any?
] unit-test
[ ] [
[ f ] [
\ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] any?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
[ t ] [
\ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
] unit-test
[ ] [
[ f ] [
\ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
] unit-test
GENERIC: generic-forget-test-3 ( a -- b )
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting alien ;
+io.encodings.utf8 init assocs splitting alien io.streams.null ;
IN: io.backend
SYMBOL: io-backend
HOOK: init-io io-backend ( -- )
-HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
+HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? )
+
+: set-stdio ( input-handle output-handle error-handle -- )
+ [ input-stream set-global ]
+ [ output-stream set-global ]
+ [ error-stream set-global ] tri* ;
: init-stdio ( -- )
- (init-stdio)
- [ utf8 <decoder> input-stream set-global ]
- [ utf8 <encoder> output-stream set-global ]
- [ utf8 <encoder> error-stream set-global ] tri* ;
+ (init-stdio) [
+ [ utf8 <decoder> ]
+ [ utf8 <encoder> ]
+ [ utf8 <encoder> ] tri*
+ ] [
+ 3drop
+ null-reader null-writer null-writer
+ ] if set-stdio ;
HOOK: io-multiplex io-backend ( us -- )
USING: help.markup help.syntax io strings arrays io.backend
-io.files.private quotations ;
+io.files.private quotations sequences ;
IN: io.files
ARTICLE: "io.files" "Reading and writing files"
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } }
{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
+{ $notes "Most code should use " { $link with-file-reader } " instead, to ensure the stream is properly disposed of after." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: <file-writer>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." }
+{ $notes "Most code should use " { $link with-file-writer } " instead, to ensure the stream is properly disposed of after." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: <file-appender>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." }
+{ $notes "Most code should use " { $link with-file-appender } " instead, to ensure the stream is properly disposed of after." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-reader
{ $errors "Throws an error if the file cannot be opened for reading." } ;
HELP: set-file-contents
-{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
-{ $description "Sets the contents of a file to a string with the given encoding." }
+{ $values { "seq" sequence } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to a sequence with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
-{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
-{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" sequence } }
+{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a sequence." }
{ $errors "Throws an error if the file cannot be opened for reading." } ;
{ set-file-lines file-lines set-file-contents file-contents } related-words
USING: tools.test io.files io.files.private io.files.temp
io.directories io.encodings.8-bit arrays make system
-io.encodings.binary io
-threads kernel continuations io.encodings.ascii sequences
-strings accessors io.encodings.utf8 math destructors namespaces
-;
+io.encodings.binary io threads kernel continuations
+io.encodings.ascii sequences strings accessors
+io.encodings.utf8 math destructors namespaces ;
IN: io.files.tests
\ exists? must-infer
: with-file-reader ( path encoding quot -- )
[ <file-reader> ] dip with-input-stream ; inline
-: file-contents ( path encoding -- str )
+: file-contents ( path encoding -- seq )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
-: set-file-contents ( str path encoding -- )
+: set-file-contents ( seq path encoding -- )
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
13 getenv cwd prepend-path \ image set-global
14 getenv cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
-] "io.files" add-init-hook
\ No newline at end of file
+] "io.files" add-init-hook
: path-separator ( -- string ) os windows? "\\" "/" ? ;
-: trim-right-separators ( str -- newstr )
- [ path-separator? ] trim-right ;
+: trim-tail-separators ( str -- newstr )
+ [ path-separator? ] trim-tail ;
-: trim-left-separators ( str -- newstr )
- [ path-separator? ] trim-left ;
+: trim-head-separators ( str -- newstr )
+ [ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last-from ;
: parent-directory ( path -- parent )
dup root-directory? [
- trim-right-separators
+ trim-tail-separators
dup last-path-separator [
1+ cut
] [
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
- rest trim-left-separators append-path-empty
+ rest trim-head-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
- { [ over trim-right-separators "." = ] [ nip ] }
+ { [ over trim-tail-separators "." = ] [ nip ] }
{ [ dup absolute-path? ] [ nip ] }
- { [ dup head.? ] [ rest trim-left-separators append-path ] }
+ { [ dup head.? ] [ rest trim-head-separators append-path ] }
{ [ dup head..? ] [
- 2 tail trim-left-separators
+ 2 tail trim-head-separators
[ parent-directory ] dip append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
[ 2 head ] dip append
] }
[
- [ trim-right-separators "/" ] dip
- trim-left-separators 3append
+ [ trim-tail-separators "/" ] dip
+ trim-head-separators 3append
]
} cond ;
: file-name ( path -- string )
dup root-directory? [
- trim-right-separators
+ trim-tail-separators
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
M: string (normalize-path)
"resource:" ?head [
- trim-left-separators resource-path
+ trim-head-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
HOOK: home io-backend ( -- dir )
-M: object home "" resource-path ;
\ No newline at end of file
+M: object home "" resource-path ;
stdout-handle <c-writer>
stderr-handle <c-writer> ;
-M: c-io-backend (init-stdio) init-c-stdio ;
+M: c-io-backend (init-stdio) init-c-stdio t ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io destructors io.streams.plain ;
+IN: io.streams.null
+
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
+INSTANCE: null-writer plain-writer
+
+M: null-stream dispose drop ;
+
+M: null-reader stream-readln drop f ;
+M: null-reader stream-read1 drop f ;
+M: null-reader stream-read-until 2drop f f ;
+M: null-reader stream-read 2drop f ;
+
+M: null-writer stream-write1 2drop ;
+M: null-writer stream-write 2drop ;
+M: null-writer stream-flush drop ;
+
+: with-null-reader ( quot -- )
+ null-reader swap with-input-stream* ; inline
+
+: with-null-writer ( quot -- )
+ null-writer swap with-output-stream* ; inline
"Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:"
{ $subsection >quotation }
{ $subsection 1quotation }
+"Wrappers:"
+{ $subsection "wrappers" } ;
+
+ARTICLE: "wrappers" "Wrappers"
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
{ $subsection wrapper }
{ $subsection literalize }
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
-HELP: contains?
+HELP: any?
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
-HELP: pad-left
+HELP: pad-head
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-head print ] each" "---ab\n-quux" } } ;
-HELP: pad-right
+HELP: pad-tail
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-tail print ] each" "ab---\nquux-" } } ;
HELP: sequence=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
}
{ $notes "Used to implement the " { $link filter } " word." } ;
-HELP: trim-left
+HELP: trim-head
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head ."
"{ 1 2 3 0 0 }"
} ;
-HELP: trim-left-slice
+HELP: trim-head-slice
{ $values
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left-slice ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head-slice ."
"T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
-HELP: trim-right
+HELP: trim-tail
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail ."
"{ 0 0 1 2 3 }"
} ;
-HELP: trim-right-slice
+HELP: trim-tail-slice
{ $values
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
{ $example "" "USING: prettyprint math sequences ;"
- "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right-slice ."
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail-slice ."
"T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
"T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
-{ trim trim-slice trim-left trim-left-slice trim-right trim-right-slice } related-words
+{ trim trim-slice trim-head trim-head-slice trim-tail trim-tail-slice } related-words
HELP: sift
{ $values
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
-{ $subsection pad-left }
-{ $subsection pad-right } ;
+{ $subsection pad-head }
+{ $subsection pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
+{ $subsection any? }
{ $subsection all? }
{ $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
-{ $subsection trim-left }
-{ $subsection trim-right }
+{ $subsection trim-head }
+{ $subsection trim-tail }
"Potentially more efficient trim:"
{ $subsection trim-slice }
-{ $subsection trim-left-slice }
-{ $subsection trim-right-slice } ;
+{ $subsection trim-head-slice }
+{ $subsection trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test
-[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test
-[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
+[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-head ] unit-test
+[ "" ] [ " " [ CHAR: \s = ] trim-tail ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
-[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test
-[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test
+[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
+[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
: nths ( indices seq -- seq' )
[ nth ] curry map ;
-: contains? ( seq quot -- ? )
+: any? ( seq quot -- ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
- [ = ] with contains? ;
+ [ = ] with any? ;
: memq? ( elt seq -- ? )
- [ eq? ] with contains? ;
+ [ eq? ] with any? ;
: remove ( elt seq -- newseq )
[ = not ] with filter ;
[ <repetition> ] curry
] dip compose if ; inline
-: pad-left ( seq n elt -- padded )
+: pad-head ( seq n elt -- padded )
[ swap dup append-as ] padding ;
-: pad-right ( seq n elt -- padded )
+: pad-tail ( seq n elt -- padded )
[ append ] padding ;
: shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
-: trim-left-slice ( seq quot -- slice )
+: trim-head-slice ( seq quot -- slice )
over [ [ not ] compose find drop ] dip swap
[ tail-slice ] [ dup length tail-slice ] if* ; inline
-: trim-left ( seq quot -- newseq )
- over [ trim-left-slice ] dip like ; inline
+: trim-head ( seq quot -- newseq )
+ over [ trim-head-slice ] dip like ; inline
-: trim-right-slice ( seq quot -- slice )
+: trim-tail-slice ( seq quot -- slice )
over [ [ not ] compose find-last drop ] dip swap
[ 1+ head-slice ] [ 0 head-slice ] if* ; inline
-: trim-right ( seq quot -- newseq )
- over [ trim-right-slice ] dip like ; inline
+: trim-tail ( seq quot -- newseq )
+ over [ trim-tail-slice ] dip like ; inline
: trim-slice ( seq quot -- slice )
- [ trim-left-slice ] [ trim-right-slice ] bi ; inline
+ [ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq )
over [ trim-slice ] dip like ; inline
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
-{ $see-also member? memq? contains? all? "assocs-sets" } ;
+{ $see-also member? memq? any? all? "assocs-sets" } ;
ABOUT: "sets"
tester filter ;
: intersects? ( seq1 seq2 -- ? )
- tester contains? ;
+ tester any? ;
: diff ( seq1 seq2 -- newseq )
tester [ not ] compose filter ;
]
unit-test
-[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test
-[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test
+[ "05" ] [ "5" 2 CHAR: 0 pad-head ] unit-test
+[ "666" ] [ "666" 2 CHAR: 0 pad-head ] unit-test
[ 1 "" nth ] must-fail
[ -6 "hello" nth ] must-fail
HELP: GENERIC#
{ $syntax "GENERIC# word n" }
-{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on, either 0, 1 or 2" } }
+{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $notes
"The following two definitions are equivalent:"
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax
- "\\" [ scan-word literalize parsed ] define-syntax
+ "\\" [ scan-word <wrapper> parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
"recursive" [ word make-recursive ] define-syntax
"foldable" [ word make-foldable ] define-syntax
[
all-words [
"compiled-uses" word-prop
- keys [ "forgotten" word-prop ] contains?
+ keys [ "forgotten" word-prop ] any?
] filter
] unit-test
crossref get at keys
[ word? ] filter
[
- [ reset-on-redefine [ word-prop ] with contains? ]
+ [ reset-on-redefine [ word-prop ] with any? ]
[ inline? ]
bi or
] filter
+++ /dev/null
-! 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"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-namespaces\r
-accessors\r
-make\r
-math\r
-math.functions\r
-math.trig\r
-math.parser\r
-hashtables\r
-sequences\r
-combinators\r
-continuations\r
-colors\r
-prettyprint\r
-vars\r
-quotations\r
-io\r
-io.directories\r
-io.pathnames\r
-help.markup\r
-io.files\r
-ui.gadgets.panes\r
- ui\r
- ui.gadgets\r
- ui.traverse\r
- ui.gadgets.borders\r
- ui.gadgets.handler\r
- ui.gadgets.slate\r
- ui.gadgets.theme\r
- ui.gadgets.frames\r
- ui.gadgets.tracks\r
- ui.gadgets.labels\r
- ui.gadgets.labelled \r
- ui.gadgets.lists\r
- ui.gadgets.buttons\r
- ui.gadgets.packs\r
- ui.gadgets.grids\r
- ui.gestures\r
- ui.tools.workspace\r
- ui.gadgets.scrollers\r
-splitting\r
-vectors\r
-math.vectors\r
-rewrite-closures\r
-self\r
-values\r
-4DNav.turtle\r
-4DNav.window3D\r
-4DNav.deep\r
-4DNav.space-file-decoder\r
-models\r
-fry\r
-adsoda\r
-adsoda.tools\r
-;\r
-\r
-IN: 4DNav\r
-VALUE: selected-file\r
-VALUE: translation-step\r
-VALUE: rotation-step\r
-\r
-3 to: translation-step \r
-5 to: rotation-step\r
-\r
-VAR: selected-file-model\r
-VAR: observer3d \r
-VAR: view1 \r
-VAR: view2\r
-VAR: view3\r
-VAR: view4\r
-VAR: present-space\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-! replacement of namespaces.lib\r
- \r
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! waiting for deep-cleave-quots\r
-\r
-: 4D-Rxy ( angle -- Rx ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , dup cos , dup sin neg ,\r
- 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxz ( angle -- Ry ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , 0.0 , dup sin neg ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxw ( angle -- Rz ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , dup sin neg , 0.0 ,\r
- 0.0 , dup sin , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryz ( angle -- Rx ) deg>rad\r
-[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryw ( angle -- Ry ) deg>rad\r
-[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- dup sin , 0.0 , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rzw ( angle -- Rz ) deg>rad\r
-[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
- dup sin , dup cos , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! UI\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: button* ( string quot -- button ) closed-quot <repeat-button> ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: model-projection-chooser ( -- gadget )\r
- observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
-\r
-: collision-detection-chooser ( -- gadget )\r
- observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <toggle-buttons>\r
-;\r
-\r
-: model-projection ( x -- space ) present-space> swap space-project ;\r
-\r
-: update-observer-projections ( -- )\r
- view1> relayout-1 \r
- view2> relayout-1 \r
- view3> relayout-1 \r
- view4> relayout-1 ;\r
-\r
-: update-model-projections ( -- )\r
- 0 model-projection <model> view1> (>>model)\r
- 1 model-projection <model> view2> (>>model)\r
- 2 model-projection <model> view3> (>>model)\r
- 3 model-projection <model> view4> (>>model) ;\r
-\r
-: camera-action ( quot -- quot ) \r
- [ drop [ ] observer3d> with-self update-observer-projections ] \r
- make* closed-quot ;\r
-\r
-: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! 4D object manipulation\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: (mvt-4D) ( quot -- ) \r
- present-space> \r
- swap call space-ensure-solids \r
- >present-space \r
- update-model-projections \r
- update-observer-projections ;\r
-\r
-: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip\r
- space-transform \r
- swap space-translate\r
- ] (mvt-4D) ;\r
-\r
-: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! menu\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: menu-rotations-4D ( -- gadget )\r
- <frame>\r
- <pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget \r
- @top grid-add \r
- <pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget \r
- @center grid-add\r
- <pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget \r
- @top-right grid-add \r
- <pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget \r
- @right grid-add \r
- <pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget \r
- @bottom-right grid-add \r
-;\r
-\r
-: menu-translations-4D ( -- gadget )\r
- <frame> \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
- button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "YZW" <label> add-gadget\r
- @bottom-right grid-add\r
- <pile> 1 >>fill\r
- "XZW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ] \r
- button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- @top-right grid-add\r
- <pile> 1 >>fill\r
- "XYW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ] \r
- button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ] \r
- button* add-gadget \r
- add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ] \r
- button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "XYZ" <label> add-gadget\r
- @bottom-left grid-add \r
- "X" <label> @center grid-add\r
-;\r
-\r
-: menu-4D ( -- gadget ) \r
- <shelf> \r
- "rotations" <label> add-gadget\r
- menu-rotations-4D add-gadget\r
- "translations" <label> add-gadget\r
- menu-translations-4D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
-;\r
-\r
-\r
-! ------------------------------------------------------\r
-\r
-: redraw-model ( space -- )\r
- >present-space \r
- update-model-projections \r
- update-observer-projections ;\r
-\r
-: load-model-file ( -- )\r
- selected-file dup selected-file-model> set-model read-model-file \r
- redraw-model ;\r
-\r
-: mvt-3D-X ( turn pitch -- quot )\r
- '[ turtle-pos> norm neg reset-turtle \r
- _ turn-left \r
- _ pitch-up \r
- step-turtle ] ;\r
-\r
-: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
-: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
-: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
-: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
-\r
-: camera-button ( string quot -- button ) \r
- [ <label> ] dip camera-action <repeat-button> ;\r
-\r
-! ----------------------------------------------------------\r
-! file chooser\r
-! ----------------------------------------------------------\r
-: <run-file-button> ( file-name -- button )\r
- dup '[ drop _ \ selected-file set-value load-model-file \r
- ] \r
- closed-quot <roll-button> { 0 0 } >>align ;\r
-\r
-: <list-runner> ( -- gadget )\r
- "resource:extra/4DNav" \r
- <pile> 1 >>fill \r
- over dup directory-files \r
- [ ".xml" tail? ] filter \r
- [ append-path ] with map\r
- [ <run-file-button> add-gadget ] each\r
- swap <labelled-gadget> ;\r
-\r
-! -----------------------------------------------------\r
-\r
-: menu-rotations-3D ( -- gadget )\r
- <frame>\r
- "Turn\n left" [ rotation-step turn-left ] camera-button \r
- @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] camera-button \r
- @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] camera-button \r
- @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] camera-button \r
- @top grid-add \r
- <shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button\r
- add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button \r
- add-gadget \r
- @center grid-add \r
-;\r
-\r
-: menu-translations-3D ( -- gadget )\r
- <frame>\r
- "left\n(alt)" [ translation-step strafe-left ] camera-button\r
- @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ] camera-button\r
- @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button\r
- @top grid-add\r
- "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button\r
- @bottom grid-add \r
- <pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] camera-button\r
- add-gadget\r
- "Backward (ctl)" [ translation-step neg step-turtle ] camera-button\r
- add-gadget\r
- @center grid-add\r
-;\r
-\r
-: menu-quick-views ( -- gadget )\r
- <shelf>\r
- "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
- "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
- "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
- "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
-;\r
-\r
-: menu-3D ( -- gadget ) \r
- <pile>\r
- <shelf> \r
- menu-rotations-3D add-gadget\r
- menu-translations-3D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
- add-gadget\r
- menu-quick-views add-gadget ; \r
-\r
-: add-keyboard-delegate ( obj -- obj )\r
- <handler>\r
-{\r
- { T{ key-down f f "LEFT" } \r
- [ [ rotation-step turn-left ] camera-action ] }\r
- { T{ key-down f f "RIGHT" } \r
- [ [ rotation-step turn-right ] camera-action ] }\r
- { T{ key-down f f "UP" } \r
- [ [ rotation-step pitch-down ] camera-action ] }\r
- { T{ key-down f f "DOWN" } \r
- [ [ rotation-step pitch-up ] camera-action ] }\r
-\r
- { T{ key-down f { C+ } "UP" } \r
- [ [ translation-step step-turtle ] camera-action ] }\r
- { T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step neg step-turtle ] camera-action ] }\r
- { T{ key-down f { C+ } "LEFT" } \r
- [ [ rotation-step roll-left ] camera-action ] }\r
- { T{ key-down f { C+ } "RIGHT" } \r
- [ [ rotation-step roll-right ] camera-action ] }\r
-\r
- { T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
- { T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
- { T{ key-down f { A+ } "UP" } \r
- [ [ translation-step strafe-up ] camera-action ] }\r
- { T{ key-down f { A+ } "DOWN" } \r
- [ [ translation-step strafe-down ] camera-action ] }\r
-\r
-\r
- { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
- { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
- { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
- { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
-\r
- } [ make* ] map >hashtable >>table\r
- ; \r
-\r
-! --------------------------------------------\r
-! print elements \r
-! --------------------------------------------\r
-! print-content\r
-\r
-GENERIC: adsoda-display-model ( x -- ) \r
-\r
-M: light adsoda-display-model \r
-"\n light : " .\r
- { \r
- [ direction>> "direction : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- } cleave\r
- ;\r
-\r
-M: face adsoda-display-model \r
- {\r
- [ halfspace>> "halfspace : " pprint . ] \r
- [ touching-corners>> "touching corners : " pprint . ]\r
- } cleave\r
- ;\r
-M: solid adsoda-display-model \r
- {\r
- [ name>> "solid called : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- [ dimension>> "dimension : " pprint . ]\r
- [ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]\r
- } cleave\r
- ;\r
-M: space adsoda-display-model \r
- {\r
- [ dimension>> "dimension : " pprint . ] \r
- [ ambient-color>> "ambient-color : " pprint . ]\r
- [ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ] \r
- } cleave\r
- ;\r
-\r
-! ----------------------------------------------\r
-: menu-bar ( -- gadget )\r
- <shelf>\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
- ;\r
-\r
-\r
-: controller-window* ( -- gadget )\r
- { 0 1 } <track>\r
- menu-bar f track-add\r
- <list-runner> \r
- <limited-scroller> \r
- { 200 400 } >>max-dim\r
- f track-add\r
- <shelf>\r
- "Projection mode : " <label> add-gadget\r
- model-projection-chooser add-gadget\r
- f track-add\r
- <shelf>\r
- "Collision detection (slow and buggy ) : " <label> add-gadget\r
- collision-detection-chooser add-gadget\r
- f track-add\r
- <pile>\r
- 0.5 >>align \r
- menu-4D add-gadget \r
- light-purple solid-interior\r
- "4D movements" <labelled-gadget>\r
- f track-add\r
- <pile>\r
- 0.5 >>align\r
- { 2 2 } >>gap\r
- menu-3D add-gadget\r
- light-purple solid-interior \r
- "Camera 3D" <labelled-gadget>\r
- f track-add \r
- gray solid-interior\r
- ;\r
- \r
-: viewer-windows* ( -- )\r
- "YZW" view1> win3D \r
- "XZW" view2> win3D \r
- "XYW" view3> win3D \r
- "XYZ" view4> win3D \r
-;\r
-\r
-: navigator-window* ( -- )\r
- controller-window*\r
- viewer-windows* \r
- add-keyboard-delegate\r
- "navigateur 4D" open-window\r
-;\r
-\r
-: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
-\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: init-variables ( -- )\r
- "choose a file" <model> >selected-file-model \r
- <observer> >observer3d\r
- [ observer3d> >self\r
- reset-turtle \r
- 45 turn-left \r
- 45 pitch-up \r
- -300 step-turtle \r
- ] with-scope\r
- \r
-;\r
-\r
-\r
-: init-models ( -- )\r
- 0 model-projection observer3d> <window3D> >view1\r
- 1 model-projection observer3d> <window3D> >view2\r
- 2 model-projection observer3d> <window3D> >view3\r
- 3 model-projection observer3d> <window3D> >view4\r
-;\r
-\r
-: 4DNav ( -- ) \r
- init-variables\r
- selected-file read-model-file >present-space\r
- init-models\r
- windows\r
-;\r
-\r
-MAIN: 4DNav\r
-\r
-\r
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! 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"
+++ /dev/null
-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 ;
+++ /dev/null
-! 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"
+++ /dev/null
-USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;\r
-IN: 4DNav.deep\r
-\r
-! USING: bake ;\r
-! MACRO: deep-cleave-quots ( seq -- quot )\r
-! [ [ quotation? ] deep-filter ]\r
-! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
-! bi '[ _ cleave _ bake ] ;\r
-\r
-: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline\r
-\r
+++ /dev/null
-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 }
-}
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING:\r
-kernel\r
-io.files\r
-io.backend\r
-io.directories\r
-io.files.info\r
-io.pathnames\r
-sequences\r
-models\r
-strings\r
-ui\r
-ui.operations\r
-ui.commands\r
-ui.gestures\r
-ui.gadgets\r
-ui.gadgets.buttons\r
-ui.gadgets.lists\r
-ui.gadgets.labels\r
-ui.gadgets.tracks\r
-ui.gadgets.packs\r
-ui.gadgets.panes\r
-ui.gadgets.scrollers\r
-prettyprint\r
-combinators\r
-rewrite-closures\r
-accessors\r
-values\r
-tools.walker\r
-fry\r
-;\r
-IN: 4DNav.file-chooser\r
-\r
-TUPLE: file-chooser < track \r
- path\r
- extension \r
- selected-file\r
- presenter\r
- hook \r
- list\r
- ;\r
-\r
-: find-file-list ( gadget -- list )\r
- [ file-chooser? ] find-parent list>> ;\r
-\r
-file-chooser H{\r
- { T{ key-down f f "UP" } [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }\r
- { T{ button-down } request-focus }\r
- { T{ button-down f 1 } [ find-file-list invoke-value-action ] }\r
-} set-gestures\r
-\r
-: list-of-files ( file-chooser -- seq )\r
- [ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
-;\r
-\r
-: update-filelist-model ( file-chooser -- file-chooser )\r
- [ list-of-files ] [ model>> ] bi set-model ;\r
-\r
-: init-filelist-model ( file-chooser -- file-chooser )\r
- dup list-of-files <model> >>model ; \r
-\r
-: (fc-go) ( file-chooser quot -- )\r
- [ [ file-chooser? ] find-parent dup path>> ] dip\r
- call\r
- normalize-path swap set-model\r
- update-filelist-model\r
- drop ;\r
-\r
-: fc-go-parent ( file-chooser -- )\r
- [ dup value>> parent-directory ] (fc-go) ;\r
-\r
-: fc-go-home ( file-chooser -- )\r
- [ home ] (fc-go) ;\r
-\r
-: fc-change-directory ( file-chooser file -- file-chooser )\r
- dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
- append-path over path>> set-model \r
- update-filelist-model\r
-;\r
-\r
-: fc-load-file ( file-chooser file -- )\r
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
- [ path>> value>> ] \r
- [ selected-file>> value>> append ] \r
- [ hook>> ] tri\r
- call\r
-; inline\r
-\r
-! : fc-ok-action ( file-chooser -- quot )\r
-! dup selected-file>> value>> "" =\r
-! [ drop [ drop ] ] [ \r
-! [ path>> value>> ] \r
-! [ selected-file>> value>> append ] \r
-! [ hook>> prefix ] tri\r
-! [ drop ] prepend\r
-! ] if ; \r
-\r
-: line-selected-action ( file-chooser -- )\r
- dup list>> list-value\r
- dup directory? \r
- [ fc-change-directory ] [ fc-load-file ] if ;\r
-\r
-: present-dir-element ( element -- string )\r
- [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
-\r
-: <file-list> ( file-chooser -- list )\r
- dup [ nip line-selected-action ] curry \r
- [ present-dir-element ] rot model>> <list> ;\r
-\r
-: <file-chooser> ( hook path extension -- gadget )\r
- { 0 1 } file-chooser new-track\r
- swap >>extension\r
- swap <model> >>path\r
- "" <model> >>selected-file\r
- swap >>hook\r
- init-filelist-model\r
- dup <file-list> >>list\r
- "choose a file in directory " <label> f track-add\r
- dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend <label> f track-add\r
- <shelf> \r
- "selected file : " <label> add-gadget\r
- over selected-file>> <label-control> add-gadget\r
- f track-add\r
- <shelf> \r
- over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget\r
- ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
- f track-add\r
- dup list>> <scroller> 1 track-add\r
-;\r
-\r
-M: file-chooser pref-dim* drop { 400 200 } ;\r
-\r
-: file-chooser-window ( -- )\r
-[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
-\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>hypercube</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,0,0,0</direction>\r
- <color>0,0,0,0.6</color>\r
- </light>\r
- <light>\r
- <direction>0,1,0,0</direction>\r
- <color>0,0.6,0,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,1,0</direction>\r
- <color>0,0,0.6,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,0,1</direction>\r
- <color>0.6,0.6,0.6</color>\r
- </light>\r
- <color>0.99,0.99,0.99</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>Prismetragone</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! 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"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
-sequences math.parser kernel splitting values continuations ;\r
-IN: 4DNav.space-file-decoder\r
-\r
-: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
-\r
-PROCESS: adsoda-read-model ( tag -- )\r
-\r
-TAG: dimension adsoda-read-model children>> first string>number ;\r
-TAG: direction adsoda-read-model children>> first decode-number-array ;\r
-TAG: color adsoda-read-model children>> first decode-number-array ;\r
-TAG: name adsoda-read-model children>> first ;\r
-TAG: face adsoda-read-model children>> first decode-number-array ;\r
-\r
-TAG: solid adsoda-read-model \r
- <solid> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \r
- } cleave\r
- ensure-adjacencies\r
-;\r
-\r
-TAG: light adsoda-read-model \r
- <light> swap \r
- { \r
- [ "direction" tag-named adsoda-read-model >>direction ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- } cleave\r
-;\r
-\r
-TAG: space adsoda-read-model \r
- <space> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>ambient-color ] \r
- [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ] \r
- [ "light" tags-named [ adsoda-read-model suffix-lights ] each ] \r
- } cleave\r
-;\r
-\r
-: read-model-file ( path -- x )\r
- dup\r
- [\r
- [ file>xml "space" tags-named first adsoda-read-model ] \r
- [ drop <space> ] recover \r
- ] [ drop <space> ] if \r
-\r
-;\r
-\r
+++ /dev/null
-4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
+++ /dev/null
-4D viewer
\ No newline at end of file
+++ /dev/null
-<model>\r
-<space>\r
- <name>triancube</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-! 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"
+++ /dev/null
-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 ;
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! 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"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-ui.gadgets\r
-ui.render\r
-opengl\r
-opengl.gl\r
-opengl.glu\r
-4DNav.camera\r
-4DNav.turtle\r
-math\r
-values\r
-alien.c-types\r
-accessors\r
-namespaces\r
-adsoda \r
-models\r
-accessors\r
-prettyprint\r
-;\r
-\r
-IN: 4DNav.window3D\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! drawing functions \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-TUPLE: window3D < gadget observer ; \r
-\r
-: <window3D> ( model observer -- gadget )\r
- window3D new-gadget \r
- swap 2dup \r
- projection-mode>> add-connection\r
- 2dup \r
- collision-mode>> add-connection\r
- >>observer \r
- swap <model> >>model \r
- t >>root?\r
-;\r
-\r
-M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
-\r
-M: window3D draw-gadget* ( gadget -- )\r
-\r
- GL_PROJECTION glMatrixMode\r
- glLoadIdentity\r
- 0.6 0.6 0.6 .9 glClearColor\r
- dup observer>> projection-mode>> value>> 1 = \r
- [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
- [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
- dup observer>> collision-mode>> value>> \r
- \ remove-hidden-solids? \r
- set-value\r
- dup observer>> do-look-at\r
- GL_MODELVIEW glMatrixMode\r
- glLoadIdentity \r
- 0.9 0.9 0.9 1.0 glClearColor\r
- 1.0 glClearDepth\r
- GL_LINE_SMOOTH glEnable\r
- GL_BLEND glEnable\r
- GL_DEPTH_TEST glEnable \r
- GL_LEQUAL glDepthFunc\r
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
- GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
- 1.25 glLineWidth\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
- glLoadIdentity\r
- GL_LIGHTING glEnable\r
- GL_LIGHT0 glEnable\r
- GL_COLOR_MATERIAL glEnable\r
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
- ! *************************\r
- \r
- model>> value>> \r
- [ space->GL ] when*\r
-\r
- ! *************************\r
-;\r
-\r
-M: window3D graft* drop ;\r
-\r
-M: window3D model-changed nip relayout ; \r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax ;\r
-\r
-IN: adsoda\r
-\r
-\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-ARTICLE: "face-page" "face in ADSODA"\r
-"explanation of faces"\r
-$nl\r
-"link to functions"\r
-"what is an halfspace"\r
-"halfspace touching-corners adjacent-faces"\r
-"touching-corners list of pointers to the corners which touch this face\n"\r
-\r
-"adjacent-faces list of pointers to the faces which touch this face\n"\r
-{ $subsection face }\r
-{ $subsection <face> }\r
-"test relative position"\r
-{ $subsection point-inside-or-on-face? } \r
-{ $subsection point-inside-face? }\r
-"handling face"\r
-{ $subsection flip-face }\r
-{ $subsection face-translate }\r
-{ $subsection face-transform }\r
-\r
-;\r
-\r
-HELP: face\r
-{ $class-description "a face is defined by"\r
-{ $list "halfspace equation" }\r
-{ $list "list of touching corners" }\r
-{ $list "list of adjacent faces" }\r
-$nl\r
-"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
-}\r
-\r
-\r
-;\r
-HELP: <face> \r
-{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
-HELP: flip-face \r
-{ $values { "face" "a face" } { "face" "flipped face" } }\r
-{ $description "change the orientation of a face" }\r
-;\r
-\r
-HELP: face-translate \r
-{ $values { "face" "a face" } { "v" "a vector" } }\r
-{ $description \r
-"translate a face following a vector"\r
-$nl\r
-"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
-\r
- \r
- ;\r
-HELP: face-transform \r
-{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
-{ $description "compute the transformation of a face using a transformation matrix" }\r
- \r
- ;\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "solid in ADSODA"\r
-"explanation of solids"\r
-$nl\r
-"link to functions"\r
-{ $subsection solid }\r
-{ $subsection <solid> }\r
-"test relative position"\r
-{ $subsection point-inside-solid? }\r
-{ $subsection point-inside-or-on-solid? }\r
-"playing with faces and solids"\r
-{ $subsection add-face }\r
-{ $subsection cut-solid }\r
-{ $subsection slice-solid }\r
-"solid handling"\r
-{ $subsection solid-project }\r
-{ $subsection solid-translate }\r
-{ $subsection solid-transform }\r
-{ $subsection subtract }\r
-\r
-{ $subsection get-silhouette }\r
-\r
-{ $subsection solid= }\r
-\r
-\r
-;\r
-\r
-HELP: solid \r
-{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
-}\r
-;\r
-\r
-HELP: add-face \r
-{ $values { "solid" "a solid" } { "face" "a face" } }\r
-{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
-\r
-HELP: cut-solid\r
-{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
-{ $description "like add-face but just with halfspace equation" } ;\r
-\r
-HELP: slice-solid\r
-{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
-{ $description "cut a solid into two parts. The face acts like a knife"\r
-} ;\r
-\r
-\r
-HELP: solid-project\r
-{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
-{ $description "Project the solid using pv vector" \r
-$nl\r
-"TODO: explain how to use lights"\r
-} ;\r
-\r
-HELP: solid-translate \r
-{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
-{ $description "Translate a solid using a vector" \r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: solid-transform \r
-{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
-{ $description "Transform a solid using a matrix"\r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: subtract \r
-{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description " " } ;\r
-\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-ARTICLE: "space-page" "space in ADSODA"\r
-"A space is a collection of solids and lights."\r
-$nl\r
-"link to functions"\r
-$nl\r
-"Defining words"\r
-{ $subsection space }\r
-{ $subsection <space> } \r
-{ $subsection suffix-solids }\r
-{ $subsection suffix-lights }\r
-{ $subsection clear-space-solids }\r
-{ $subsection describe-space }\r
-\r
-\r
-"Handling space"\r
-{ $subsection space-ensure-solids }\r
-{ $subsection eliminate-empty-solids }\r
-{ $subsection space-transform }\r
-{ $subsection space-translate }\r
-{ $subsection remove-hidden-solids }\r
-{ $subsection space-project }\r
-\r
-\r
-;\r
-\r
-HELP: space \r
-{ $class-description \r
-"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
-}\r
-;\r
-\r
-HELP: suffix-solids \r
-"( space solid -- space )"\r
-{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
-{ $description "Add solid to space definition" } ;\r
-\r
-HELP: suffix-lights \r
-"( space light -- space ) "\r
-{ $values { "space" "a space" } { "light" "a light to add" } }\r
-{ $description "Add a light to space definition" } ;\r
-\r
-HELP: clear-space-solids \r
-"( space -- space )" \r
-{ $values { "space" "a space" } }\r
-{ $description "remove all solids in space" } ;\r
-\r
-HELP: space-ensure-solids \r
-{ $values { "space" "a space" } }\r
-{ $description "rebuild corners of all solids in space" } ;\r
-\r
-\r
-\r
-HELP: space-transform \r
-" ( space m -- space )" \r
-{ $values { "space" "a space" } { "m" "a matrix" } }\r
-{ $description "Transform a space using a matrix" } ;\r
-\r
-HELP: space-translate \r
-{ $values { "space" "a space" } { "v" "a vector" } }\r
-{ $description "Translate a space following a vector" } ;\r
-\r
-HELP: describe-space " ( space -- )"\r
-{ $values { "space" "a space" } }\r
-{ $description "return a description of space" } ;\r
-\r
-HELP: space-project \r
-{ $values { "space" "a space" } { "i" "an integer" } }\r
-{ $description "Project a space along ith coordinate" } ;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\r
-"explanation of 3D rendering"\r
-$nl\r
-"link to functions"\r
-{ $subsection face->GL }\r
-{ $subsection solid->GL }\r
-{ $subsection space->GL }\r
-\r
-;\r
-\r
-HELP: face->GL \r
-{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "" } ;\r
-\r
-HELP: solid->GL \r
-{ $values { "solid" "a solid" } }\r
-{ $description "" } ;\r
-\r
-HELP: space->GL \r
-{ $values { "space" "a space" } }\r
-{ $description "" } ;\r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-ARTICLE: "light-page" "light in ADSODA"\r
-"explanation of light"\r
-$nl\r
-"link to functions"\r
-;\r
-\r
-ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-"! HELP: light position color" \r
-"! <light> ( -- tuple ) light new ;"\r
-\r
-"! light est un vecteur avec 3 variables pour les couleurs\n"\r
-\r
-" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"\r
-" { \n"\r
-" // Dot the light direction with the normalized normal of Face."\r
-" register double intensity = -(normal * (*this));"\r
-\r
-" // Face is a backface, from light's perspective"\r
-" if (intensity < 0)"\r
-" return;"\r
-" "\r
-" // Add the intensity componentwise"\r
-" cRed += red * intensity;"\r
-" cGreen += green * intensity;"\r
-" cBlue += blue * intensity;"\r
-\r
-" // Clip to unit range"\r
-" if (cRed > 1.0) cRed = 1.0;"\r
-" if (cGreen > 1.0) cGreen = 1.0;"\r
-" if (cBlue > 1.0) cBlue = 1.0;"\r
-\r
-\r
-;\r
-\r
-\r
-\r
-ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-"! demi espace défini par un vecteur normal et une constante"\r
-" defined by the concatenation of the normal vector and a constant" \r
- ;\r
-\r
-\r
-\r
-ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
-"multidimensional handler :" \r
-$nl\r
-"design a solid using face delimitations. Only works on convex shapes"\r
-$nl\r
-{ $emphasis "written in C++ by Greg Ferrar" }\r
-$nl\r
-"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
-$nl\r
-"Useful words are describe on the following pages: "\r
-{ $subsection "face-page" }\r
-{ $subsection "solid-page" }\r
-{ $subsection "space-page" }\r
-{ $subsection "light-page" }\r
-{ $subsection "3D-rendering-page" }\r
- ;\r
-\r
-ABOUT: "adsoda-main-page"\r
+++ /dev/null
-USING: adsoda\r
-kernel\r
-math\r
-accessors\r
-sequences\r
- adsoda.solution2\r
- fry\r
- tools.test \r
- arrays ;\r
-\r
-IN: adsoda.tests\r
-\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
-\r
-\r
-! {\r
-! { 1 0 0 0 }\r
-! { 0 1 0 0 }\r
-! { 0 0 0.984807753012208 -0.1736481776669303 }\r
-! { 0 0 0.1736481776669303 0.984807753012208 }\r
-! }\r
-\r
-! ------------------------------------------------------------\r
-! constant+\r
-[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! translate\r
-[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! transform\r
-[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 }\r
- } transform \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! compare-nleft-to-identity-matrix\r
-[ t ] [ \r
- { \r
- { 1 0 0 1232 } \r
- { 0 1 0 0 321 } \r
- { 0 0 1 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-! ------------------------------------------------------------\r
-[ t ] [ \r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 2 valid-solution? \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-[ 3 ] [ { 1 2 3 } last ] unit-test \r
-\r
-[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
-\r
-! ------------------------------------------------------------\r
-! position-point \r
-[ 0 ] [ \r
- { 1 -1 -5 } { 2 7 } position-point \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-\r
-! transform\r
-! TODO construire un exemple\r
-\r
-\r
-! ------------------------------------------------------------\r
-! slice-solid \r
-\r
-! ------------------------------------------------------------\r
-! solve-equation \r
-! deux cas de tests, avec solution et sans solution\r
-\r
-[ { 2 7 } ] \r
-[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-! ------------------------------------------------------------\r
-! point-inside-halfspace\r
-[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
-unit-test\r
-[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
-unit-test\r
-[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
-unit-test\r
-\r
-\r
-! ------------------------------\r
-! order solid\r
-\r
-[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
-[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
-\r
-\r
-! clip-solid\r
-[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
- [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-solid2 corners>> '[ _ ]\r
- [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-!\r
-[\r
- {\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
- }\r
-] [ 0 >pv solid2 solid3 2array \r
- solid1 (solids-silhouette-subtract) \r
- [ corners>> ] map\r
- ] unit-test\r
-\r
-\r
-[\r
-{\r
- { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
-}\r
-] [ \r
- 0 >pv <space> solid1 suffix-solids \r
- solid2 suffix-solids \r
- solid3 suffix-solids\r
- remove-hidden-solids\r
- solids>> [ corners>> ] map\r
-] unit-test\r
-\r
-! { }\r
-! { }\r
-! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
-! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
-! suffix \r
-! { 0.1 0.1 0.1 } suffix ! ambient color\r
-! { 0.23 0.32 0.17 } suffix ! solid color\r
-! solid3 faces>> first \r
-\r
-! enlight-projection\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! ---------------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t to: remove-hidden-solids?\r
-0.0000001 to: VERY-SMALL-NUM\r
-0.0000001 to: ZERO-VALUE\r
-4 to: MAX-FACE-PER-CORNER\r
-! ---------------------------------------------------------------------\r
-! sequence complement\r
-\r
-: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
-\r
-: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
-: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -----------------------------------------------------------------------\r
-! halfspace manipulation\r
-! -----------------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\r
- [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
- ! be sure it's not null vector\r
- last ! get constant\r
- swap /f neg swap ! intercept value\r
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM > ; \r
-: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
-\r
-: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
-\r
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-\r
-TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
-: <face> ( v -- tuple ) face new swap >>halfspace ;\r
-: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
-: faces-intersection ( faces -- v ) \r
- [ halfspace>> ] map intersect-hyperplanes ;\r
-: face-translate ( face v -- face ) \r
- [ translate ] curry change-halfspace ; inline\r
-: face-transform ( face m -- face )\r
- [ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
-: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
-: pv-factor ( face -- f face ) \r
- halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
-: suffix-touching-corner ( face corner -- face ) \r
- [ suffix ] curry change-touching-corners ; inline\r
-: real-face? ( face -- ? )\r
- [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup adjacent-faces>> [ intersection-into-face ] with map \r
- [ ] filter ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- [ ] filter\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
-\r
-: <solid> ( -- tuple ) solid new ;\r
-\r
-: suffix-silhouettes ( solid silhouette -- solid ) \r
- [ suffix ] curry change-silhouettes ;\r
-\r
-: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
-\r
-: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
-\r
-: erase-solid-corners ( solid -- solid ) f >>corners ;\r
-\r
-: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
-\r
-: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
-\r
-: initiate-solid-from-face ( face -- solid ) \r
- face-project-dim <solid> swap >>dimension ;\r
-\r
-: erase-old-adjacencies ( solid -- solid )\r
- erase-solid-corners\r
- [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-halfspace? ;\r
-\r
-: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
-\r
-: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- [ ] filter \r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\r
-: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
-\r
-: compare-corners-roughly ( corner corner -- ? )\r
- 2drop t ;\r
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- [ ] filter \r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\r
-: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
-\r
-: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
- pv> swap silhouettes>> nth \r
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
-: clear-space-solids ( space -- space ) f >>solids ;\r
-\r
-: space-ensure-solids ( space -- space ) \r
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ drop ] recover drop ;\r
-: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
-\r
-: describe-space ( space -- ) \r
- solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because during substration \r
-! a solid can be divided in more than on solid\r
- [ \r
- [ [ 1array ] map ] \r
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
- bi\r
- ; inline\r
-\r
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+++ /dev/null
-! : init-4D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 4 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
- { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-! : init-3D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 3 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
- ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
+++ /dev/null
-Jeff Bigot\r
-Greg Ferrar
\ No newline at end of file
+++ /dev/null
-JF Bigot, after Greg Ferrar
\ No newline at end of file
+++ /dev/null
-! 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"
+++ /dev/null
-USING: adsoda.combinators\r
-sequences\r
- tools.test \r
- ;\r
-\r
-IN: adsoda.combinators.tests\r
-\r
-\r
-[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
- unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays sequences fry math combinators ;\r
-\r
-IN: adsoda.combinators\r
-\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
-\r
-! : prefix-each [ prefix ] curry map ; inline\r
-\r
-! : combinations ( seq n -- seqs )\r
-! {\r
-! { [ dup 0 = ] [ 2drop { { } } ] }\r
-! { [ over empty? ] [ 2drop { } ] }\r
-! { [ t ] [ \r
-! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
-! [ (combinations) ] 2bi append\r
-! ] }\r
-! } cond ;\r
-\r
-: columnize ( array -- array ) [ 1array ] map ; inline\r
-\r
-: among ( array n -- array )\r
- 2dup swap length \r
- {\r
- { [ over 1 = ] [ 3drop columnize ] }\r
- { [ over 0 = ] [ 2drop 2drop { } ] }\r
- { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1- among [ append ] with map ] \r
- [ among append ] 2bi\r
- ] }\r
- { [ 2dup = ] [ 3drop 1array ] }\r
- { [ 2dup > ] [ 2drop 2drop { } ] } \r
- } cond\r
-;\r
-\r
-: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\r
-\r
-: do-cycle ( array -- array ) dup first suffix ;\r
-\r
-: map-but ( seq i quot -- seq )\r
- ! quot : ( seq x -- seq )\r
- '[ _ = [ @ ] unless ] map-index ; inline\r
-\r
+++ /dev/null
-USING: kernel\r
-sequences\r
-namespaces\r
-\r
-math\r
-math.vectors\r
-math.matrices\r
-;\r
-IN: adsoda.solution2\r
-\r
-! -------------------\r
-! correctif solution\r
-! ---------------\r
-SYMBOL: matrix\r
-: MIN-VAL-adsoda ( -- x ) 0.00000001\r
-! 0.000000000001 \r
-;\r
-\r
-: zero? ( x -- ? ) \r
- abs MIN-VAL-adsoda <\r
-;\r
-\r
-! [ number>string string>number ] map \r
-\r
-: with-matrix ( matrix quot -- )\r
- [ swap matrix set call matrix get ] with-scope ; inline\r
-\r
-: nth-row ( row# -- seq ) matrix get nth ;\r
-\r
-: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
- matrix get swap change-nth ; inline\r
-\r
-: exchange-rows ( row# row# -- ) matrix get exchange ;\r
-\r
-: rows ( -- n ) matrix get length ;\r
-\r
-: cols ( -- n ) 0 nth-row length ;\r
-\r
-: skip ( i seq quot -- n )\r
- over [ find-from drop ] dip length or ; inline\r
-\r
-: first-col ( row# -- n )\r
- #! First non-zero column\r
- 0 swap nth-row [ zero? not ] skip ;\r
-\r
-: clear-scale ( col# pivot-row i-row -- n )\r
- [ over ] dip nth dup zero? [\r
- 3drop 0\r
- ] [\r
- [ nth dup zero? ] dip swap [\r
- 2drop 0\r
- ] [\r
- swap / neg\r
- ] if\r
- ] if ;\r
-\r
-: (clear-col) ( col# pivot-row i -- )\r
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
-\r
-: rows-from ( row# -- slice )\r
- rows dup <slice> ;\r
-\r
-: clear-col ( col# row# rows -- )\r
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
-\r
-: do-row ( exchange-with row# -- )\r
- [ exchange-rows ] keep\r
- [ first-col ] keep\r
- dup 1+ rows-from clear-col ;\r
-\r
-: find-row ( row# quot -- i elt )\r
- [ rows-from ] dip find ; inline\r
-\r
-: pivot-row ( col# row# -- n )\r
- [ dupd nth-row nth zero? not ] find-row 2nip ;\r
-\r
-: (echelon) ( col# row# -- )\r
- over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1+ ] when*\r
- [ 1+ ] dip (echelon)\r
- ] [\r
- 2drop\r
- ] if ;\r
-\r
-: echelon ( matrix -- matrix' )\r
- [ 0 0 (echelon) ] with-matrix ;\r
-\r
-: nonzero-rows ( matrix -- matrix' )\r
- [ [ zero? ] all? not ] filter ;\r
-\r
-: null/rank ( matrix -- null rank )\r
- echelon dup length swap nonzero-rows length [ - ] keep ;\r
-\r
-: leading ( seq -- n elt ) [ zero? not ] find ;\r
-\r
-: reduced ( matrix' -- matrix'' )\r
- [\r
- rows <reversed> [\r
- dup nth-row leading drop\r
- dup [ swap dup clear-col ] [ 2drop ] if\r
- ] each\r
- ] with-matrix ;\r
-\r
-: basis-vector ( row col# -- )\r
- [ clone ] dip\r
- [ swap nth neg recip ] 2keep\r
- [ 0 spin set-nth ] 2keep\r
- [ n*v ] dip\r
- matrix get set-nth ;\r
-\r
-: nullspace ( matrix -- seq )\r
- echelon reduced dup empty? [\r
- dup first length identity-matrix [\r
- [\r
- dup leading drop\r
- dup [ basis-vector ] [ 2drop ] if\r
- ] each\r
- ] with-matrix flip nonzero-rows\r
- ] unless ;\r
-\r
-: 1-pivots ( matrix -- matrix )\r
- [ dup leading nip [ recip v*n ] when* ] map ;\r
-\r
-: solution ( matrix -- matrix )\r
- echelon nonzero-rows reduced 1-pivots ;\r
-\r
+++ /dev/null
-A modification of solution to approximate solutions
\ No newline at end of file
+++ /dev/null
-ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
+++ /dev/null
-adsoda 4D viewer
\ No newline at end of file
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! 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"
-
-
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-adsoda.tools\r
-tools.test\r
-;\r
-\r
-IN: adsoda.tools.tests\r
-\r
-\r
- [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
- [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
-\r
- [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-kernel\r
-sequences\r
-math\r
-accessors\r
-adsoda\r
-math.vectors \r
-math.matrices\r
-bunny.model\r
-io.encodings.ascii\r
-io.files\r
-sequences.deep\r
-combinators\r
-adsoda.combinators\r
-fry\r
-io.files.temp\r
-grouping\r
-;\r
-\r
-IN: adsoda.tools\r
-\r
-\r
-\r
-\r
-\r
-! ---------------------------------\r
-: coord-min ( x array -- array ) swap suffix ;\r
-: coord-max ( x array -- array ) swap neg suffix ;\r
-\r
-: 4cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 4 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
- [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
- [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
- [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-: 3cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 3 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
- [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
- [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-\r
-: equation-system-for-normal ( points -- matrix )\r
- unclip [ v- 0 suffix ] curry map\r
- dup first [ drop 1 ] map suffix\r
-;\r
-\r
-: normal-vector ( points -- v ) \r
- equation-system-for-normal\r
- intersect-hyperplanes ;\r
-\r
-: points-to-hyperplane ( points -- hyperplane )\r
- [ normal-vector 0 suffix ] [ first ] bi\r
- translate ;\r
-\r
-: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
-;\r
-! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
-! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
-\r
-: ply-model-path ( -- path )\r
-\r
-! "bun_zipper.ply" \r
-"screw2.ply"\r
-temp-file \r
-;\r
-\r
-: read-bunny-model ( -- v )\r
-ply-model-path ascii [ parse-model ] with-file-reader\r
-\r
-refs-to-points\r
-;\r
-\r
-: 3points-to-normal ( seq -- v )\r
- unclip [ v- ] curry map first2 cross normalize\r
-;\r
-: 2-faces-to-prism ( seq seq -- seq )\r
- 2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
- swap prefix\r
- swap prefix\r
-; \r
-\r
-: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing a cube of height "height"\r
- ! and of based on the three points\r
- ! a face is a group of 3 or mode points. \r
- [ dup dup 3points-to-normal ] dip \r
- v*n [ v+ ] curry map ! 2 eme face triangulaire \r
- 2-faces-to-prism \r
-\r
-! [ dup number? [ 1 + ] when ] deep-map\r
-! dup keep \r
-;\r
-\r
-\r
-: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing a cube in 4th dim\r
- ! from x to y (height = y-x)\r
- ! and of based on the X points\r
- ! a face is a group of 3 or mode points. \r
- '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
- 2-faces-to-prism\r
-;\r
-\r
-: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
-\r
-;\r
-\r
-: test-figure ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-\r
{ 0 0 1 }
{ 0 0 0 } } ;
-: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
+: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
: set-rule ( n -- )
dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
] if
] [ f ] if
]
- ] contains? ; inline recursive
+ ] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
+ 10 [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
swap >float number>string
"." split1 rot
over length over <
- [ CHAR: 0 pad-right ]
+ [ CHAR: 0 pad-tail ]
[ head ] if "." glue ;
: discard-lines ( -- )
[ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
METHOD: satisfiable? { â–¡ }
- cnf [ (satisfiable?) ] contains? ;
+ cnf [ (satisfiable?) ] any? ;
GENERIC: (expr.) ( expr -- )
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
- 64 0 pad-right
+ 64 0 pad-tail
[ opad seq-bitxor ] keep
ipad seq-bitxor ;
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
- [ " " split1 [ " " first = ] trim-left 2array ] map
+ [ " " split1 [ " " first = ] trim-head 2array ] map
\ $values prefix
parsed
: flattenable? ( object -- ? )
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
- [ word-prop ] with contains? not
+ [ word-prop ] with any? not
] } 1&& ;
: flatten ( quot -- expanded )
: empty-inverse ( class -- quot )
deconstruct-pred
- [ tuple>array rest [ ] contains? [ fail ] when ]
+ [ tuple>array rest [ ] any? [ fail ] when ]
compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
[
drop {
- [ [ wrapper? ] deep-contains? ]
- [ [ hashtable? ] deep-contains? ]
+ [ [ wrapper? ] deep-any? ]
+ [ [ hashtable? ] deep-any? ]
} 1|| not
] assoc-filter
: double. ( double -- )
double>bits
[ (double-sign) .b ]
- [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
[
- (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
11 [ bl ] times print
] tri ;
: (money>string) ( dollars cents -- string )
[ number>string ] bi@
[ <reversed> 3 group "," join <reversed> ]
- [ 2 CHAR: 0 pad-left ] bi* "." glue ;
+ [ 2 CHAR: 0 pad-head ] bi* "." glue ;
: money>string ( object -- string )
dollars/cents (money>string) currency-token get prefix ;
parsers>> 0 swap seq>list
[ parse ] lazy-map-with lconcat ;
-: trim-left-slice ( string -- string )
+: trim-head-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
- dup first blank? [ rest-slice trim-left-slice ] when
+ dup first blank? [ rest-slice trim-head-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
M: sp-parser parse ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
- [ trim-left-slice ] dip p1>> parse ;
+ [ trim-head-slice ] dip p1>> parse ;
TUPLE: just-parser p1 ;
<PRIVATE
: candidates ( n -- seq )
- 1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
+ 1000 over <range> [ number>digits 3 0 pad-head ] map [ all-unique? ] filter ;
: overlap? ( seq -- ? )
[ first 2 tail* ] [ second 2 head ] bi = ;
2 /i sqrt >integer [1,b] [ sq ] map ;
: fits-conjecture? ( n -- ? )
- dup perfect-squares [ 2 * - ] with map [ prime? ] contains? ;
+ dup perfect-squares [ 2 * - ] with map [ prime? ] any? ;
: next-odd-composite ( n -- m )
dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
: source-059 ( -- seq )
"resource:extra/project-euler/059/cipher1.txt"
- ascii file-contents [ blank? ] trim-right "," split
+ ascii file-contents [ blank? ] trim-tail "," split
[ string>number ] map ;
TUPLE: rollover seq n ;
print readln string>number ;
: number>euler ( n -- str )
- number>string 3 CHAR: 0 pad-left ;
+ number>string 3 CHAR: 0 pad-head ;
: solution-path ( n -- str/f )
number>euler "project-euler." prepend
: >board ( row m n -- ) row set-nth ;
: f>board ( m n -- ) f -rot >board ;
-: row-contains? ( n y -- ? ) row member? ;
-: col-contains? ( n x -- ? ) board get swap <column> member? ;
-: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
+: row-any? ( n y -- ? ) row member? ;
+: col-any? ( n x -- ? ) board get swap <column> member? ;
+: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ;
-: box-contains? ( n x y -- ? )
+: box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ [ 3dup ] dip cell-contains? ] contains?
+ 9 [ [ 3dup ] dip cell-any? ] any?
[ 3drop ] dip ;
DEFER: search
: attempt ( n x y -- )
{
- { [ 3dup nip row-contains? ] [ 3drop ] }
- { [ 3dup drop col-contains? ] [ 3drop ] }
- { [ 3dup box-contains? ] [ 3drop ] }
+ { [ 3dup nip row-any? ] [ 3drop ] }
+ { [ 3dup drop col-any? ] [ 3drop ] }
+ { [ 3dup box-any? ] [ 3drop ] }
[ assume ]
} cond ;
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split harvest [ >string ] map
- 6 "" pad-right ;
+ 6 "" pad-tail ;
: sysname ( -- string ) uname first ;
: nodename ( -- string ) uname second ;
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-right ;
+ release ".-" split harvest 5 "" pad-tail ;
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
: read-c-string* ( n -- str/f )
- read [ zero? ] trim-right [ f ] when-empty ;
+ read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
: typeflag-L ( header -- )
drop ;
! <string-writer> [ read-data-blocks ] keep
- ! >string [ zero? ] trim-right filename set
+ ! >string [ zero? ] trim-tail filename set
! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry
+++ /dev/null
-
-USING: kernel quotations arrays sequences math math.ranges fry
- opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
- accessors
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.plot
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "ui.gadgets.plot" "Plot Gadget"
-
-Summary:
-
- A simple gadget for ploting two dimentional functions.
-
- Use the arrow keys to move around.
-
- Use 'a' and 'z' keys to zoom in and out. ..
-
-Example:
-
- <plot> [ sin ] add-function gadget. ..
-
-Example:
-
- <plot>
- [ sin ] red function boa add-function
- [ cos ] blue function boa add-function
- gadget. ..
-
-;
-
-ABOUT: "ui.gadgets.plot"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: plot < cartesian functions points ;
-
-: init-plot ( plot -- plot )
- init-cartesian
- { } >>functions
- 100 >>points ;
-
-: <plot> ( -- plot ) plot new init-plot ;
-
-: step-size ( plot -- step-size )
- [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
-
-: plot-range ( plot -- range )
- [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: function function color ;
-
-GENERIC: plot-function ( plot object -- plot )
-
-M: callable plot-function ( plot quotation -- plot )
- [ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
-
-M: function plot-function ( plot function -- plot )
- dup color>> dup [ >stroke-color ] [ drop ] if
- [ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
-
-: draw-axis ( plot -- plot )
- dup
- [ [ x-min>> ] [ drop 0 ] bi 2array ]
- [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
- dup
- [ [ drop 0 ] [ y-min>> ] bi 2array ]
- [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gadgets.slate ;
-
-M: plot draw-slate ( plot -- plot )
- 2 glLineWidth
- draw-axis
- plot-functions
- fill-mode
- 1 glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-function ( plot function -- plot )
- over functions>> swap suffix >>functions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
-: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gestures ui.gadgets ;
-
-: left ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
- dup relayout-1 ;
-
-: right ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
- dup relayout-1 ;
-
-: down ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
- dup relayout-1 ;
-
-: up ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-in-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
-
-: zoom-in-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
-
-: zoom-in ( plot -- plot )
- zoom-in-horizontal
- zoom-in-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-out-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
-
-: zoom-out-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
-
-: zoom-out ( plot -- plot )
- zoom-out-horizontal
- zoom-out-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-plot
- H{
- { T{ mouse-enter } [ request-focus ] }
- { T{ key-down f f "LEFT" } [ left drop ] }
- { T{ key-down f f "RIGHT" } [ right drop ] }
- { T{ key-down f f "DOWN" } [ down drop ] }
- { T{ key-down f f "UP" } [ up drop ] }
- { T{ key-down f f "a" } [ zoom-in drop ] }
- { T{ key-down f f "z" } [ zoom-out drop ] }
- }
-set-gestures
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces opengl ui.render ui.gadgets accessors
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "slate" "Slate Gadget"
-
-Summary:
-
- A gadget with an 'action' slot which should be set to a callable. ..
-
-Example:
-
- ! Load the right vocabs for the examples
-
- USING: processing.shapes ui.gadgets.slate ; ..
-
-Example:
-
- [ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
- gadget. ..
-
-;
-
-ABOUT: "slate"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-
-USING: kernel sequences math math.order
- ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.tiling
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
-
-Summary:
-
- A gadget which tiles it's children.
-
- A tiling gadget may contain any number of children, but only a
- fixed number is displayed at one time. How many are displayed can
- be controlled via Control-[ and Control-].
-
- The focus may be switched with Alt-Left and Alt-Right.
-
- The focused child may be moved via Shift-Alt-Left and
- Shift-Alt-Right. ..
-
-Example:
-
- <tiling-shelf>
- "resource:" directory-files
- [ [ drop ] <bevel-button> tiling-add ]
- each
- "Files" open-window ..
-
-;
-
-ABOUT: "ui.gadgets.tiling"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling < track gadgets tiles first focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-tiling ( tiling -- tiling )
- init-track
- { 1 0 } >>orientation
- V{ } clone >>gadgets
- 2 >>tiles
- 0 >>first
- 0 >>focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- gadget ) tiling new init-tiling ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounded-subseq ( seq a b -- seq )
- [ 0 max ] dip
- pick length [ min ] curry bi@
- rot
- subseq ;
-
-: tiling-gadgets-to-map ( tiling -- gadgets )
- [ gadgets>> ]
- [ first>> ]
- [ [ first>> ] [ tiles>> ] bi + ]
- tri
- bounded-subseq ;
-
-: tiling-map-gadgets ( tiling -- tiling )
- dup clear-track
- dup tiling-gadgets-to-map [ 1 track-add ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tiling-add ( tiling gadget -- tiling )
- over gadgets>> push
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: first-gadget ( tiling -- index ) drop 0 ;
-
-: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
-
-: first-viewable ( tiling -- index ) first>> ;
-
-: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-focused-mapped ( tiling -- tiling )
-
- dup [ focused>> ] [ first>> ] bi <
- [ dup first>> 1 - >>first ]
- [ ]
- if
-
- dup [ last-viewable ] [ focused>> ] bi <
- [ dup first>> 1 + >>first ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-focused-bounds ( tiling -- tiling )
- dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
-
-: focus-prev ( tiling -- tiling )
- dup focused>> 1 - >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-: focus-next ( tiling -- tiling )
- dup focused>> 1 + >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exchanged! ( seq a b -- )
- [ 0 max ] bi@
- pick length 1 - '[ _ min ] bi@
- rot exchange ;
-
-: move-prev ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
- focus-prev ;
-
-: move-next ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
- focus-next ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-tile ( tiling -- tiling )
- dup tiles>> 1 + >>tiles
- tiling-map-gadgets ;
-
-: del-tile ( tiling -- tiling )
- dup tiles>> 1 - 1 max >>tiles
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: tiling focusable-child* ( tiling -- child/t )
- [ focused>> ] [ gadgets>> ] bi nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling-shelf < tiling ;
-TUPLE: tiling-pile < tiling ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- gadget )
- tiling-pile new init-tiling { 0 1 } >>orientation ;
-
-tiling-shelf
- H{
- { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
-
-tiling-pile
- H{
- { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
;; Default is word constituent
(dotimes (i 256)
(modify-syntax-entry i "w" table))
-
;; Whitespace (TAB is not whitespace)
(modify-syntax-entry ?\f " " table)
(modify-syntax-entry ?\r " " table)
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
-
- ;; Char quote
- (modify-syntax-entry ?\\ "/" table)
-
table))
(defconst fuel-syntax--syntactic-keywords
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings
- ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\)"
- (3 "\"") (4 "\""))
- ("\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\|$\\)" (1 "\"") (2 "\""))
+ ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
+ (3 "\"") (5 "\""))
+ ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
" kernel vocab keywords
syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple
-syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
+syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-any? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot
syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f
-syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
+syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek any? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
--- /dev/null
+! 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"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+namespaces\r
+accessors\r
+make\r
+math\r
+math.functions\r
+math.trig\r
+math.parser\r
+hashtables\r
+sequences\r
+combinators\r
+continuations\r
+colors\r
+prettyprint\r
+vars\r
+quotations\r
+io\r
+io.directories\r
+io.pathnames\r
+help.markup\r
+io.files\r
+ui.gadgets.panes\r
+ ui\r
+ ui.gadgets\r
+ ui.traverse\r
+ ui.gadgets.borders\r
+ ui.gadgets.handler\r
+ ui.gadgets.slate\r
+ ui.gadgets.theme\r
+ ui.gadgets.frames\r
+ ui.gadgets.tracks\r
+ ui.gadgets.labels\r
+ ui.gadgets.labelled \r
+ ui.gadgets.lists\r
+ ui.gadgets.buttons\r
+ ui.gadgets.packs\r
+ ui.gadgets.grids\r
+ ui.gestures\r
+ ui.tools.workspace\r
+ ui.gadgets.scrollers\r
+splitting\r
+vectors\r
+math.vectors\r
+rewrite-closures\r
+self\r
+values\r
+4DNav.turtle\r
+4DNav.window3D\r
+4DNav.deep\r
+4DNav.space-file-decoder\r
+models\r
+fry\r
+adsoda\r
+adsoda.tools\r
+;\r
+\r
+IN: 4DNav\r
+VALUE: selected-file\r
+VALUE: translation-step\r
+VALUE: rotation-step\r
+\r
+3 to: translation-step \r
+5 to: rotation-step\r
+\r
+VAR: selected-file-model\r
+VAR: observer3d \r
+VAR: view1 \r
+VAR: view2\r
+VAR: view3\r
+VAR: view4\r
+VAR: present-space\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+! replacement of namespaces.lib\r
+ \r
+: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! waiting for deep-cleave-quots\r
+\r
+: 4D-Rxy ( angle -- Rx ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , dup cos , dup sin neg ,\r
+ 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rxz ( angle -- Ry ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , dup cos , 0.0 , dup sin neg ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rxw ( angle -- Rz ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , dup cos , dup sin neg , 0.0 ,\r
+ 0.0 , dup sin , dup cos , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+: 4D-Ryz ( angle -- Rx ) deg>rad\r
+[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Ryw ( angle -- Ry ) deg>rad\r
+[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ dup sin , 0.0 , dup cos , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rzw ( angle -- Rz ) deg>rad\r
+[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
+ dup sin , dup cos , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! UI\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: button* ( string quot -- button ) closed-quot <repeat-button> ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: model-projection-chooser ( -- gadget )\r
+ observer3d> projection-mode>>\r
+ { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
+\r
+: collision-detection-chooser ( -- gadget )\r
+ observer3d> collision-mode>>\r
+ { { t "on" } { f "off" } } <toggle-buttons>\r
+;\r
+\r
+: model-projection ( x -- space ) present-space> swap space-project ;\r
+\r
+: update-observer-projections ( -- )\r
+ view1> relayout-1 \r
+ view2> relayout-1 \r
+ view3> relayout-1 \r
+ view4> relayout-1 ;\r
+\r
+: update-model-projections ( -- )\r
+ 0 model-projection <model> view1> (>>model)\r
+ 1 model-projection <model> view2> (>>model)\r
+ 2 model-projection <model> view3> (>>model)\r
+ 3 model-projection <model> view4> (>>model) ;\r
+\r
+: camera-action ( quot -- quot ) \r
+ [ drop [ ] observer3d> with-self update-observer-projections ] \r
+ make* closed-quot ;\r
+\r
+: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! 4D object manipulation\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: (mvt-4D) ( quot -- ) \r
+ present-space> \r
+ swap call space-ensure-solids \r
+ >present-space \r
+ update-model-projections \r
+ update-observer-projections ;\r
+\r
+: rotation-4D ( m -- ) \r
+ '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip\r
+ space-transform \r
+ swap space-translate\r
+ ] (mvt-4D) ;\r
+\r
+: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! menu\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: menu-rotations-4D ( -- gadget )\r
+ <frame>\r
+ <pile> 1 >>fill\r
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget\r
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget\r
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget \r
+ @top grid-add \r
+ <pile> 1 >>fill\r
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget\r
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget \r
+ @center grid-add\r
+ <pile> 1 >>fill\r
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget\r
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget \r
+ @top-right grid-add \r
+ <pile> 1 >>fill\r
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget\r
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget \r
+ @right grid-add \r
+ <pile> 1 >>fill\r
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget\r
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget \r
+ @bottom-right grid-add \r
+;\r
+\r
+: menu-translations-4D ( -- gadget )\r
+ <frame> \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill \r
+ "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget\r
+ "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "YZW" <label> add-gadget\r
+ @bottom-right grid-add\r
+ <pile> 1 >>fill\r
+ "XZW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget\r
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ @top-right grid-add\r
+ <pile> 1 >>fill\r
+ "XYW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget\r
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget \r
+ add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill\r
+ "W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ] \r
+ button* add-gadget\r
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "XYZ" <label> add-gadget\r
+ @bottom-left grid-add \r
+ "X" <label> @center grid-add\r
+;\r
+\r
+: menu-4D ( -- gadget ) \r
+ <shelf> \r
+ "rotations" <label> add-gadget\r
+ menu-rotations-4D add-gadget\r
+ "translations" <label> add-gadget\r
+ menu-translations-4D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+;\r
+\r
+\r
+! ------------------------------------------------------\r
+\r
+: redraw-model ( space -- )\r
+ >present-space \r
+ update-model-projections \r
+ update-observer-projections ;\r
+\r
+: load-model-file ( -- )\r
+ selected-file dup selected-file-model> set-model read-model-file \r
+ redraw-model ;\r
+\r
+: mvt-3D-X ( turn pitch -- quot )\r
+ '[ turtle-pos> norm neg reset-turtle \r
+ _ turn-left \r
+ _ pitch-up \r
+ step-turtle ] ;\r
+\r
+: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
+: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
+: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
+: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
+\r
+: camera-button ( string quot -- button ) \r
+ [ <label> ] dip camera-action <repeat-button> ;\r
+\r
+! ----------------------------------------------------------\r
+! file chooser\r
+! ----------------------------------------------------------\r
+: <run-file-button> ( file-name -- button )\r
+ dup '[ drop _ \ selected-file set-value load-model-file \r
+ ] \r
+ closed-quot <roll-button> { 0 0 } >>align ;\r
+\r
+: <list-runner> ( -- gadget )\r
+ "resource:extra/4DNav" \r
+ <pile> 1 >>fill \r
+ over dup directory-files \r
+ [ ".xml" tail? ] filter \r
+ [ append-path ] with map\r
+ [ <run-file-button> add-gadget ] each\r
+ swap <labelled-gadget> ;\r
+\r
+! -----------------------------------------------------\r
+\r
+: menu-rotations-3D ( -- gadget )\r
+ <frame>\r
+ "Turn\n left" [ rotation-step turn-left ] camera-button \r
+ @left grid-add \r
+ "Turn\n right" [ rotation-step turn-right ] camera-button \r
+ @right grid-add \r
+ "Pitch down" [ rotation-step pitch-down ] camera-button \r
+ @bottom grid-add \r
+ "Pitch up" [ rotation-step pitch-up ] camera-button \r
+ @top grid-add \r
+ <shelf> 1 >>fill\r
+ "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button\r
+ add-gadget \r
+ "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button \r
+ add-gadget \r
+ @center grid-add \r
+;\r
+\r
+: menu-translations-3D ( -- gadget )\r
+ <frame>\r
+ "left\n(alt)" [ translation-step strafe-left ] camera-button\r
+ @left grid-add \r
+ "right\n(alt)" [ translation-step strafe-right ] camera-button\r
+ @right grid-add \r
+ "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button\r
+ @top grid-add\r
+ "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button\r
+ @bottom grid-add \r
+ <pile> 1 >>fill\r
+ "Forward (ctl)" [ translation-step step-turtle ] camera-button\r
+ add-gadget\r
+ "Backward (ctl)" [ translation-step neg step-turtle ] camera-button\r
+ add-gadget\r
+ @center grid-add\r
+;\r
+\r
+: menu-quick-views ( -- gadget )\r
+ <shelf>\r
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
+;\r
+\r
+: menu-3D ( -- gadget ) \r
+ <pile>\r
+ <shelf> \r
+ menu-rotations-3D add-gadget\r
+ menu-translations-3D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+ add-gadget\r
+ menu-quick-views add-gadget ; \r
+\r
+: add-keyboard-delegate ( obj -- obj )\r
+ <handler>\r
+{\r
+ { T{ key-down f f "LEFT" } \r
+ [ [ rotation-step turn-left ] camera-action ] }\r
+ { T{ key-down f f "RIGHT" } \r
+ [ [ rotation-step turn-right ] camera-action ] }\r
+ { T{ key-down f f "UP" } \r
+ [ [ rotation-step pitch-down ] camera-action ] }\r
+ { T{ key-down f f "DOWN" } \r
+ [ [ rotation-step pitch-up ] camera-action ] }\r
+\r
+ { T{ key-down f { C+ } "UP" } \r
+ [ [ translation-step step-turtle ] camera-action ] }\r
+ { T{ key-down f { C+ } "DOWN" } \r
+ [ [ translation-step neg step-turtle ] camera-action ] }\r
+ { T{ key-down f { C+ } "LEFT" } \r
+ [ [ rotation-step roll-left ] camera-action ] }\r
+ { T{ key-down f { C+ } "RIGHT" } \r
+ [ [ rotation-step roll-right ] camera-action ] }\r
+\r
+ { T{ key-down f { A+ } "LEFT" } \r
+ [ [ translation-step strafe-left ] camera-action ] }\r
+ { T{ key-down f { A+ } "RIGHT" } \r
+ [ [ translation-step strafe-right ] camera-action ] }\r
+ { T{ key-down f { A+ } "UP" } \r
+ [ [ translation-step strafe-up ] camera-action ] }\r
+ { T{ key-down f { A+ } "DOWN" } \r
+ [ [ translation-step strafe-down ] camera-action ] }\r
+\r
+\r
+ { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
+ { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
+ { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
+ { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
+\r
+ } [ make* ] map >hashtable >>table\r
+ ; \r
+\r
+! --------------------------------------------\r
+! print elements \r
+! --------------------------------------------\r
+! print-content\r
+\r
+GENERIC: adsoda-display-model ( x -- ) \r
+\r
+M: light adsoda-display-model \r
+"\n light : " .\r
+ { \r
+ [ direction>> "direction : " pprint . ] \r
+ [ color>> "color : " pprint . ]\r
+ } cleave\r
+ ;\r
+\r
+M: face adsoda-display-model \r
+ {\r
+ [ halfspace>> "halfspace : " pprint . ] \r
+ [ touching-corners>> "touching corners : " pprint . ]\r
+ } cleave\r
+ ;\r
+M: solid adsoda-display-model \r
+ {\r
+ [ name>> "solid called : " pprint . ] \r
+ [ color>> "color : " pprint . ]\r
+ [ dimension>> "dimension : " pprint . ]\r
+ [ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]\r
+ } cleave\r
+ ;\r
+M: space adsoda-display-model \r
+ {\r
+ [ dimension>> "dimension : " pprint . ] \r
+ [ ambient-color>> "ambient-color : " pprint . ]\r
+ [ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]\r
+ [ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ] \r
+ } cleave\r
+ ;\r
+\r
+! ----------------------------------------------\r
+: menu-bar ( -- gadget )\r
+ <shelf>\r
+ "reinit" [ drop load-model-file ] button* add-gadget\r
+ selected-file-model> <label-control> add-gadget\r
+ ;\r
+\r
+\r
+: controller-window* ( -- gadget )\r
+ { 0 1 } <track>\r
+ menu-bar f track-add\r
+ <list-runner> \r
+ <limited-scroller> \r
+ { 200 400 } >>max-dim\r
+ f track-add\r
+ <shelf>\r
+ "Projection mode : " <label> add-gadget\r
+ model-projection-chooser add-gadget\r
+ f track-add\r
+ <shelf>\r
+ "Collision detection (slow and buggy ) : " <label> add-gadget\r
+ collision-detection-chooser add-gadget\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align \r
+ menu-4D add-gadget \r
+ light-purple solid-interior\r
+ "4D movements" <labelled-gadget>\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align\r
+ { 2 2 } >>gap\r
+ menu-3D add-gadget\r
+ light-purple solid-interior \r
+ "Camera 3D" <labelled-gadget>\r
+ f track-add \r
+ gray solid-interior\r
+ ;\r
+ \r
+: viewer-windows* ( -- )\r
+ "YZW" view1> win3D \r
+ "XZW" view2> win3D \r
+ "XYW" view3> win3D \r
+ "XYZ" view4> win3D \r
+;\r
+\r
+: navigator-window* ( -- )\r
+ controller-window*\r
+ viewer-windows* \r
+ add-keyboard-delegate\r
+ "navigateur 4D" open-window\r
+;\r
+\r
+: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
+\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: init-variables ( -- )\r
+ "choose a file" <model> >selected-file-model \r
+ <observer> >observer3d\r
+ [ observer3d> >self\r
+ reset-turtle \r
+ 45 turn-left \r
+ 45 pitch-up \r
+ -300 step-turtle \r
+ ] with-scope\r
+ \r
+;\r
+\r
+\r
+: init-models ( -- )\r
+ 0 model-projection observer3d> <window3D> >view1\r
+ 1 model-projection observer3d> <window3D> >view2\r
+ 2 model-projection observer3d> <window3D> >view3\r
+ 3 model-projection observer3d> <window3D> >view4\r
+;\r
+\r
+: 4DNav ( -- ) \r
+ init-variables\r
+ selected-file read-model-file >present-space\r
+ init-models\r
+ windows\r
+;\r
+\r
+MAIN: 4DNav\r
+\r
+\r
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+Adam Wendt
--- /dev/null
+! 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"
--- /dev/null
+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 ;
--- /dev/null
+! 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"
--- /dev/null
+USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;\r
+IN: 4DNav.deep\r
+\r
+! USING: bake ;\r
+! MACRO: deep-cleave-quots ( seq -- quot )\r
+! [ [ quotation? ] deep-filter ]\r
+! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
+! bi '[ _ cleave _ bake ] ;\r
+\r
+: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline\r
+\r
--- /dev/null
+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 }
+}
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING:\r
+kernel\r
+io.files\r
+io.backend\r
+io.directories\r
+io.files.info\r
+io.pathnames\r
+sequences\r
+models\r
+strings\r
+ui\r
+ui.operations\r
+ui.commands\r
+ui.gestures\r
+ui.gadgets\r
+ui.gadgets.buttons\r
+ui.gadgets.lists\r
+ui.gadgets.labels\r
+ui.gadgets.tracks\r
+ui.gadgets.packs\r
+ui.gadgets.panes\r
+ui.gadgets.scrollers\r
+prettyprint\r
+combinators\r
+rewrite-closures\r
+accessors\r
+values\r
+tools.walker\r
+fry\r
+;\r
+IN: 4DNav.file-chooser\r
+\r
+TUPLE: file-chooser < track \r
+ path\r
+ extension \r
+ selected-file\r
+ presenter\r
+ hook \r
+ list\r
+ ;\r
+\r
+: find-file-list ( gadget -- list )\r
+ [ file-chooser? ] find-parent list>> ;\r
+\r
+file-chooser H{\r
+ { T{ key-down f f "UP" } [ find-file-list select-previous ] }\r
+ { T{ key-down f f "DOWN" } [ find-file-list select-next ] }\r
+ { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }\r
+ { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }\r
+ { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }\r
+ { T{ button-down } request-focus }\r
+ { T{ button-down f 1 } [ find-file-list invoke-value-action ] }\r
+} set-gestures\r
+\r
+: list-of-files ( file-chooser -- seq )\r
+ [ path>> value>> directory-entries ] [ extension>> ] bi\r
+ '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
+;\r
+\r
+: update-filelist-model ( file-chooser -- file-chooser )\r
+ [ list-of-files ] [ model>> ] bi set-model ;\r
+\r
+: init-filelist-model ( file-chooser -- file-chooser )\r
+ dup list-of-files <model> >>model ; \r
+\r
+: (fc-go) ( file-chooser quot -- )\r
+ [ [ file-chooser? ] find-parent dup path>> ] dip\r
+ call\r
+ normalize-path swap set-model\r
+ update-filelist-model\r
+ drop ;\r
+\r
+: fc-go-parent ( file-chooser -- )\r
+ [ dup value>> parent-directory ] (fc-go) ;\r
+\r
+: fc-go-home ( file-chooser -- )\r
+ [ home ] (fc-go) ;\r
+\r
+: fc-change-directory ( file-chooser file -- file-chooser )\r
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
+ append-path over path>> set-model \r
+ update-filelist-model\r
+;\r
+\r
+: fc-load-file ( file-chooser file -- )\r
+ dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
+ [ path>> value>> ] \r
+ [ selected-file>> value>> append ] \r
+ [ hook>> ] tri\r
+ call\r
+; inline\r
+\r
+! : fc-ok-action ( file-chooser -- quot )\r
+! dup selected-file>> value>> "" =\r
+! [ drop [ drop ] ] [ \r
+! [ path>> value>> ] \r
+! [ selected-file>> value>> append ] \r
+! [ hook>> prefix ] tri\r
+! [ drop ] prepend\r
+! ] if ; \r
+\r
+: line-selected-action ( file-chooser -- )\r
+ dup list>> list-value\r
+ dup directory? \r
+ [ fc-change-directory ] [ fc-load-file ] if ;\r
+\r
+: present-dir-element ( element -- string )\r
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
+\r
+: <file-list> ( file-chooser -- list )\r
+ dup [ nip line-selected-action ] curry \r
+ [ present-dir-element ] rot model>> <list> ;\r
+\r
+: <file-chooser> ( hook path extension -- gadget )\r
+ { 0 1 } file-chooser new-track\r
+ swap >>extension\r
+ swap <model> >>path\r
+ "" <model> >>selected-file\r
+ swap >>hook\r
+ init-filelist-model\r
+ dup <file-list> >>list\r
+ "choose a file in directory " <label> f track-add\r
+ dup path>> <label-control> f track-add\r
+ dup extension>> ", " join "limited to : " prepend <label> f track-add\r
+ <shelf> \r
+ "selected file : " <label> add-gadget\r
+ over selected-file>> <label-control> add-gadget\r
+ f track-add\r
+ <shelf> \r
+ over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget\r
+ over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget\r
+ ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget\r
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
+ f track-add\r
+ dup list>> <scroller> 1 track-add\r
+;\r
+\r
+M: file-chooser pref-dim* drop { 400 200 } ;\r
+\r
+: file-chooser-window ( -- )\r
+[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
+\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>hypercube</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,0,0,0</direction>\r
+ <color>0,0,0,0.6</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,1,0,0</direction>\r
+ <color>0,0.6,0,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,1,0</direction>\r
+ <color>0,0,0.6,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,0,1</direction>\r
+ <color>0.6,0.6,0.6</color>\r
+ </light>\r
+ <color>0.99,0.99,0.99</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>Prismetragone</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
+sequences math.parser kernel splitting values continuations ;\r
+IN: 4DNav.space-file-decoder\r
+\r
+: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
+\r
+PROCESS: adsoda-read-model ( tag -- )\r
+\r
+TAG: dimension adsoda-read-model children>> first string>number ;\r
+TAG: direction adsoda-read-model children>> first decode-number-array ;\r
+TAG: color adsoda-read-model children>> first decode-number-array ;\r
+TAG: name adsoda-read-model children>> first ;\r
+TAG: face adsoda-read-model children>> first decode-number-array ;\r
+\r
+TAG: solid adsoda-read-model \r
+ <solid> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \r
+ } cleave\r
+ ensure-adjacencies\r
+;\r
+\r
+TAG: light adsoda-read-model \r
+ <light> swap \r
+ { \r
+ [ "direction" tag-named adsoda-read-model >>direction ] \r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ } cleave\r
+;\r
+\r
+TAG: space adsoda-read-model \r
+ <space> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named adsoda-read-model >>ambient-color ] \r
+ [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ] \r
+ [ "light" tags-named [ adsoda-read-model suffix-lights ] each ] \r
+ } cleave\r
+;\r
+\r
+: read-model-file ( path -- x )\r
+ dup\r
+ [\r
+ [ file>xml "space" tags-named first adsoda-read-model ] \r
+ [ drop <space> ] recover \r
+ ] [ drop <space> ] if \r
+\r
+;\r
+\r
--- /dev/null
+4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
--- /dev/null
+4D viewer
\ No newline at end of file
--- /dev/null
+<model>\r
+<space>\r
+ <name>triancube</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+! 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"
--- /dev/null
+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 ;
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+ui.gadgets\r
+ui.render\r
+opengl\r
+opengl.gl\r
+opengl.glu\r
+4DNav.camera\r
+4DNav.turtle\r
+math\r
+values\r
+alien.c-types\r
+accessors\r
+namespaces\r
+adsoda \r
+models\r
+accessors\r
+prettyprint\r
+;\r
+\r
+IN: 4DNav.window3D\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! drawing functions \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+TUPLE: window3D < gadget observer ; \r
+\r
+: <window3D> ( model observer -- gadget )\r
+ window3D new-gadget \r
+ swap 2dup \r
+ projection-mode>> add-connection\r
+ 2dup \r
+ collision-mode>> add-connection\r
+ >>observer \r
+ swap <model> >>model \r
+ t >>root?\r
+;\r
+\r
+M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
+\r
+M: window3D draw-gadget* ( gadget -- )\r
+\r
+ GL_PROJECTION glMatrixMode\r
+ glLoadIdentity\r
+ 0.6 0.6 0.6 .9 glClearColor\r
+ dup observer>> projection-mode>> value>> 1 = \r
+ [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
+ [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
+ dup observer>> collision-mode>> value>> \r
+ \ remove-hidden-solids? \r
+ set-value\r
+ dup observer>> do-look-at\r
+ GL_MODELVIEW glMatrixMode\r
+ glLoadIdentity \r
+ 0.9 0.9 0.9 1.0 glClearColor\r
+ 1.0 glClearDepth\r
+ GL_LINE_SMOOTH glEnable\r
+ GL_BLEND glEnable\r
+ GL_DEPTH_TEST glEnable \r
+ GL_LEQUAL glDepthFunc\r
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
+ GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
+ 1.25 glLineWidth\r
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
+ glLoadIdentity\r
+ GL_LIGHTING glEnable\r
+ GL_LIGHT0 glEnable\r
+ GL_COLOR_MATERIAL glEnable\r
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
+ ! *************************\r
+ \r
+ model>> value>> \r
+ [ space->GL ] when*\r
+\r
+ ! *************************\r
+;\r
+\r
+M: window3D graft* drop ;\r
+\r
+M: window3D model-changed nip relayout ; \r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.markup help.syntax ;\r
+\r
+IN: adsoda\r
+\r
+\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+ARTICLE: "face-page" "face in ADSODA"\r
+"explanation of faces"\r
+$nl\r
+"link to functions"\r
+"what is an halfspace"\r
+"halfspace touching-corners adjacent-faces"\r
+"touching-corners list of pointers to the corners which touch this face\n"\r
+\r
+"adjacent-faces list of pointers to the faces which touch this face\n"\r
+{ $subsection face }\r
+{ $subsection <face> }\r
+"test relative position"\r
+{ $subsection point-inside-or-on-face? } \r
+{ $subsection point-inside-face? }\r
+"handling face"\r
+{ $subsection flip-face }\r
+{ $subsection face-translate }\r
+{ $subsection face-transform }\r
+\r
+;\r
+\r
+HELP: face\r
+{ $class-description "a face is defined by"\r
+{ $list "halfspace equation" }\r
+{ $list "list of touching corners" }\r
+{ $list "list of adjacent faces" }\r
+$nl\r
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
+}\r
+\r
+\r
+;\r
+HELP: <face> \r
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
+HELP: flip-face \r
+{ $values { "face" "a face" } { "face" "flipped face" } }\r
+{ $description "change the orientation of a face" }\r
+;\r
+\r
+HELP: face-translate \r
+{ $values { "face" "a face" } { "v" "a vector" } }\r
+{ $description \r
+"translate a face following a vector"\r
+$nl\r
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
+\r
+ \r
+ ;\r
+HELP: face-transform \r
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
+{ $description "compute the transformation of a face using a transformation matrix" }\r
+ \r
+ ;\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+ARTICLE: "solid-page" "solid in ADSODA"\r
+"explanation of solids"\r
+$nl\r
+"link to functions"\r
+{ $subsection solid }\r
+{ $subsection <solid> }\r
+"test relative position"\r
+{ $subsection point-inside-solid? }\r
+{ $subsection point-inside-or-on-solid? }\r
+"playing with faces and solids"\r
+{ $subsection add-face }\r
+{ $subsection cut-solid }\r
+{ $subsection slice-solid }\r
+"solid handling"\r
+{ $subsection solid-project }\r
+{ $subsection solid-translate }\r
+{ $subsection solid-transform }\r
+{ $subsection subtract }\r
+\r
+{ $subsection get-silhouette }\r
+\r
+{ $subsection solid= }\r
+\r
+\r
+;\r
+\r
+HELP: solid \r
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
+}\r
+;\r
+\r
+HELP: add-face \r
+{ $values { "solid" "a solid" } { "face" "a face" } }\r
+{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
+\r
+HELP: cut-solid\r
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
+{ $description "like add-face but just with halfspace equation" } ;\r
+\r
+HELP: slice-solid\r
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
+{ $description "cut a solid into two parts. The face acts like a knife"\r
+} ;\r
+\r
+\r
+HELP: solid-project\r
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
+{ $description "Project the solid using pv vector" \r
+$nl\r
+"TODO: explain how to use lights"\r
+} ;\r
+\r
+HELP: solid-translate \r
+{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
+{ $description "Translate a solid using a vector" \r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: solid-transform \r
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
+{ $description "Transform a solid using a matrix"\r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: subtract \r
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
+{ $description " " } ;\r
+\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+ARTICLE: "space-page" "space in ADSODA"\r
+"A space is a collection of solids and lights."\r
+$nl\r
+"link to functions"\r
+$nl\r
+"Defining words"\r
+{ $subsection space }\r
+{ $subsection <space> } \r
+{ $subsection suffix-solids }\r
+{ $subsection suffix-lights }\r
+{ $subsection clear-space-solids }\r
+{ $subsection describe-space }\r
+\r
+\r
+"Handling space"\r
+{ $subsection space-ensure-solids }\r
+{ $subsection eliminate-empty-solids }\r
+{ $subsection space-transform }\r
+{ $subsection space-translate }\r
+{ $subsection remove-hidden-solids }\r
+{ $subsection space-project }\r
+\r
+\r
+;\r
+\r
+HELP: space \r
+{ $class-description \r
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
+}\r
+;\r
+\r
+HELP: suffix-solids \r
+"( space solid -- space )"\r
+{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
+{ $description "Add solid to space definition" } ;\r
+\r
+HELP: suffix-lights \r
+"( space light -- space ) "\r
+{ $values { "space" "a space" } { "light" "a light to add" } }\r
+{ $description "Add a light to space definition" } ;\r
+\r
+HELP: clear-space-solids \r
+"( space -- space )" \r
+{ $values { "space" "a space" } }\r
+{ $description "remove all solids in space" } ;\r
+\r
+HELP: space-ensure-solids \r
+{ $values { "space" "a space" } }\r
+{ $description "rebuild corners of all solids in space" } ;\r
+\r
+\r
+\r
+HELP: space-transform \r
+" ( space m -- space )" \r
+{ $values { "space" "a space" } { "m" "a matrix" } }\r
+{ $description "Transform a space using a matrix" } ;\r
+\r
+HELP: space-translate \r
+{ $values { "space" "a space" } { "v" "a vector" } }\r
+{ $description "Translate a space following a vector" } ;\r
+\r
+HELP: describe-space " ( space -- )"\r
+{ $values { "space" "a space" } }\r
+{ $description "return a description of space" } ;\r
+\r
+HELP: space-project \r
+{ $values { "space" "a space" } { "i" "an integer" } }\r
+{ $description "Project a space along ith coordinate" } ;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\r
+"explanation of 3D rendering"\r
+$nl\r
+"link to functions"\r
+{ $subsection face->GL }\r
+{ $subsection solid->GL }\r
+{ $subsection space->GL }\r
+\r
+;\r
+\r
+HELP: face->GL \r
+{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
+{ $description "" } ;\r
+\r
+HELP: solid->GL \r
+{ $values { "solid" "a solid" } }\r
+{ $description "" } ;\r
+\r
+HELP: space->GL \r
+{ $values { "space" "a space" } }\r
+{ $description "" } ;\r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+ARTICLE: "light-page" "light in ADSODA"\r
+"explanation of light"\r
+$nl\r
+"link to functions"\r
+;\r
+\r
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
+"! HELP: light position color" \r
+"! <light> ( -- tuple ) light new ;"\r
+\r
+"! light est un vecteur avec 3 variables pour les couleurs\n"\r
+\r
+" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"\r
+" { \n"\r
+" // Dot the light direction with the normalized normal of Face."\r
+" register double intensity = -(normal * (*this));"\r
+\r
+" // Face is a backface, from light's perspective"\r
+" if (intensity < 0)"\r
+" return;"\r
+" "\r
+" // Add the intensity componentwise"\r
+" cRed += red * intensity;"\r
+" cGreen += green * intensity;"\r
+" cBlue += blue * intensity;"\r
+\r
+" // Clip to unit range"\r
+" if (cRed > 1.0) cRed = 1.0;"\r
+" if (cGreen > 1.0) cGreen = 1.0;"\r
+" if (cBlue > 1.0) cBlue = 1.0;"\r
+\r
+\r
+;\r
+\r
+\r
+\r
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
+"! demi espace défini par un vecteur normal et une constante"\r
+" defined by the concatenation of the normal vector and a constant" \r
+ ;\r
+\r
+\r
+\r
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
+"multidimensional handler :" \r
+$nl\r
+"design a solid using face delimitations. Only works on convex shapes"\r
+$nl\r
+{ $emphasis "written in C++ by Greg Ferrar" }\r
+$nl\r
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
+$nl\r
+"Useful words are describe on the following pages: "\r
+{ $subsection "face-page" }\r
+{ $subsection "solid-page" }\r
+{ $subsection "space-page" }\r
+{ $subsection "light-page" }\r
+{ $subsection "3D-rendering-page" }\r
+ ;\r
+\r
+ABOUT: "adsoda-main-page"\r
--- /dev/null
+USING: adsoda\r
+kernel\r
+math\r
+accessors\r
+sequences\r
+ adsoda.solution2\r
+ fry\r
+ tools.test \r
+ arrays ;\r
+\r
+IN: adsoda.tests\r
+\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
+\r
+\r
+! {\r
+! { 1 0 0 0 }\r
+! { 0 1 0 0 }\r
+! { 0 0 0.984807753012208 -0.1736481776669303 }\r
+! { 0 0 0.1736481776669303 0.984807753012208 }\r
+! }\r
+\r
+! ------------------------------------------------------------\r
+! constant+\r
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! translate\r
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! transform\r
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 }\r
+ } transform \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! compare-nleft-to-identity-matrix\r
+[ t ] [ \r
+ { \r
+ { 1 0 0 1232 } \r
+ { 0 1 0 0 321 } \r
+ { 0 0 1 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+! ------------------------------------------------------------\r
+[ t ] [ \r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 2 valid-solution? \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+[ 3 ] [ { 1 2 3 } last ] unit-test \r
+\r
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
+\r
+! ------------------------------------------------------------\r
+! position-point \r
+[ 0 ] [ \r
+ { 1 -1 -5 } { 2 7 } position-point \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+\r
+! transform\r
+! TODO construire un exemple\r
+\r
+\r
+! ------------------------------------------------------------\r
+! slice-solid \r
+\r
+! ------------------------------------------------------------\r
+! solve-equation \r
+! deux cas de tests, avec solution et sans solution\r
+\r
+[ { 2 7 } ] \r
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+! ------------------------------------------------------------\r
+! point-inside-halfspace\r
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
+unit-test\r
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
+unit-test\r
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
+unit-test\r
+\r
+\r
+! ------------------------------\r
+! order solid\r
+\r
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
+\r
+\r
+! clip-solid\r
+[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+solid2 corners>> '[ _ ]\r
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+!\r
+[\r
+ {\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+ }\r
+] [ 0 >pv solid2 solid3 2array \r
+ solid1 (solids-silhouette-subtract) \r
+ [ corners>> ] map\r
+ ] unit-test\r
+\r
+\r
+[\r
+{\r
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+}\r
+] [ \r
+ 0 >pv <space> solid1 suffix-solids \r
+ solid2 suffix-solids \r
+ solid3 suffix-solids\r
+ remove-hidden-solids\r
+ solids>> [ corners>> ] map\r
+] unit-test\r
+\r
+! { }\r
+! { }\r
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
+! suffix \r
+! { 0.1 0.1 0.1 } suffix ! ambient color\r
+! { 0.23 0.32 0.17 } suffix ! solid color\r
+! solid3 faces>> first \r
+\r
+! enlight-projection\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors\r
+arrays \r
+assocs\r
+combinators\r
+kernel \r
+fry\r
+math \r
+math.constants\r
+math.functions\r
+math.libm\r
+math.order\r
+math.vectors \r
+math.matrices \r
+math.parser\r
+namespaces\r
+prettyprint\r
+sequences\r
+sequences.deep\r
+sets\r
+slots\r
+sorting\r
+tools.time\r
+vars\r
+continuations\r
+words\r
+opengl\r
+opengl.gl\r
+colors\r
+adsoda.solution2\r
+adsoda.combinators\r
+opengl.demo-support\r
+values\r
+tools.walker\r
+;\r
+\r
+IN: adsoda\r
+\r
+DEFER: combinations\r
+VAR: pv\r
+\r
+\r
+! ---------------------------------------------------------------------\r
+! global values\r
+VALUE: remove-hidden-solids?\r
+VALUE: VERY-SMALL-NUM\r
+VALUE: ZERO-VALUE\r
+VALUE: MAX-FACE-PER-CORNER\r
+\r
+t to: remove-hidden-solids?\r
+0.0000001 to: VERY-SMALL-NUM\r
+0.0000001 to: ZERO-VALUE\r
+4 to: MAX-FACE-PER-CORNER\r
+! ---------------------------------------------------------------------\r
+! sequence complement\r
+\r
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
+\r
+: dimension ( array -- x ) length 1- ; inline \r
+: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
+: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+TUPLE: light name { direction array } color ;\r
+: <light> ( -- tuple ) light new ;\r
+\r
+! -----------------------------------------------------------------------\r
+! halfspace manipulation\r
+! -----------------------------------------------------------------------\r
+\r
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
+: translate ( u v -- w ) dupd v* sum constant+ ; \r
+\r
+: transform ( u matrix -- w )\r
+ [ swap m.v ] 2keep ! compute new normal vector \r
+ [\r
+ [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
+ ! be sure it's not null vector\r
+ last ! get constant\r
+ swap /f neg swap ! intercept value\r
+ ] dip \r
+ flip \r
+ nth\r
+ [ * ] with map ! apply intercep value\r
+ over v*\r
+ sum neg\r
+ suffix ! add value as constant at the end of equation\r
+;\r
+\r
+: position-point ( halfspace v -- x ) \r
+ -1 suffix v* sum ; inline\r
+: point-inside-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM > ; \r
+: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM neg > ;\r
+: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
+\r
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
+\r
+: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
+ [ [ head ] curry map ] keep identity-matrix m- \r
+ flatten\r
+ [ abs ZERO-VALUE < ] all?\r
+;\r
+\r
+: valid-solution? ( matrice n -- ? )\r
+ islenght=?\r
+ [ compare-nleft-to-identity-matrix ] \r
+ [ 2drop f ] if ; inline\r
+\r
+: intersect-hyperplanes ( matrice -- seq )\r
+ [ solution dup ] [ first dimension ] bi\r
+ valid-solution? [ get-intersection ] [ drop f ] if ;\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+\r
+TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
+: <face> ( v -- tuple ) face new swap >>halfspace ;\r
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
+: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
+: faces-intersection ( faces -- v ) \r
+ [ halfspace>> ] map intersect-hyperplanes ;\r
+: face-translate ( face v -- face ) \r
+ [ translate ] curry change-halfspace ; inline\r
+: face-transform ( face m -- face )\r
+ [ transform ] curry change-halfspace ; inline\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
+: pv-factor ( face -- f face ) \r
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
+: suffix-touching-corner ( face corner -- face ) \r
+ [ suffix ] curry change-touching-corners ; inline\r
+: real-face? ( face -- ? )\r
+ [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
+\r
+: (add-to-adjacent-faces) ( face face -- face )\r
+ over adjacent-faces>> 2dup member?\r
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
+\r
+: add-to-adjacent-faces ( face face -- face )\r
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
+\r
+: update-adjacent-faces ( faces corner -- )\r
+ '[ [ _ suffix-touching-corner drop ] each ] keep \r
+ 2 among [ \r
+ [ first ] keep second \r
+ [ add-to-adjacent-faces drop ] 2keep \r
+ swap add-to-adjacent-faces drop \r
+ ] each ; inline\r
+\r
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
+\r
+: apply-light ( color light normal -- u )\r
+ over direction>> v. \r
+ neg dup 0 > \r
+ [ \r
+ [ color>> swap ] dip \r
+ [ * ] curry map v+ \r
+ [ 1 min ] map \r
+ ] \r
+ [ 2drop ] \r
+ if\r
+;\r
+\r
+: enlight-projection ( array face -- color )\r
+ ! array = lights + ambient color\r
+ [ [ third ] [ second ] [ first ] tri ]\r
+ [ halfspace>> project-vector normalize ] bi*\r
+ [ apply-light ] curry each\r
+ v*\r
+;\r
+\r
+: (intersection-into-face) ( face-init face-adja quot -- face )\r
+ [\r
+ [ [ pv-factor ] bi@ \r
+ roll \r
+ [ map ] 2bi@\r
+ v-\r
+ ] 2keep\r
+ [ touching-corners>> ] bi@\r
+ [ swap [ = ] curry find nip f = ] curry find nip\r
+ ] dip over\r
+ [\r
+ call\r
+ dupd\r
+ point-inside-halfspace? [ vneg ] unless \r
+ <face> \r
+ ] [ 3drop f ] if \r
+ ; inline\r
+\r
+: intersection-into-face ( face-init face-adja -- face )\r
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
+\r
+: intersection-into-silhouette-face ( face-init face-adja -- face )\r
+ [ ] (intersection-into-face) ;\r
+\r
+: intersections-into-faces ( face -- faces )\r
+ clone dup adjacent-faces>> [ intersection-into-face ] with map \r
+ [ ] filter ;\r
+\r
+: (face-silhouette) ( face -- faces )\r
+ clone dup adjacent-faces>>\r
+ [ backface?\r
+ [ intersection-into-silhouette-face ] [ 2drop f ] if \r
+ ] with map \r
+ [ ] filter\r
+; inline\r
+\r
+: face-silhouette ( face -- faces ) \r
+ backface? [ drop f ] [ (face-silhouette) ] if ;\r
+\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
+\r
+: <solid> ( -- tuple ) solid new ;\r
+\r
+: suffix-silhouettes ( solid silhouette -- solid ) \r
+ [ suffix ] curry change-silhouettes ;\r
+\r
+: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
+\r
+: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
+\r
+: erase-solid-corners ( solid -- solid ) f >>corners ;\r
+\r
+: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
+\r
+: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
+\r
+: initiate-solid-from-face ( face -- solid ) \r
+ face-project-dim <solid> swap >>dimension ;\r
+\r
+: erase-old-adjacencies ( solid -- solid )\r
+ erase-solid-corners\r
+ [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
+ change-faces ;\r
+\r
+: point-inside-or-on-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
+\r
+: point-inside-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-halfspace? ;\r
+\r
+: point-inside-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+\r
+: point-inside-or-on-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
+\r
+: unvalid-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
+\r
+: add-face ( solid face -- solid ) \r
+ suffix-face unvalid-adjacencies ; \r
+\r
+: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
+\r
+: slice-solid ( solid face -- solid1 solid2 )\r
+ [ [ clone ] bi@ flip-face add-face \r
+ [ "/outer/" append ] change-name ] 2keep\r
+ add-face [ "/inner/" append ] change-name ;\r
+\r
+! -------------\r
+\r
+\r
+: add-silhouette ( solid -- solid )\r
+ dup \r
+ ! find-adjacencies \r
+ faces>> { } \r
+ [ face-silhouette append ] reduce\r
+ [ ] filter \r
+ <solid> \r
+ swap >>faces\r
+ over dimension>> >>dimension \r
+ over name>> " silhouette " append \r
+ pv> number>string append \r
+ >>name\r
+ ! ensure-adjacencies\r
+ suffix-silhouettes ; inline\r
+\r
+: find-silhouettes ( solid -- solid )\r
+ { } >>silhouettes \r
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
+\r
+: ensure-silhouettes ( solid -- solid )\r
+ dup silhouettes>> [ f = ] all?\r
+ [ find-silhouettes ] when ; \r
+\r
+! ------------\r
+\r
+: corner-added? ( solid corner -- ? ) \r
+ ! add corner to solid if it is inside solid\r
+ [ ] \r
+ [ point-inside-or-on-solid? ] \r
+ [ swap corners>> member? not ] \r
+ 2tri and\r
+ [ suffix-corner drop t ] [ 2drop f ] if ;\r
+\r
+: process-corner ( solid faces corner -- )\r
+ swapd \r
+ [ corner-added? ] keep swap ! test if corner is inside solid\r
+ [ update-adjacent-faces ] \r
+ [ 2drop ]\r
+ if ;\r
+\r
+: compute-intersection ( solid faces -- )\r
+ dup faces-intersection\r
+ dup f = [ 3drop ] [ process-corner ] if ;\r
+\r
+: test-faces-combinaisons ( solid n -- )\r
+ [ dup faces>> ] dip among \r
+ [ compute-intersection ] with each ;\r
+\r
+: compute-adjacencies ( solid -- solid )\r
+ dup dimension>> [ >= ] curry \r
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
+ [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;\r
+\r
+: find-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies \r
+ compute-adjacencies\r
+ filter-real-faces \r
+ t >>adjacencies-valid ;\r
+\r
+: ensure-adjacencies ( solid -- solid ) \r
+ dup adjacencies-valid>> \r
+ [ find-adjacencies ] unless \r
+ ensure-silhouettes\r
+ ;\r
+\r
+: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
+\r
+: compare-corners-roughly ( corner corner -- ? )\r
+ 2drop t ;\r
+! : remove-inner-faces ( -- ) ;\r
+: face-project ( array face -- seq )\r
+ backface? \r
+ [ 2drop f ]\r
+ [ [ enlight-projection ] \r
+ [ initiate-solid-from-face ]\r
+ [ intersections-into-faces ] tri\r
+ >>faces\r
+ swap >>color \r
+ ] if ;\r
+\r
+: solid-project ( lights ambient solid -- solids )\r
+ ensure-adjacencies\r
+ [ color>> ] [ faces>> ] bi [ 3array ] dip\r
+ [ face-project ] with map \r
+ [ ] filter \r
+ [ ensure-adjacencies ] map\r
+;\r
+\r
+: (solid-move) ( solid v move -- solid ) \r
+ curry [ map ] curry \r
+ [ dup faces>> ] dip call drop \r
+ unvalid-adjacencies ; inline\r
+\r
+: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
+\r
+: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
+ pv> swap silhouettes>> nth \r
+ swap corners>>\r
+ [ point-inside-solid? ] with find swap ;\r
+\r
+: valid-face-for-order ( solid point -- face )\r
+ [ point-inside-face? not ] \r
+ [ drop face-orientation 0 = not ] 2bi and ;\r
+\r
+: check-orientation ( s1 s2 pt -- int )\r
+ [ nip faces>> ] dip\r
+ [ valid-face-for-order ] curry find swap\r
+ [ face-orientation ] [ drop f ] if ;\r
+\r
+: (order-solid) ( s1 s2 -- int )\r
+ 2dup find-corner-in-silhouette\r
+ [ check-orientation ] [ 3drop f ] if ;\r
+\r
+: order-solid ( solid solid -- i ) \r
+ 2dup (order-solid)\r
+ [ 2nip ]\r
+ [ swap (order-solid)\r
+ [ neg ] [ f ] if*\r
+ ] if* ;\r
+\r
+: subtract ( solid1 solid2 -- solids )\r
+ faces>> swap clone ensure-adjacencies ensure-silhouettes \r
+ [ swap slice-solid drop ] curry map\r
+ [ non-empty-solid? ] filter\r
+ [ ensure-adjacencies ] map\r
+; inline\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+TUPLE: space name dimension solids ambient-color lights ;\r
+: <space> ( -- space ) space new ;\r
+: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
+: clear-space-solids ( space -- space ) f >>solids ;\r
+\r
+: space-ensure-solids ( space -- space ) \r
+ [ [ ensure-adjacencies ] map ] change-solids ;\r
+: eliminate-empty-solids ( space -- space ) \r
+ [ [ non-empty-solid? ] filter ] change-solids ;\r
+\r
+: projected-space ( space solids -- space ) \r
+ swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
+\r
+: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+\r
+: space-apply ( space m quot -- space ) \r
+ curry [ map ] curry [ dup solids>> ] dip\r
+ [ call ] [ drop ] recover drop ;\r
+: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
+\r
+: describe-space ( space -- ) \r
+ solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+\r
+: clip-solid ( solid solid -- solids )\r
+ [ ]\r
+ [ solid= not ]\r
+ [ order-solid -1 = ] 2tri \r
+ and\r
+ [ get-silhouette subtract ] \r
+ [ drop 1array ] \r
+ if \r
+ \r
+ ;\r
+\r
+: (solids-silhouette-subtract) ( solids solid -- solids ) \r
+ [ clip-solid append ] curry { } -rot each ; inline\r
+\r
+: solids-silhouette-subtract ( solids i solid -- solids )\r
+! solids is an array of 1 solid arrays\r
+ [ (solids-silhouette-subtract) ] curry map-but \r
+; inline \r
+\r
+: remove-hidden-solids ( space -- space ) \r
+! We must include each solid in a sequence because during substration \r
+! a solid can be divided in more than on solid\r
+ [ \r
+ [ [ 1array ] map ] \r
+ [ length ] \r
+ [ ] \r
+ tri \r
+ [ solids-silhouette-subtract ] 2each\r
+ { } [ append ] reduce \r
+ ] change-solids\r
+ eliminate-empty-solids ! TODO include into change-solids\r
+;\r
+\r
+: space-project ( space i -- space )\r
+ [\r
+ [ clone \r
+ remove-hidden-solids? [ remove-hidden-solids ] when\r
+ dup \r
+ [ solids>> ] \r
+ [ lights>> ] \r
+ [ ambient-color>> ] tri \r
+ [ rot solid-project ] 2curry \r
+ map \r
+ [ append ] { } -rot each \r
+ ! TODO project lights\r
+ projected-space \r
+ ! remove-inner-faces \r
+ ! \r
+ eliminate-empty-solids\r
+ ] with-pv \r
+ ] [ 3drop <space> ] recover\r
+ ; inline\r
+\r
+: middle-of-space ( space -- point )\r
+ solids>> [ corners>> ] map concat\r
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
+;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+\r
+: face-reference ( face -- halfspace point vect )\r
+ [ halfspace>> ] \r
+ [ touching-corners>> first ] \r
+ [ touching-corners>> second ] tri \r
+ over v-\r
+;\r
+\r
+: theta ( v halfspace point vect -- v x )\r
+ [ [ over ] dip v- ] dip \r
+ [ cross dup norm >float ]\r
+ [ v. >float ] \r
+ 2bi \r
+ fatan2\r
+ -rot v. \r
+ 0 < [ neg ] when\r
+;\r
+\r
+: ordered-face-points ( face -- corners ) \r
+ [ touching-corners>> 1 head ] \r
+ [ touching-corners>> 1 tail ] \r
+ [ face-reference [ theta ] 3curry ] tri\r
+ { } map>assoc sort-values keys \r
+ append\r
+ ; inline\r
+\r
+: point->GL ( point -- ) gl-vertex ;\r
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
+\r
+: face->GL ( face color -- )\r
+ [ ordered-face-points ] dip\r
+ [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
+ bi\r
+ ; inline\r
+\r
+: solid->GL ( solid -- ) \r
+ [ faces>> ] \r
+ [ color>> ] bi\r
+ [ face->GL ] curry each ; inline\r
+\r
+: space->GL ( space -- )\r
+ solids>>\r
+ [ solid->GL ] each ;\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+! : init-4D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 4 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
+ { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+! : init-3D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 3 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
+ ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
--- /dev/null
+Jeff Bigot\r
+Greg Ferrar
\ No newline at end of file
--- /dev/null
+JF Bigot, after Greg Ferrar
\ No newline at end of file
--- /dev/null
+! 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"
--- /dev/null
+USING: adsoda.combinators\r
+sequences\r
+ tools.test \r
+ ;\r
+\r
+IN: adsoda.combinators.tests\r
+\r
+\r
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
+ unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays sequences fry math combinators ;\r
+\r
+IN: adsoda.combinators\r
+\r
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
+\r
+! : prefix-each [ prefix ] curry map ; inline\r
+\r
+! : combinations ( seq n -- seqs )\r
+! {\r
+! { [ dup 0 = ] [ 2drop { { } } ] }\r
+! { [ over empty? ] [ 2drop { } ] }\r
+! { [ t ] [ \r
+! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ (combinations) ] 2bi append\r
+! ] }\r
+! } cond ;\r
+\r
+: columnize ( array -- array ) [ 1array ] map ; inline\r
+\r
+: among ( array n -- array )\r
+ 2dup swap length \r
+ {\r
+ { [ over 1 = ] [ 3drop columnize ] }\r
+ { [ over 0 = ] [ 2drop 2drop { } ] }\r
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
+ [ 1- among [ append ] with map ] \r
+ [ among append ] 2bi\r
+ ] }\r
+ { [ 2dup = ] [ 3drop 1array ] }\r
+ { [ 2dup > ] [ 2drop 2drop { } ] } \r
+ } cond\r
+;\r
+\r
+: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\r
+\r
+: do-cycle ( array -- array ) dup first suffix ;\r
+\r
+: map-but ( seq i quot -- seq )\r
+ ! quot : ( seq x -- seq )\r
+ '[ _ = [ @ ] unless ] map-index ; inline\r
+\r
--- /dev/null
+USING: kernel\r
+sequences\r
+namespaces\r
+\r
+math\r
+math.vectors\r
+math.matrices\r
+;\r
+IN: adsoda.solution2\r
+\r
+! -------------------\r
+! correctif solution\r
+! ---------------\r
+SYMBOL: matrix\r
+: MIN-VAL-adsoda ( -- x ) 0.00000001\r
+! 0.000000000001 \r
+;\r
+\r
+: zero? ( x -- ? ) \r
+ abs MIN-VAL-adsoda <\r
+;\r
+\r
+! [ number>string string>number ] map \r
+\r
+: with-matrix ( matrix quot -- )\r
+ [ swap matrix set call matrix get ] with-scope ; inline\r
+\r
+: nth-row ( row# -- seq ) matrix get nth ;\r
+\r
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
+ matrix get swap change-nth ; inline\r
+\r
+: exchange-rows ( row# row# -- ) matrix get exchange ;\r
+\r
+: rows ( -- n ) matrix get length ;\r
+\r
+: cols ( -- n ) 0 nth-row length ;\r
+\r
+: skip ( i seq quot -- n )\r
+ over [ find-from drop ] dip length or ; inline\r
+\r
+: first-col ( row# -- n )\r
+ #! First non-zero column\r
+ 0 swap nth-row [ zero? not ] skip ;\r
+\r
+: clear-scale ( col# pivot-row i-row -- n )\r
+ [ over ] dip nth dup zero? [\r
+ 3drop 0\r
+ ] [\r
+ [ nth dup zero? ] dip swap [\r
+ 2drop 0\r
+ ] [\r
+ swap / neg\r
+ ] if\r
+ ] if ;\r
+\r
+: (clear-col) ( col# pivot-row i -- )\r
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
+\r
+: rows-from ( row# -- slice )\r
+ rows dup <slice> ;\r
+\r
+: clear-col ( col# row# rows -- )\r
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
+\r
+: do-row ( exchange-with row# -- )\r
+ [ exchange-rows ] keep\r
+ [ first-col ] keep\r
+ dup 1+ rows-from clear-col ;\r
+\r
+: find-row ( row# quot -- i elt )\r
+ [ rows-from ] dip find ; inline\r
+\r
+: pivot-row ( col# row# -- n )\r
+ [ dupd nth-row nth zero? not ] find-row 2nip ;\r
+\r
+: (echelon) ( col# row# -- )\r
+ over cols < over rows < and [\r
+ 2dup pivot-row [ over do-row 1+ ] when*\r
+ [ 1+ ] dip (echelon)\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: echelon ( matrix -- matrix' )\r
+ [ 0 0 (echelon) ] with-matrix ;\r
+\r
+: nonzero-rows ( matrix -- matrix' )\r
+ [ [ zero? ] all? not ] filter ;\r
+\r
+: null/rank ( matrix -- null rank )\r
+ echelon dup length swap nonzero-rows length [ - ] keep ;\r
+\r
+: leading ( seq -- n elt ) [ zero? not ] find ;\r
+\r
+: reduced ( matrix' -- matrix'' )\r
+ [\r
+ rows <reversed> [\r
+ dup nth-row leading drop\r
+ dup [ swap dup clear-col ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix ;\r
+\r
+: basis-vector ( row col# -- )\r
+ [ clone ] dip\r
+ [ swap nth neg recip ] 2keep\r
+ [ 0 spin set-nth ] 2keep\r
+ [ n*v ] dip\r
+ matrix get set-nth ;\r
+\r
+: nullspace ( matrix -- seq )\r
+ echelon reduced dup empty? [\r
+ dup first length identity-matrix [\r
+ [\r
+ dup leading drop\r
+ dup [ basis-vector ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix flip nonzero-rows\r
+ ] unless ;\r
+\r
+: 1-pivots ( matrix -- matrix )\r
+ [ dup leading nip [ recip v*n ] when* ] map ;\r
+\r
+: solution ( matrix -- matrix )\r
+ echelon nonzero-rows reduced 1-pivots ;\r
+\r
--- /dev/null
+A modification of solution to approximate solutions
\ No newline at end of file
--- /dev/null
+ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
--- /dev/null
+adsoda 4D viewer
\ No newline at end of file
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! 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"
+
+
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+adsoda.tools\r
+tools.test\r
+;\r
+\r
+IN: adsoda.tools.tests\r
+\r
+\r
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
+\r
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+kernel\r
+sequences\r
+math\r
+accessors\r
+adsoda\r
+math.vectors \r
+math.matrices\r
+bunny.model\r
+io.encodings.ascii\r
+io.files\r
+sequences.deep\r
+combinators\r
+adsoda.combinators\r
+fry\r
+io.files.temp\r
+grouping\r
+;\r
+\r
+IN: adsoda.tools\r
+\r
+\r
+\r
+\r
+\r
+! ---------------------------------\r
+: coord-min ( x array -- array ) swap suffix ;\r
+: coord-max ( x array -- array ) swap neg suffix ;\r
+\r
+: 4cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 4 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+: 3cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 3 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+\r
+: equation-system-for-normal ( points -- matrix )\r
+ unclip [ v- 0 suffix ] curry map\r
+ dup first [ drop 1 ] map suffix\r
+;\r
+\r
+: normal-vector ( points -- v ) \r
+ equation-system-for-normal\r
+ intersect-hyperplanes ;\r
+\r
+: points-to-hyperplane ( points -- hyperplane )\r
+ [ normal-vector 0 suffix ] [ first ] bi\r
+ translate ;\r
+\r
+: refs-to-points ( points faces -- faces )\r
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
+;\r
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
+\r
+: ply-model-path ( -- path )\r
+\r
+! "bun_zipper.ply" \r
+"screw2.ply"\r
+temp-file \r
+;\r
+\r
+: read-bunny-model ( -- v )\r
+ply-model-path ascii [ parse-model ] with-file-reader\r
+\r
+refs-to-points\r
+;\r
+\r
+: 3points-to-normal ( seq -- v )\r
+ unclip [ v- ] curry map first2 cross normalize\r
+;\r
+: 2-faces-to-prism ( seq seq -- seq )\r
+ 2dup\r
+ [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
+ swap prefix\r
+ swap prefix\r
+; \r
+\r
+: Xpoints-to-prisme ( seq height -- cube )\r
+ ! from 3 points gives a list of faces representing a cube of height "height"\r
+ ! and of based on the three points\r
+ ! a face is a group of 3 or mode points. \r
+ [ dup dup 3points-to-normal ] dip \r
+ v*n [ v+ ] curry map ! 2 eme face triangulaire \r
+ 2-faces-to-prism \r
+\r
+! [ dup number? [ 1 + ] when ] deep-map\r
+! dup keep \r
+;\r
+\r
+\r
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
+ ! from 3 points gives a list of faces representing a cube in 4th dim\r
+ ! from x to y (height = y-x)\r
+ ! and of based on the X points\r
+ ! a face is a group of 3 or mode points. \r
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
+ 2-faces-to-prism\r
+;\r
+\r
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
+ [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
+\r
+;\r
+\r
+: test-figure ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+\r
--- /dev/null
+
+USING: kernel quotations arrays sequences math math.ranges fry
+ opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
+ accessors
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.plot
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "ui.gadgets.plot" "Plot Gadget"
+
+Summary:
+
+ A simple gadget for ploting two dimentional functions.
+
+ Use the arrow keys to move around.
+
+ Use 'a' and 'z' keys to zoom in and out. ..
+
+Example:
+
+ <plot> [ sin ] add-function gadget. ..
+
+Example:
+
+ <plot>
+ [ sin ] red function boa add-function
+ [ cos ] blue function boa add-function
+ gadget. ..
+
+;
+
+ABOUT: "ui.gadgets.plot"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: plot < cartesian functions points ;
+
+: init-plot ( plot -- plot )
+ init-cartesian
+ { } >>functions
+ 100 >>points ;
+
+: <plot> ( -- plot ) plot new init-plot ;
+
+: step-size ( plot -- step-size )
+ [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
+
+: plot-range ( plot -- range )
+ [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: function function color ;
+
+GENERIC: plot-function ( plot object -- plot )
+
+M: callable plot-function ( plot quotation -- plot )
+ [ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
+
+M: function plot-function ( plot function -- plot )
+ dup color>> dup [ >stroke-color ] [ drop ] if
+ [ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
+
+: draw-axis ( plot -- plot )
+ dup
+ [ [ x-min>> ] [ drop 0 ] bi 2array ]
+ [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
+ dup
+ [ [ drop 0 ] [ y-min>> ] bi 2array ]
+ [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gadgets.slate ;
+
+M: plot draw-slate ( plot -- plot )
+ 2 glLineWidth
+ draw-axis
+ plot-functions
+ fill-mode
+ 1 glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-function ( plot function -- plot )
+ over functions>> swap suffix >>functions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
+: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gestures ui.gadgets ;
+
+: left ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
+ dup relayout-1 ;
+
+: right ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
+ dup relayout-1 ;
+
+: down ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
+ dup relayout-1 ;
+
+: up ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-in-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
+
+: zoom-in-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
+
+: zoom-in ( plot -- plot )
+ zoom-in-horizontal
+ zoom-in-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-out-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
+
+: zoom-out-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
+
+: zoom-out ( plot -- plot )
+ zoom-out-horizontal
+ zoom-out-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+plot
+ H{
+ { T{ mouse-enter } [ request-focus ] }
+ { T{ key-down f f "LEFT" } [ left drop ] }
+ { T{ key-down f f "RIGHT" } [ right drop ] }
+ { T{ key-down f f "DOWN" } [ down drop ] }
+ { T{ key-down f f "UP" } [ up drop ] }
+ { T{ key-down f f "a" } [ zoom-in drop ] }
+ { T{ key-down f f "z" } [ zoom-out drop ] }
+ }
+set-gestures
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces opengl ui.render ui.gadgets accessors
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.slate
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "slate" "Slate Gadget"
+
+Summary:
+
+ A gadget with an 'action' slot which should be set to a callable. ..
+
+Example:
+
+ ! Load the right vocabs for the examples
+
+ USING: processing.shapes ui.gadgets.slate ; ..
+
+Example:
+
+ [ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
+ gadget. ..
+
+;
+
+ABOUT: "slate"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+
+USING: kernel sequences math math.order
+ ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.tiling
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
+
+Summary:
+
+ A gadget which tiles it's children.
+
+ A tiling gadget may contain any number of children, but only a
+ fixed number is displayed at one time. How many are displayed can
+ be controlled via Control-[ and Control-].
+
+ The focus may be switched with Alt-Left and Alt-Right.
+
+ The focused child may be moved via Shift-Alt-Left and
+ Shift-Alt-Right. ..
+
+Example:
+
+ <tiling-shelf>
+ "resource:" directory-files
+ [ [ drop ] <bevel-button> tiling-add ]
+ each
+ "Files" open-window ..
+
+;
+
+ABOUT: "ui.gadgets.tiling"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+ init-track
+ { 1 0 } >>orientation
+ V{ } clone >>gadgets
+ 2 >>tiles
+ 0 >>first
+ 0 >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+ [ 0 max ] dip
+ pick length [ min ] curry bi@
+ rot
+ subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+ [ gadgets>> ]
+ [ first>> ]
+ [ [ first>> ] [ tiles>> ] bi + ]
+ tri
+ bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+ dup clear-track
+ dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+ over gadgets>> push
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+ dup [ focused>> ] [ first>> ] bi <
+ [ dup first>> 1 - >>first ]
+ [ ]
+ if
+
+ dup [ last-viewable ] [ focused>> ] bi <
+ [ dup first>> 1 + >>first ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+ dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+ dup focused>> 1 - >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+ dup focused>> 1 + >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+ [ 0 max ] bi@
+ pick length 1 - '[ _ min ] bi@
+ rot exchange ;
+
+: move-prev ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+ focus-prev ;
+
+: move-next ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+ focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+ dup tiles>> 1 + >>tiles
+ tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+ dup tiles>> 1 - 1 max >>tiles
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+ [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+ tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+ { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
+
+tiling-pile
+ H{
+ { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
-#CFLAGS += -mwindows
+CFLAGS += -mwindows
+CFLAGS_CONSOLE += -mconsole
include vm/Config.windows
void open_console(void)
{
- /*
- // Do this: http://www.cygwin.com/ml/cygwin/2007-11/msg00432.html
- if(console_open)
- return;
-
- if(AttachConsole(ATTACH_PARENT_PROCESS) || AllocConsole())
- {
- console_open = true;
- }
- */
}
void c_to_factor_toplevel(CELL quot);
long exception_handler(PEXCEPTION_POINTERS pe);
-bool console_open;
void open_console(void);
dll->dll = NULL;
}
+bool windows_stat(F_CHAR *path)
+{
+ BY_HANDLE_FILE_INFORMATION bhfi;
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
+ if(h == INVALID_HANDLE_VALUE)
+ {
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ return false;
+ FindClose(h);
+ return true;
+ }
+ bool ret;
+ ret = GetFileInformationByHandle(h, &bhfi);
+ CloseHandle(h);
+ return ret;
+}
+
+void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length)
+{
+ snwprintf(temp_path, length-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
+}
+
/* You must free() this yourself. */
const F_CHAR *default_image_path(void)
{
F_CHAR full_path[MAX_UNICODE_PATH];
F_CHAR *ptr;
- F_CHAR path_temp[MAX_UNICODE_PATH];
+ F_CHAR temp_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
fatal_error("GetModuleFileName() failed", 0);
if((ptr = wcsrchr(full_path, '.')))
*ptr = 0;
- snwprintf(path_temp, sizeof(path_temp)-1, L"%s.image", full_path);
- path_temp[sizeof(path_temp) - 1] = 0;
+ snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
- return safe_strdup(path_temp);
+ if(!windows_stat(temp_path)) {
+ unsigned int len = wcslen(full_path);
+ F_CHAR magic[] = L"-console";
+ unsigned int magic_len = wcslen(magic);
+
+ if(!wcsncmp(full_path + len - magic_len, magic, MIN(len, magic_len)))
+ full_path[len - magic_len] = 0;
+ snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
+ }
+
+ return safe_strdup(temp_path);
}
/* You must free() this yourself. */
return safe_strdup(full_path);
}
+
void primitive_existsp(void)
{
- BY_HANDLE_FILE_INFORMATION bhfi;
F_CHAR *path = unbox_u16_string();
- HANDLE h = CreateFileW(path,
- GENERIC_READ,
- FILE_SHARE_READ,
- NULL,
- OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS,
- NULL);
-
- if(h == INVALID_HANDLE_VALUE)
- {
- // FindFirstFile is the only call that can stat c:\pagefile.sys
- WIN32_FIND_DATA st;
- HANDLE h;
-
- if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- dpush(F);
- else
- {
- FindClose(h);
- dpush(T);
- }
- return;
- }
-
- box_boolean(GetFileInformationByHandle(h, &bhfi));
- CloseHandle(h);
+ box_boolean(windows_stat(path));
}
F_SEGMENT *alloc_segment(CELL size)
#define STRCMP wcscmp
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
+#define MIN(a,b) ((a)>(b)?(b):(a))
#ifdef WIN64
#define CELL_FORMAT "%Iu"
projects / factor.git / commitdiff