Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
eda80c2a3e
|
|
@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE
|
|||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
] must-fail
|
||||
|
||||
[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
|
||||
|
|
|
|||
|
|
@ -151,7 +151,8 @@ M: byte-array byte-length length ;
|
|||
swap dup length memcpy ;
|
||||
|
||||
: (define-nth) ( word type quot -- )
|
||||
>r heap-size [ rot * ] swap prefix r> append define-inline ;
|
||||
>r heap-size [ rot * >fixnum ] swap prefix
|
||||
r> append define-inline ;
|
||||
|
||||
: nth-word ( name vocab -- word )
|
||||
>r "-nth" append r> create ;
|
||||
|
|
@ -348,7 +349,7 @@ M: long-long-type box-return ( type -- )
|
|||
|
||||
<c-type>
|
||||
[ alien-unsigned-4 zero? not ] >>getter
|
||||
[ 1 0 ? set-alien-unsigned-4 ] >>setter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_boolean" >>boxer
|
||||
|
|
@ -357,7 +358,7 @@ M: long-long-type box-return ( type -- )
|
|||
|
||||
<c-type>
|
||||
[ alien-float ] >>getter
|
||||
[ >r >r >float r> r> set-alien-float ] >>setter
|
||||
[ [ >float ] 2dip set-alien-float ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_float" >>boxer
|
||||
|
|
@ -368,7 +369,7 @@ M: long-long-type box-return ( type -- )
|
|||
|
||||
<c-type>
|
||||
[ alien-double ] >>getter
|
||||
[ >r >r >float r> r> set-alien-double ] >>setter
|
||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_double" >>boxer
|
||||
|
|
|
|||
|
|
@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
|
|||
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
||||
{ $subsection key? }
|
||||
{ $subsection at }
|
||||
{ $subsection value-at }
|
||||
{ $subsection assoc-empty? }
|
||||
{ $subsection keys }
|
||||
{ $subsection values }
|
||||
{ $subsection assoc-stack }
|
||||
{ $see-also at* assoc-size } ;
|
||||
|
||||
ARTICLE: "assocs-values" "Transposed assoc operations"
|
||||
"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
|
||||
{ $subsection value-at }
|
||||
{ $subsection value-at* }
|
||||
{ $subsection value? }
|
||||
"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ;
|
||||
|
||||
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
|
||||
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
|
||||
{ $subsection assoc-subset? }
|
||||
|
|
@ -111,6 +117,7 @@ $nl
|
|||
{ $subsection "assocs-protocol" }
|
||||
"A large set of utility words work on any object whose class implements the associative mapping protocol."
|
||||
{ $subsection "assocs-lookup" }
|
||||
{ $subsection "assocs-values" }
|
||||
{ $subsection "assocs-mutation" }
|
||||
{ $subsection "assocs-combinators" }
|
||||
{ $subsection "assocs-sets" } ;
|
||||
|
|
@ -231,10 +238,17 @@ HELP: assoc-stack
|
|||
{ $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." }
|
||||
{ $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ;
|
||||
|
||||
HELP: value-at*
|
||||
{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ;
|
||||
|
||||
HELP: value-at
|
||||
{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } }
|
||||
{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." }
|
||||
{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ;
|
||||
{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ;
|
||||
|
||||
HELP: value?
|
||||
{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } }
|
||||
{ $description "Tests if an assoc contains at least one key with the given value." } ;
|
||||
|
||||
HELP: delete-at*
|
||||
{ $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: extract-keys ( seq assoc -- subassoc )
|
||||
[ [ dupd at ] curry ] keep map>assoc ;
|
||||
|
||||
! M: assoc >alist [ 2array ] { } assoc>map ;
|
||||
GENERIC: value-at* ( value assoc -- key/f ? )
|
||||
|
||||
: value-at ( value assoc -- key/f )
|
||||
swap [ = nip ] curry assoc-find 2drop ;
|
||||
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
||||
|
||||
: value-at ( value assoc -- key/f ) value-at* drop ;
|
||||
|
||||
: value? ( value assoc -- ? ) value-at* nip ;
|
||||
|
||||
: push-at ( value key assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
|
|
|||
|
|
@ -119,6 +119,7 @@ SYMBOL: jit-primitive
|
|||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-literal
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-jump
|
||||
SYMBOL: jit-dispatch-word
|
||||
|
|
@ -149,6 +150,7 @@ SYMBOL: undefined-quot
|
|||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-declare-word 42 }
|
||||
{ undefined-quot 60 }
|
||||
} at header-size + ;
|
||||
|
|
@ -438,6 +440,7 @@ M: quotation '
|
|||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-literal
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-jump
|
||||
jit-dispatch-word
|
||||
|
|
|
|||
|
|
@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ;
|
|||
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
|
||||
|
||||
[ ] [ object flatten-builtin-class drop ] unit-test
|
||||
|
||||
SINGLETON: sa
|
||||
SINGLETON: sb
|
||||
SINGLETON: sc
|
||||
|
||||
[ sa ] [ sa { sa sb sc } min-class ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.predicate kernel sequences words ;
|
||||
USING: classes classes.algebra classes.predicate kernel
|
||||
sequences words ;
|
||||
IN: classes.singleton
|
||||
|
||||
PREDICATE: singleton-class < predicate-class
|
||||
|
|
@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class
|
|||
\ word over [ eq? ] curry define-predicate-class ;
|
||||
|
||||
M: singleton-class instance? eq? ;
|
||||
|
||||
M: singleton-class (classes-intersect?)
|
||||
over singleton-class? [ eq? ] [ call-next-method ] if ;
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ must-fail-with
|
|||
[ error>> unexpected-eof? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ]
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
|
||||
[ error>> no-initial-value? ]
|
||||
must-fail-with
|
||||
|
||||
|
|
|
|||
|
|
@ -298,16 +298,16 @@ $nl
|
|||
"For example, compare the definitions of the " { $link sbuf } " class,"
|
||||
{ $code
|
||||
"TUPLE: sbuf"
|
||||
"{ \"underlying\" string }"
|
||||
"{ \"length\" array-capacity } ;"
|
||||
"{ underlying string }"
|
||||
"{ length array-capacity } ;"
|
||||
""
|
||||
"INSTANCE: sbuf growable"
|
||||
}
|
||||
"with that of the " { $link vector } " class:"
|
||||
{ $code
|
||||
"TUPLE: vector"
|
||||
"{ \"underlying\" array }"
|
||||
"{ \"length\" array-capacity } ;"
|
||||
"{ underlying array }"
|
||||
"{ length array-capacity } ;"
|
||||
""
|
||||
"INSTANCE: vector growable"
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -336,6 +336,8 @@ M: tuple-class boa
|
|||
[ tuple-layout ]
|
||||
bi <tuple-boa> ;
|
||||
|
||||
M: tuple-class initial-value* new ;
|
||||
|
||||
! Deprecated
|
||||
M: object get-slots ( obj slots -- ... )
|
||||
[ execute ] with each ;
|
||||
|
|
|
|||
|
|
@ -40,6 +40,12 @@ big-endian off
|
|||
ds-reg [] arg0 MOV ! store literal on datastack
|
||||
] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
|
||||
|
||||
[
|
||||
arg0 0 MOV ! load literal
|
||||
ds-reg bootstrap-cell ADD ! increment datastack pointer
|
||||
ds-reg [] arg0 MOV ! store literal on datastack
|
||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
arg0 0 MOV ! load XT
|
||||
arg1 stack-reg MOV ! pass callstack pointer as arg 2
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ SYMBOL: label-table
|
|||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ;
|
|||
IN: grouping
|
||||
|
||||
ARTICLE: "grouping" "Groups and clumps"
|
||||
"Splitting a sequence into disjoint, fixed-length subsequences:"
|
||||
{ $subsection group }
|
||||
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
|
||||
{ $subsection groups }
|
||||
{ $subsection <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"Splitting a sequence into overlapping, fixed-length subsequences:"
|
||||
{ $subsection clump }
|
||||
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
|
||||
{ $subsection clumps }
|
||||
{ $subsection <clumps> }
|
||||
|
|
|
|||
|
|
@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- )
|
|||
2dup (>>length)
|
||||
] when 2drop ;
|
||||
|
||||
M: growable shorten ( n seq -- )
|
||||
growable-check
|
||||
2dup length < [
|
||||
2dup contract
|
||||
2dup (>>length)
|
||||
] when 2drop ;
|
||||
|
||||
INSTANCE: growable sequence
|
||||
|
|
|
|||
|
|
@ -5,8 +5,9 @@ sequences words inference.class quotations alien
|
|||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system layouts vectors optimizer.math.partial
|
||||
optimizer.inlining optimizer.backend math.order
|
||||
accessors hashtables classes assocs ;
|
||||
optimizer.inlining optimizer.backend math.order math.functions
|
||||
accessors hashtables classes assocs io.encodings.utf8
|
||||
io.encodings.ascii io.encodings ;
|
||||
|
||||
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||
|
||||
|
|
@ -193,19 +194,15 @@ M: fixnum detect-fx ;
|
|||
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare push-all ] \ push-all inlined?
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare push-all ] \ + inlined?
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare push-all ] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { string sbuf } declare push-all ] \ >fixnum inlined?
|
||||
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
{ slot } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ array } declare length
|
||||
1 + dup 100 fixnum> [ 1 fixnum+ ] when
|
||||
] \ fixnum+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ resize-array ] keep length ] \ length inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ dup 0 > [ sqrt ] when ] \ sqrt inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { utf8 } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { ascii } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
! Later
|
||||
|
||||
! [ t ] [
|
||||
|
|
|
|||
|
|
@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- )
|
|||
|
||||
GENERIC: infer-classes-around ( node -- )
|
||||
|
||||
GENERIC: infer-classes-after ( node -- )
|
||||
|
||||
M: node infer-classes-before drop ;
|
||||
|
||||
M: node infer-classes-after drop ;
|
||||
|
||||
M: node child-constraints
|
||||
children>> length
|
||||
dup zero? [ drop f ] [ f <repetition> ] if ;
|
||||
|
|
@ -203,11 +207,19 @@ M: pair constraint-satisfied?
|
|||
[ ] [ param>> "default-output-classes" word-prop ] ?if
|
||||
r> ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
[ compute-constraints ] keep
|
||||
[ output-classes ] [ out-d>> ] bi
|
||||
: intersect-values ( classes intervals values -- )
|
||||
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
||||
|
||||
M: #call infer-classes-before
|
||||
[ compute-constraints ]
|
||||
[ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
|
||||
|
||||
: input-classes ( #call -- classes )
|
||||
param>> "input-classes" word-prop ;
|
||||
|
||||
M: #call infer-classes-after
|
||||
[ input-classes ] [ in-d>> ] bi intersect-classes ;
|
||||
|
||||
M: #push infer-classes-before
|
||||
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
|
||||
|
||||
|
|
@ -340,6 +352,7 @@ M: object infer-classes-around
|
|||
{
|
||||
[ infer-classes-before ]
|
||||
[ annotate-node ]
|
||||
[ infer-classes-after ]
|
||||
[ infer-children ]
|
||||
[ merge-children ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic sequences prettyprint io words arrays
|
||||
summary effects debugger assocs accessors inference.backend
|
||||
inference.dataflow ;
|
||||
IN: inference.errors
|
||||
USING: inference.backend inference.dataflow kernel generic
|
||||
sequences prettyprint io words arrays summary effects debugger
|
||||
assocs accessors ;
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
|
|
|
|||
|
|
@ -153,8 +153,10 @@ M: object infer-call
|
|||
] "infer" set-word-prop
|
||||
|
||||
: set-primitive-effect ( word effect -- )
|
||||
2dup effect-out "default-output-classes" set-word-prop
|
||||
dupd [ make-call-node ] 2curry "infer" set-word-prop ;
|
||||
[ in>> "input-classes" set-word-prop ]
|
||||
[ out>> "default-output-classes" set-word-prop ]
|
||||
[ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
|
||||
2tri ;
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
|
||||
|
|
|
|||
|
|
@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ;
|
|||
[ >r drop "" like r> ]
|
||||
[ pick push ((read-until)) ] if ; inline
|
||||
|
||||
: (read-until) ( seps stream -- string/f sep/f )
|
||||
SBUF" " clone -rot >decoder<
|
||||
: (read-until) ( quot -- string/f sep/f )
|
||||
100 <sbuf> swap ((read-until)) ; inline
|
||||
|
||||
: decoder-read-until ( seps stream encoding -- string/f sep/f )
|
||||
[ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
|
||||
((read-until)) ; inline
|
||||
(read-until) ;
|
||||
|
||||
M: decoder stream-read-until (read-until) ;
|
||||
M: decoder stream-read-until >decoder< decoder-read-until ;
|
||||
|
||||
M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
|
||||
: decoder-readln ( stream encoding -- string/f sep/f )
|
||||
[ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
|
||||
(read-until) ;
|
||||
|
||||
M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
|
||||
|
||||
M: decoder dispose stream>> dispose ;
|
||||
|
||||
|
|
@ -119,8 +125,11 @@ M: object <encoder> encoder boa ;
|
|||
M: encoder stream-write1
|
||||
>encoder< encode-char ;
|
||||
|
||||
: decoder-write ( string stream encoding -- )
|
||||
[ encode-char ] 2curry each ;
|
||||
|
||||
M: encoder stream-write
|
||||
>encoder< [ encode-char ] 2curry each ;
|
||||
>encoder< decoder-write ;
|
||||
|
||||
M: encoder dispose encoder-stream dispose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,21 +11,21 @@ SINGLETON: utf8
|
|||
<PRIVATE
|
||||
|
||||
: starts-2? ( char -- ? )
|
||||
dup [ -6 shift BIN: 10 number= ] when ;
|
||||
dup [ -6 shift BIN: 10 number= ] when ; inline
|
||||
|
||||
: append-nums ( stream byte -- stream char )
|
||||
over stream-read1 dup starts-2?
|
||||
[ swap 6 shift swap BIN: 111111 bitand bitor ]
|
||||
[ 2drop replacement-char ] if ;
|
||||
[ 2drop replacement-char ] if ; inline
|
||||
|
||||
: double ( stream byte -- stream char )
|
||||
BIN: 11111 bitand append-nums ;
|
||||
BIN: 11111 bitand append-nums ; inline
|
||||
|
||||
: triple ( stream byte -- stream char )
|
||||
BIN: 1111 bitand append-nums append-nums ;
|
||||
BIN: 1111 bitand append-nums append-nums ; inline
|
||||
|
||||
: quad ( stream byte -- stream char )
|
||||
BIN: 111 bitand append-nums append-nums append-nums ;
|
||||
BIN: 111 bitand append-nums append-nums append-nums ; inline
|
||||
|
||||
: begin-utf8 ( stream byte -- stream char )
|
||||
{
|
||||
|
|
@ -34,10 +34,10 @@ SINGLETON: utf8
|
|||
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
|
||||
[ drop replacement-char ]
|
||||
} cond ;
|
||||
} cond ; inline
|
||||
|
||||
: decode-utf8 ( stream -- char/f )
|
||||
dup stream-read1 dup [ begin-utf8 ] when nip ;
|
||||
dup stream-read1 dup [ begin-utf8 ] when nip ; inline
|
||||
|
||||
M: utf8 decode-char
|
||||
drop decode-utf8 ;
|
||||
|
|
|
|||
|
|
@ -114,10 +114,6 @@ IN: kernel.tests
|
|||
|
||||
[ total-failure-1 ] must-fail
|
||||
|
||||
: total-failure-2 [ ] (call) unimplemented ;
|
||||
|
||||
[ total-failure-2 ] must-fail
|
||||
|
||||
! From combinators.lib
|
||||
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
|
||||
[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs sequences inference.dataflow
|
||||
inference.backend kernel generic assocs classes vectors
|
||||
accessors combinators ;
|
||||
USING: namespaces assocs sequences kernel generic assocs classes
|
||||
vectors accessors combinators inference.dataflow inference.backend ;
|
||||
IN: optimizer.def-use
|
||||
|
||||
SYMBOL: def-use
|
||||
|
|
|
|||
|
|
@ -7,14 +7,3 @@ sequences growable sbufs vectors sequences.private accessors kernel ;
|
|||
\ optimistic-inline? must-infer
|
||||
\ find-identity must-infer
|
||||
\ dispatching-class must-infer
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
[ t ] [ \ fixnum \ shift method should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? method should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ set-nth method should-inline? ] unit-test
|
||||
[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,12 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes classes.algebra generic.math
|
||||
optimizer.math.partial continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private definitions sets ;
|
||||
math math.order namespaces sequences vectors words quotations
|
||||
hashtables combinators effects classes classes.union
|
||||
classes.algebra generic.math optimizer.math.partial
|
||||
continuations optimizer.def-use optimizer.backend
|
||||
generic.standard optimizer.specializers optimizer.def-use
|
||||
optimizer.pattern-match generic.standard optimizer.control
|
||||
kernel.private definitions sets summary ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
|
|
@ -31,9 +32,9 @@ DEFER: (flat-length)
|
|||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 0 ] }
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! recursive and inline
|
||||
{ [ dup recursive-calls get key? ] [ drop 4 ] }
|
||||
{ [ dup recursive-calls get key? ] [ drop 10 ] }
|
||||
! inline
|
||||
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
|
||||
} cond ;
|
||||
|
|
@ -41,7 +42,7 @@ DEFER: (flat-length)
|
|||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup quotation? ] [ (flat-length) 2 + ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
[ drop 0 ]
|
||||
|
|
@ -51,7 +52,7 @@ DEFER: (flat-length)
|
|||
: flat-length ( word -- n )
|
||||
H{ } clone recursive-calls [
|
||||
[ recursive-calls get conjoin ]
|
||||
[ def>> (flat-length) ]
|
||||
[ def>> (flat-length) 5 /i ]
|
||||
bi
|
||||
] with-variable ;
|
||||
|
||||
|
|
@ -102,7 +103,7 @@ DEFER: (flat-length)
|
|||
[ f splice-quot ] [ 2drop t ] if ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
dup param>> {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup math-partial? ] [ inline-math-partial ] }
|
||||
|
|
@ -155,15 +156,35 @@ DEFER: (flat-length)
|
|||
(optimize-predicate) optimize-check ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
dup node-param "flushable" word-prop
|
||||
[ node-out-d [ unused? ] all? ] [ drop f ] if ;
|
||||
|
||||
ERROR: flushed-eval-error word ;
|
||||
|
||||
M: flushed-eval-error summary
|
||||
drop "Flushed evaluation of word would have thrown an error" ;
|
||||
|
||||
: flushed-eval-quot ( #call -- quot )
|
||||
#! A quotation to replace flushed evaluations with. We can't
|
||||
#! just remove the code altogether, because if the optimizer
|
||||
#! knows the input types of a word, it assumes the inputs are
|
||||
#! of this type after the word returns, since presumably
|
||||
#! the word would have checked input types itself. However,
|
||||
#! if the word gets flushed, then it won't do this checking;
|
||||
#! so we have to do it here.
|
||||
[
|
||||
dup param>> "input-classes" word-prop [
|
||||
make-specializer %
|
||||
[ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
|
||||
\ unless ,
|
||||
] when*
|
||||
dup in-d>> length [ \ drop , ] times
|
||||
out-d>> length [ f , ] times
|
||||
] [ ] make ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
dup param>> +inlined+ depends-on
|
||||
dup flushed-eval-quot f splice-quot ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
|
|
@ -195,13 +216,28 @@ DEFER: (flat-length)
|
|||
[ drop +inlined+ depends-on ] [ swap 1array ] 2bi
|
||||
splice-quot ;
|
||||
|
||||
: classes-known? ( #call -- ? )
|
||||
node-input-classes [
|
||||
[ class-types length 1 = ]
|
||||
[ union-class? not ]
|
||||
bi and
|
||||
] contains? ;
|
||||
|
||||
: inlining-rank ( #call -- n )
|
||||
{
|
||||
[ param>> flat-length 24 swap [-] 4 /i ]
|
||||
[ param>> "default" word-prop -4 0 ? ]
|
||||
[ param>> "specializer" word-prop 1 0 ? ]
|
||||
[ param>> method-body? 1 0 ? ]
|
||||
[ classes-known? 2 0 ? ]
|
||||
} cleave + + + + ;
|
||||
|
||||
: should-inline? ( #call -- ? )
|
||||
inlining-rank 5 >= ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ class-types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
dup param>> "specializer" word-prop
|
||||
[ should-inline? ] [ drop f ] if ;
|
||||
|
||||
: already-inlined? ( #call -- ? )
|
||||
[ param>> ] [ history>> ] bi memq? ;
|
||||
|
|
@ -211,11 +247,8 @@ DEFER: (flat-length)
|
|||
dup param>> dup def>> splice-word-def
|
||||
] if ;
|
||||
|
||||
: should-inline? ( word -- ? )
|
||||
flat-length 11 <= ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
param>> dup [ method-body? ] [ "default" word-prop not ] bi and
|
||||
dup param>> method-body?
|
||||
[ should-inline? ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien arrays generic hashtables definitions
|
||||
inference.dataflow inference.state inference.class kernel assocs
|
||||
math math.order math.private kernel.private sequences words
|
||||
parser vectors strings sbufs io namespaces assocs quotations
|
||||
sequences.private io.binary io.streams.string layouts splitting
|
||||
math.intervals math.floats.private classes.tuple classes.predicate
|
||||
classes.tuple.private classes classes.algebra optimizer.def-use
|
||||
optimizer.backend optimizer.pattern-match optimizer.inlining
|
||||
sequences.private combinators byte-arrays byte-vectors
|
||||
slots.private ;
|
||||
kernel assocs math math.order math.private kernel.private
|
||||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations sequences.private io.binary io.streams.string
|
||||
layouts splitting math.intervals math.floats.private
|
||||
classes.tuple classes.predicate classes.tuple.private classes
|
||||
classes.algebra sequences.private combinators byte-arrays
|
||||
byte-vectors slots.private inference.dataflow inference.state
|
||||
inference.class optimizer.def-use optimizer.backend
|
||||
optimizer.pattern-match optimizer.inlining ;
|
||||
IN: optimizer.known-words
|
||||
|
||||
{ <tuple> <tuple-boa> (tuple) } [
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: effects alien alien.accessors arrays generic hashtables
|
||||
kernel assocs math math.libm math.private kernel.private
|
||||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations math.intervals sequences.private combinators
|
||||
splitting layouts math.parser classes classes.algebra
|
||||
generic.math inference.class inference.dataflow
|
||||
optimizer.pattern-match optimizer.backend optimizer.def-use
|
||||
optimizer.inlining optimizer.math.partial generic.standard
|
||||
system accessors ;
|
||||
IN: optimizer.math
|
||||
USING: alien alien.accessors arrays generic hashtables kernel
|
||||
assocs math math.private kernel.private sequences words parser
|
||||
inference.class inference.dataflow vectors strings sbufs io
|
||||
namespaces assocs quotations math.intervals sequences.private
|
||||
combinators splitting layouts math.parser classes
|
||||
classes.algebra generic.math optimizer.pattern-match
|
||||
optimizer.backend optimizer.def-use optimizer.inlining
|
||||
optimizer.math.partial generic.standard system accessors ;
|
||||
|
||||
: define-math-identities ( word identities -- )
|
||||
>r all-derived-ops r> define-identities ;
|
||||
|
|
@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ;
|
|||
] 2curry each-derived-op
|
||||
] each
|
||||
|
||||
: math-output-class/interval-2-fast ( node word -- classes intervals )
|
||||
math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
|
||||
|
||||
[
|
||||
{ + interval+ }
|
||||
{ - interval- }
|
||||
{ * interval* }
|
||||
{ shift interval-shift-safe }
|
||||
] [
|
||||
first2 [
|
||||
[
|
||||
math-output-class/interval-2-fast
|
||||
] curry "output-classes" set-word-prop
|
||||
] curry each-fast-derived-op
|
||||
] each
|
||||
|
||||
: real-value? ( value -- n ? )
|
||||
dup value? [ value-literal dup real? ] [ drop f f ] if ;
|
||||
|
||||
|
|
@ -420,3 +437,40 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
[ fixnumify-bitand ]
|
||||
}
|
||||
} define-optimizers
|
||||
|
||||
{ + - * / }
|
||||
[ { number number } "input-classes" set-word-prop ] each
|
||||
|
||||
{ /f < > <= >= }
|
||||
[ { real real } "input-classes" set-word-prop ] each
|
||||
|
||||
{ /i mod /mod }
|
||||
[ { rational rational } "input-classes" set-word-prop ] each
|
||||
|
||||
{ bitand bitor bitxor bitnot shift }
|
||||
[ { integer integer } "input-classes" set-word-prop ] each
|
||||
|
||||
{
|
||||
fcosh
|
||||
flog
|
||||
fsinh
|
||||
fexp
|
||||
fasin
|
||||
facosh
|
||||
fasinh
|
||||
ftanh
|
||||
fatanh
|
||||
facos
|
||||
fpow
|
||||
fatan
|
||||
fatan2
|
||||
fcos
|
||||
ftan
|
||||
fsin
|
||||
fsqrt
|
||||
} [
|
||||
dup stack-effect
|
||||
[ in>> length real <repetition> "input-classes" set-word-prop ]
|
||||
[ out>> length float <repetition> "default-output-classes" set-word-prop ]
|
||||
2bi
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -170,3 +170,6 @@ SYMBOL: fast-math-ops
|
|||
|
||||
: each-derived-op ( word quot -- )
|
||||
>r derived-ops r> each ; inline
|
||||
|
||||
: each-fast-derived-op ( word quot -- )
|
||||
>r fast-derived-ops r> each ; inline
|
||||
|
|
|
|||
|
|
@ -375,3 +375,12 @@ PREDICATE: list < improper-list
|
|||
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
||||
[ 1 4 ] [ 1 interval-inference-bug ] unit-test
|
||||
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
|
||||
|
||||
: aggressive-flush-regression ( a -- b )
|
||||
f over >r <array> drop r> 1 + ;
|
||||
|
||||
[ 1.0 aggressive-flush-regression drop ] must-fail
|
||||
|
||||
[ 1 [ "hi" + drop ] compile-call ] must-fail
|
||||
|
||||
[ "hi" f [ <array> drop ] compile-call ] must-fail
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces generic
|
||||
combinators classes classes.algebra
|
||||
inference inference.dataflow ;
|
||||
IN: optimizer.pattern-match
|
||||
USING: kernel sequences inference namespaces generic
|
||||
combinators classes classes.algebra inference.dataflow ;
|
||||
|
||||
! Funny pattern matching
|
||||
SYMBOL: @
|
||||
|
|
|
|||
|
|
@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
|
|||
M: sequence like drop ;
|
||||
|
||||
GENERIC: lengthen ( n seq -- )
|
||||
GENERIC: shorten ( n seq -- )
|
||||
|
||||
M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
|
||||
|
||||
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
|
||||
|
||||
: empty? ( seq -- ? ) length zero? ; inline
|
||||
: delete-all ( seq -- ) 0 swap set-length ;
|
||||
|
||||
|
|
@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
|
||||
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
|
||||
|
||||
: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
|
||||
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
|
||||
|
||||
: move-backward ( shift from to seq -- )
|
||||
2over number= [
|
||||
|
|
@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
copy ;
|
||||
|
||||
: pop ( seq -- elt )
|
||||
[ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
|
||||
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
|
||||
|
||||
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -38,6 +38,18 @@ HELP: adjoin
|
|||
}
|
||||
{ $side-effects "seq" } ;
|
||||
|
||||
HELP: conjoin
|
||||
{ $values { "elt" object } { "assoc" "an assoc" } }
|
||||
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel prettyprint sets ;"
|
||||
"H{ } clone 1 over conjoin ."
|
||||
"H{ { 1 1 } }"
|
||||
}
|
||||
}
|
||||
{ $side-effects "assoc" } ;
|
||||
|
||||
HELP: unique
|
||||
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
|
||||
{ $description "Outputs a new assoc where the keys and values are equal." }
|
||||
|
|
|
|||
|
|
@ -77,6 +77,7 @@ $nl
|
|||
"All other classes are handled with one of two cases:"
|
||||
{ $list
|
||||
{ "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." }
|
||||
{ "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." }
|
||||
{ "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." }
|
||||
}
|
||||
"A word can be used to check if a class has an initial value or not:"
|
||||
|
|
|
|||
|
|
@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ;
|
|||
|
||||
ERROR: no-initial-value class ;
|
||||
|
||||
GENERIC: initial-value* ( class -- object )
|
||||
|
||||
M: class initial-value* no-initial-value ;
|
||||
|
||||
: initial-value ( class -- object )
|
||||
{
|
||||
{ [ \ f bootstrap-word over class<= ] [ f ] }
|
||||
|
|
@ -134,7 +138,7 @@ ERROR: no-initial-value class ;
|
|||
{ [ array bootstrap-word over class<= ] [ { } ] }
|
||||
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
|
||||
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
|
||||
[ no-initial-value ]
|
||||
[ dup initial-value* ]
|
||||
} cond nip ;
|
||||
|
||||
GENERIC: make-slot ( desc -- slot-spec )
|
||||
|
|
|
|||
|
|
@ -1,13 +1,8 @@
|
|||
USING: arrays assocs kernel vectors sequences namespaces
|
||||
random math.parser math fry ;
|
||||
random math.parser math fry ;
|
||||
|
||||
IN: assocs.lib
|
||||
|
||||
: ref-at ( table key -- value ) swap at ;
|
||||
|
||||
: put-at* ( table key value -- ) swap rot set-at ;
|
||||
|
||||
: put-at ( table key value -- table ) swap pick set-at ;
|
||||
|
||||
: set-assoc-stack ( value key seq -- )
|
||||
dupd [ key? ] with find-last nip set-at ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel math math.parser random arrays hashtables assocs sequences
|
||||
vars ;
|
||||
grouping vars ;
|
||||
|
||||
IN: automata
|
||||
|
||||
|
|
@ -32,18 +32,6 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
|||
! step-wrapped-line
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: map3-i ( seq -- i ) length 2 - ;
|
||||
|
||||
: map3-quot ( seq quot -- quot ) >r [ 3nth ] curry r> compose ; inline
|
||||
|
||||
: map3 ( seq quot -- seq ) >r dup map3-i swap r> map3-quot map ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
|
||||
|
||||
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
|
||||
|
|
@ -51,10 +39,9 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
|
|||
: wrap-line ( a-line-z -- za-line-za )
|
||||
dup peek 1array swap dup first 1array append append ;
|
||||
|
||||
: step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
|
||||
|
||||
: step-capped-line ( line -- new-line ) cap-line step-line ;
|
||||
: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
|
||||
|
||||
: step-capped-line ( line -- new-line ) cap-line step-line ;
|
||||
: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -14,13 +14,22 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gadgets.theme
|
||||
accessors
|
||||
qualified
|
||||
namespaces.lib assocs.lib vars
|
||||
rewrite-closures automata ;
|
||||
rewrite-closures automata math.geometry.rect newfx ;
|
||||
|
||||
IN: automata.ui
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
QUALIFIED: ui.gadgets.grids
|
||||
|
||||
: grid-add ( grid child i j -- grid )
|
||||
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
|
||||
|
||||
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
|
||||
|
|
@ -57,29 +66,40 @@ slate> relayout-1 ;
|
|||
|
||||
DEFER: automata-window
|
||||
|
||||
: automata-window* ( -- ) init-rule set-interesting <frame>
|
||||
: automata-window* ( -- )
|
||||
init-rule
|
||||
set-interesting
|
||||
|
||||
{
|
||||
[ "1 - Center" [ start-center ] view-button ]
|
||||
[ "2 - Random" [ start-random ] view-button ]
|
||||
[ "3 - Continue" [ run-rule ] view-button ]
|
||||
[ "5 - Random Rule" [ random-rule ] view-button ]
|
||||
[ "n - New" [ automata-window ] view-button ]
|
||||
} make*
|
||||
[ [ gadget, ] curry ] map concat ! Hack
|
||||
make-shelf over @top grid-add
|
||||
<frame>
|
||||
|
||||
[ display ] closed-quot <slate> { 400 400 } over set-slate-dim dup >slate
|
||||
over @center grid-add
|
||||
<shelf>
|
||||
|
||||
{
|
||||
{ T{ key-down f f "1" } [ [ start-center ] view-action ] }
|
||||
{ T{ key-down f f "2" } [ [ start-random ] view-action ] }
|
||||
{ T{ key-down f f "3" } [ [ run-rule ] view-action ] }
|
||||
{ T{ key-down f f "5" } [ [ random-rule ] view-action ] }
|
||||
{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
|
||||
} [ make* ] map >hashtable <handler> tuck set-gadget-delegate
|
||||
"Automata" open-window ;
|
||||
"1 - Center" [ start-center ] view-button add-gadget
|
||||
"2 - Random" [ start-random ] view-button add-gadget
|
||||
"3 - Continue" [ run-rule ] view-button add-gadget
|
||||
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
||||
"n - New" [ automata-window ] view-button add-gadget
|
||||
|
||||
@top grid-add
|
||||
|
||||
C[ display ] <slate>
|
||||
{ 400 400 } >>dim
|
||||
dup >slate
|
||||
|
||||
@center grid-add
|
||||
|
||||
H{ }
|
||||
T{ key-down f f "1" } [ start-center ] view-action is
|
||||
T{ key-down f f "2" } [ start-random ] view-action is
|
||||
T{ key-down f f "3" } [ run-rule ] view-action is
|
||||
T{ key-down f f "5" } [ random-rule ] view-action is
|
||||
T{ key-down f f "n" } [ automata-window ] view-action is
|
||||
|
||||
<handler>
|
||||
|
||||
tuck set-gadget-delegate
|
||||
|
||||
"Automata" open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,19 @@
|
|||
USING: kernel sequences math math.functions vectors ;
|
||||
IN: benchmark.stack
|
||||
|
||||
: stack-loop ( vec -- )
|
||||
1000 [
|
||||
10000 [
|
||||
dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if
|
||||
pick push
|
||||
over push
|
||||
] times
|
||||
10000 [ dup pop* ] times
|
||||
] times
|
||||
drop ;
|
||||
|
||||
: stack-benchmark ( -- )
|
||||
V{ 123456 } clone stack-loop
|
||||
20000 <vector> 123456 over set-first stack-loop ;
|
||||
|
||||
MAIN: stack-benchmark
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
IN: biassocs
|
||||
USING: help.markup help.syntax assocs kernel ;
|
||||
|
||||
HELP: biassoc
|
||||
{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ;
|
||||
|
||||
HELP: <biassoc>
|
||||
{ $values { "exemplar" assoc } { "biassoc" biassoc } }
|
||||
{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ;
|
||||
|
||||
HELP: <bihash>
|
||||
{ $values { "biassoc" biassoc } }
|
||||
{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ;
|
||||
|
||||
HELP: once-at
|
||||
{ $values { "value" object } { "key" object } { "assoc" assoc } }
|
||||
{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
|
||||
|
||||
ARTICLE: "biassocs" "Bidirectional assocs"
|
||||
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
|
||||
$nl
|
||||
"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
|
||||
{ $subsection biassoc }
|
||||
{ $subsection biassoc? }
|
||||
{ $subsection <biassoc> }
|
||||
{ $subsection <bihash> } ;
|
||||
|
||||
ABOUT: "biassocs"
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
IN: biassocs.tests
|
||||
USING: biassocs assocs namespaces tools.test ;
|
||||
|
||||
<bihash> "h" set
|
||||
|
||||
[ 0 ] [ "h" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ 1 2 "h" get set-at ] unit-test
|
||||
|
||||
[ 1 ] [ 2 "h" get at ] unit-test
|
||||
|
||||
[ 2 ] [ 1 "h" get value-at ] unit-test
|
||||
|
||||
[ 1 ] [ "h" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ 1 3 "h" get set-at ] unit-test
|
||||
|
||||
[ 1 ] [ 3 "h" get at ] unit-test
|
||||
|
||||
[ 2 ] [ 1 "h" get value-at ] unit-test
|
||||
|
||||
[ 2 ] [ "h" get assoc-size ] unit-test
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs accessors ;
|
||||
IN: biassocs
|
||||
|
||||
TUPLE: biassoc from to ;
|
||||
|
||||
: <biassoc> ( exemplar -- biassoc )
|
||||
[ clone ] [ clone ] bi biassoc boa ;
|
||||
|
||||
: <bihash> ( -- biassoc )
|
||||
H{ } <biassoc> ;
|
||||
|
||||
M: biassoc assoc-size from>> assoc-size ;
|
||||
|
||||
M: biassoc at* from>> at* ;
|
||||
|
||||
M: biassoc value-at* to>> at* ;
|
||||
|
||||
: once-at ( value key assoc -- )
|
||||
2dup key? [ 3drop ] [ set-at ] if ;
|
||||
|
||||
M: biassoc set-at
|
||||
[ from>> set-at ] [ swapd to>> once-at ] 3bi ;
|
||||
|
||||
M: biassoc delete-at
|
||||
"biassocs do not support deletion" throw ;
|
||||
|
||||
M: biassoc >alist
|
||||
from>> >alist ;
|
||||
|
||||
M: biassoc clear-assoc
|
||||
[ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
|
||||
|
||||
INSTANCE: biassoc assoc
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bidirectional assocs
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
n zero? [ 0 <bit-array> ] [
|
||||
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
|
||||
[ n' zero? not ] [
|
||||
n' out underlying>> i 255 bitand set-alien-unsigned-1
|
||||
n' out underlying>> i set-alien-unsigned-1
|
||||
n' -8 shift n'!
|
||||
i 1+ i!
|
||||
] [ ] while
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
collections
|
||||
extensions
|
||||
|
|
|
|||
|
|
@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces
|
|||
math.order
|
||||
math.vectors
|
||||
math.trig
|
||||
math.physics.pos
|
||||
math.physics.vel
|
||||
combinators arrays sequences random vars
|
||||
combinators.lib ;
|
||||
combinators.lib
|
||||
accessors ;
|
||||
|
||||
IN: boids
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: boid pos vel ;
|
||||
TUPLE: boid < vel ;
|
||||
|
||||
C: <boid> boid
|
||||
|
||||
|
|
@ -70,10 +73,6 @@ VAR: separation-radius
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: constrain ( n a b -- n ) rot min max ;
|
||||
|
||||
: angle-between ( vec vec -- angle )
|
||||
|
|
@ -81,10 +80,10 @@ VAR: separation-radius
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
|
||||
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
|
||||
|
||||
: relative-angle ( self other -- angle )
|
||||
over boid-vel -rot relative-position angle-between ;
|
||||
over vel>> -rot relative-position angle-between ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -92,9 +91,9 @@ over boid-vel -rot relative-position angle-between ;
|
|||
|
||||
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
|
||||
|
||||
: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
|
||||
: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
|
||||
|
||||
: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
|
||||
: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -123,7 +122,7 @@ over boid-vel -rot relative-position angle-between ;
|
|||
dup cohesion-neighborhood
|
||||
dup empty?
|
||||
[ 2drop { 0 0 } ]
|
||||
[ average-position swap boid-pos v- normalize* cohesion-weight> v*n ]
|
||||
[ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -143,7 +142,7 @@ over boid-vel -rot relative-position angle-between ;
|
|||
dup separation-neighborhood
|
||||
dup empty?
|
||||
[ 2drop { 0 0 } ]
|
||||
[ average-position swap boid-pos swap v- normalize* separation-weight> v*n ]
|
||||
[ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -206,10 +205,10 @@ cond ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ;
|
||||
: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
|
||||
|
||||
: new-vel ( boid -- vel )
|
||||
[ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
|
||||
[ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
|
||||
|
||||
: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,9 @@ USING: combinators.short-circuit kernel namespaces
|
|||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gestures
|
||||
assocs.lib vars rewrite-closures boids ;
|
||||
assocs.lib vars rewrite-closures boids accessors
|
||||
math.geometry.rect
|
||||
newfx ;
|
||||
|
||||
IN: boids.ui
|
||||
|
||||
|
|
@ -27,9 +29,9 @@ IN: boids.ui
|
|||
! draw-boid
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: point-a ( boid -- a ) boid-pos ;
|
||||
: point-a ( boid -- a ) pos>> ;
|
||||
|
||||
: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ;
|
||||
: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ;
|
||||
|
||||
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;
|
||||
|
||||
|
|
@ -112,52 +114,54 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
<frame>
|
||||
|
||||
<shelf>
|
||||
|
||||
{
|
||||
[ "ESC - Pause" [ drop toggle-loop ] button* ]
|
||||
|
||||
[ "1 - Randomize" [ drop randomize ] button* ]
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
population-label> over add-gadget
|
||||
"3 - Add 10" [ drop add-10-boids ] button* over add-gadget
|
||||
"2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ]
|
||||
population-label> add-gadget
|
||||
"3 - Add 10" [ drop add-10-boids ] button* add-gadget
|
||||
"2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
cohesion-label> over add-gadget
|
||||
"q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget
|
||||
"a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ]
|
||||
cohesion-label> add-gadget
|
||||
"q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
|
||||
"a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
alignment-label> over add-gadget
|
||||
"w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget
|
||||
"s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ]
|
||||
alignment-label> add-gadget
|
||||
"w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
|
||||
"s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
|
||||
|
||||
[ <pile> 1 over set-pack-fill
|
||||
separation-label> over add-gadget
|
||||
"e - +0.1" [ drop inc-separation-weight ] button* over add-gadget
|
||||
"d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ]
|
||||
separation-label> add-gadget
|
||||
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
|
||||
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
|
||||
|
||||
} [ call ] map [ [ gadget, ] each ] make-shelf
|
||||
} [ call ] map [ add-gadget ] each
|
||||
1 over set-pack-fill
|
||||
over @top grid-add
|
||||
|
||||
slate> over @center grid-add
|
||||
|
||||
H{ } clone
|
||||
T{ key-down f f "1" } C[ drop randomize ] put-at
|
||||
T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
|
||||
T{ key-down f f "3" } C[ drop add-10-boids ] put-at
|
||||
T{ key-down f f "1" } C[ drop randomize ] is
|
||||
T{ key-down f f "2" } C[ drop sub-10-boids ] is
|
||||
T{ key-down f f "3" } C[ drop add-10-boids ] is
|
||||
|
||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
|
||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
|
||||
T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
|
||||
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
|
||||
|
||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
|
||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
|
||||
T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
|
||||
T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
|
||||
|
||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
|
||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
|
||||
T{ key-down f f "e" } C[ drop inc-separation-weight ] is
|
||||
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
||||
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
||||
|
||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||
|
|
|
|||
|
|
@ -1,34 +1,25 @@
|
|||
USING: alien alien.c-types arrays sequences math math.vectors
|
||||
math.matrices math.parser io io.files kernel opengl opengl.gl
|
||||
opengl.glu shuffle http.client vectors namespaces ui.gadgets
|
||||
ui.gadgets.canvas ui.render ui splitting combinators
|
||||
system combinators.lib float-arrays continuations
|
||||
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
|
||||
bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
|
||||
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
|
||||
bunny.model bunny.outlined destructors kernel math opengl.demo-support
|
||||
opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
|
||||
IN: bunny
|
||||
|
||||
TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
||||
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
|
||||
|
||||
: <bunny-gadget> ( -- bunny-gadget )
|
||||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model {
|
||||
set-delegate
|
||||
(>>model)
|
||||
} bunny-gadget construct ;
|
||||
0.0 0.0 0.375 bunny-gadget new-demo-gadget
|
||||
maybe-download read-model >>model-triangles ;
|
||||
|
||||
: bunny-gadget-draw ( gadget -- draw )
|
||||
{ draw-n>> draw-seq>> }
|
||||
get-slots nth ;
|
||||
[ draw-n>> ] [ draw-seq>> ] bi nth ;
|
||||
|
||||
: bunny-gadget-next-draw ( gadget -- )
|
||||
dup { draw-seq>> draw-n>> }
|
||||
get-slots
|
||||
dup [ draw-seq>> ] [ draw-n>> ] bi
|
||||
1+ swap length mod
|
||||
>>draw-n relayout-1 ;
|
||||
|
||||
M: bunny-gadget graft* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
dup model>> <bunny-geom> >>geom
|
||||
dup model-triangles>> <bunny-geom> >>geom
|
||||
dup
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
|
|
@ -48,8 +39,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
|
|||
dup demo-gadget-set-matrices
|
||||
GL_MODELVIEW glMatrixMode
|
||||
0.02 -0.105 0.0 glTranslatef
|
||||
{ geom>> bunny-gadget-draw } get-slots
|
||||
draw-bunny
|
||||
[ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
|
||||
] if ;
|
||||
|
||||
M: bunny-gadget pref-dim* ( gadget -- dim )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
USING: alien alien.c-types arrays sequences math math.vectors
|
||||
math.matrices math.parser io io.files kernel opengl opengl.gl
|
||||
opengl.glu io.encodings.ascii opengl.capabilities shuffle
|
||||
http.client vectors splitting system combinators
|
||||
float-arrays continuations destructors namespaces sequences.lib
|
||||
accessors ;
|
||||
USING: accessors alien.c-types arrays combinators destructors http.client
|
||||
io io.encodings.ascii io.files kernel math math.matrices math.parser
|
||||
math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
|
||||
splitting vectors words ;
|
||||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
|
|
@ -66,7 +64,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
|
|||
{
|
||||
[
|
||||
[ first concat ] [ second concat ] bi
|
||||
append >c-double-array
|
||||
append >c-float-array
|
||||
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
|
||||
]
|
||||
[
|
||||
|
|
@ -86,10 +84,10 @@ M: bunny-dlist bunny-geom
|
|||
M: bunny-buffers bunny-geom
|
||||
dup { array>> element-array>> } get-slots [
|
||||
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
|
||||
GL_DOUBLE 0 0 buffer-offset glNormalPointer
|
||||
GL_FLOAT 0 0 buffer-offset glNormalPointer
|
||||
[
|
||||
nv>> "double" heap-size * buffer-offset
|
||||
3 GL_DOUBLE 0 roll glVertexPointer
|
||||
nv>> "float" heap-size * buffer-offset
|
||||
3 GL_FLOAT 0 roll glVertexPointer
|
||||
] [
|
||||
ni>>
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
|
|
|
|||
|
|
@ -181,10 +181,9 @@ TUPLE: bunny-outlined
|
|||
] [ drop ] if ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
|
||||
over =
|
||||
[ 2drop ] [
|
||||
[ dup dispose-framebuffer dup ] dip {
|
||||
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
|
||||
[ drop ] [
|
||||
[ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
|
||||
[
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>color-texture drop ] keep
|
||||
|
|
@ -196,7 +195,8 @@ TUPLE: bunny-outlined
|
|||
[ >>depth-texture drop ] keep
|
||||
]
|
||||
} 2cleave
|
||||
(make-framebuffer) >>framebuffer drop
|
||||
[ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: clear-framebuffer ( -- )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: kernel math math.functions math.parser models
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render ;
|
||||
ui.gadgets.sliders ui.render math.geometry.rect ;
|
||||
IN: color-picker
|
||||
|
||||
! Simple example demonstrating the use of models.
|
||||
|
|
@ -15,7 +15,8 @@ TUPLE: color-preview < gadget ;
|
|||
|
||||
: <color-preview> ( model -- gadget )
|
||||
color-preview new-gadget
|
||||
{ 100 100 } over set-rect-dim ;
|
||||
swap >>model
|
||||
{ 100 100 } >>dim ;
|
||||
|
||||
M: color-preview model-changed
|
||||
swap model-value over set-gadget-interior relayout-1 ;
|
||||
|
|
@ -26,7 +27,10 @@ M: color-preview model-changed
|
|||
: <color-sliders> ( -- model gadget )
|
||||
3 [ 0 0 0 255 <range> ] replicate
|
||||
dup [ range-model ] map <compose>
|
||||
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
|
||||
swap
|
||||
<filled-pile>
|
||||
swap
|
||||
[ <color-slider> add-gadget ] each ;
|
||||
|
||||
: <color-picker> ( -- gadget )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -9,16 +9,8 @@ TUPLE: float-array
|
|||
{ length array-capacity read-only }
|
||||
{ underlying byte-array read-only } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: floats>bytes 8 * ; inline
|
||||
|
||||
: float-array@ underlying>> swap >fixnum floats>bytes ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <float-array> ( n -- float-array )
|
||||
dup floats>bytes <byte-array> float-array boa ; inline
|
||||
dup "double" <c-array> float-array boa ; inline
|
||||
|
||||
M: float-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi float-array boa ;
|
||||
|
|
@ -26,13 +18,13 @@ M: float-array clone
|
|||
M: float-array length length>> ;
|
||||
|
||||
M: float-array nth-unsafe
|
||||
float-array@ alien-double ;
|
||||
underlying>> double-nth ;
|
||||
|
||||
M: float-array set-nth-unsafe
|
||||
[ >float ] 2dip float-array@ set-alien-double ;
|
||||
[ >float ] 2dip underlying>> set-double-nth ;
|
||||
|
||||
: >float-array ( seq -- float-array )
|
||||
T{ float-array f 0 B{ } } clone-like ; inline
|
||||
T{ float-array } clone-like ; inline
|
||||
|
||||
M: float-array like
|
||||
drop dup float-array? [ >float-array ] unless ;
|
||||
|
|
@ -45,7 +37,7 @@ M: float-array equal?
|
|||
|
||||
M: float-array resize
|
||||
[ drop ] [
|
||||
[ floats>bytes ] [ underlying>> ] bi*
|
||||
[ "double" heap-size * ] [ underlying>> ] bi*
|
||||
resize-byte-array
|
||||
] 2bi
|
||||
float-array boa ;
|
||||
|
|
@ -58,13 +50,13 @@ INSTANCE: float-array sequence
|
|||
1 <float-array> [ set-first ] keep ; flushable
|
||||
|
||||
: 2float-array ( x y -- array )
|
||||
T{ float-array f 0 B{ } } 2sequence ; flushable
|
||||
T{ float-array } 2sequence ; flushable
|
||||
|
||||
: 3float-array ( x y z -- array )
|
||||
T{ float-array f 0 B{ } } 3sequence ; flushable
|
||||
T{ float-array } 3sequence ; flushable
|
||||
|
||||
: 4float-array ( w x y z -- array )
|
||||
T{ float-array f 0 B{ } } 4sequence ; flushable
|
||||
T{ float-array } 4sequence ; flushable
|
||||
|
||||
: F{ ( parsed -- parsed )
|
||||
\ } [ >float-array ] parse-literal ; parsing
|
||||
|
|
@ -72,3 +64,20 @@ INSTANCE: float-array sequence
|
|||
M: float-array pprint-delims drop \ F{ \ } ;
|
||||
|
||||
M: float-array >pprint-sequence ;
|
||||
|
||||
USING: hints math.vectors arrays ;
|
||||
|
||||
HINTS: vneg { float-array } { array } ;
|
||||
HINTS: v*n { float-array object } { array object } ;
|
||||
HINTS: v/n { float-array object } { array object } ;
|
||||
HINTS: n/v { object float-array } { object array } ;
|
||||
HINTS: v+ { float-array float-array } { array array } ;
|
||||
HINTS: v- { float-array float-array } { array array } ;
|
||||
HINTS: v* { float-array float-array } { array array } ;
|
||||
HINTS: v/ { float-array float-array } { array array } ;
|
||||
HINTS: vmax { float-array float-array } { array array } ;
|
||||
HINTS: vmin { float-array float-array } { array array } ;
|
||||
HINTS: v. { float-array float-array } { array array } ;
|
||||
HINTS: norm-sq { float-array } { array } ;
|
||||
HINTS: norm { float-array } { array } ;
|
||||
HINTS: normalize { float-array } { array } ;
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@ ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors
|
|||
accessors ;
|
||||
IN: gesture-logger
|
||||
|
||||
TUPLE: gesture-logger stream ;
|
||||
TUPLE: gesture-logger < gadget stream ;
|
||||
|
||||
: <gesture-logger> ( stream -- gadget )
|
||||
\ gesture-logger construct-gadget
|
||||
\ gesture-logger new-gadget
|
||||
swap >>stream
|
||||
{ 100 100 } >>dim
|
||||
black solid-interior ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser words definitions kernel ;
|
||||
IN: hints
|
||||
USING: parser words ;
|
||||
|
||||
: HINTS:
|
||||
scan-word parse-definition "specializer" set-word-prop ;
|
||||
: HINTS:
|
||||
scan-word
|
||||
[ +inlined+ changed-definition ]
|
||||
[ parse-definition "specializer" set-word-prop ] bi ;
|
||||
parsing
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ;
|
|||
[ size>> ] [ fill>> ] bi - ; inline
|
||||
|
||||
: buffer-empty? ( buffer -- ? )
|
||||
fill>> zero? ;
|
||||
fill>> zero? ; inline
|
||||
|
||||
: buffer-consume ( n buffer -- )
|
||||
[ + ] change-pos
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ;
|
|||
: <port> ( handle class -- port )
|
||||
new swap >>handle ; inline
|
||||
|
||||
TUPLE: buffered-port < port buffer ;
|
||||
TUPLE: buffered-port < port { buffer buffer } ;
|
||||
|
||||
: <buffered-port> ( handle class -- port )
|
||||
<port>
|
||||
|
|
@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
|
|||
: wait-to-read ( port -- eof? )
|
||||
dup buffer>> buffer-empty? [
|
||||
dup (wait-to-read) buffer>> buffer-empty?
|
||||
] [ drop f ] if ;
|
||||
] [ drop f ] if ; inline
|
||||
|
||||
M: input-port stream-read1
|
||||
dup check-disposed
|
||||
|
|
@ -140,9 +140,7 @@ M: output-port dispose*
|
|||
] with-destructors ;
|
||||
|
||||
M: buffered-port dispose*
|
||||
[ call-next-method ]
|
||||
[ [ [ dispose ] when* f ] change-buffer drop ]
|
||||
bi ;
|
||||
[ call-next-method ] [ buffer>> dispose ] bi ;
|
||||
|
||||
M: port cancel-operation handle>> cancel-operation ;
|
||||
|
||||
|
|
@ -152,3 +150,13 @@ M: port dispose*
|
|||
[ handle>> shutdown ]
|
||||
bi
|
||||
] with-destructors ;
|
||||
|
||||
! Fast-path optimization
|
||||
USING: hints strings io.encodings.utf8 io.encodings.ascii
|
||||
io.encodings.private ;
|
||||
|
||||
HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
|
||||
|
||||
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
|
||||
|
||||
HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,9 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
|
||||
USING: accessors alarms arrays calendar jamshred.game jamshred.gl
|
||||
jamshred.player jamshred.log kernel math math.constants namespaces
|
||||
sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render math.vectors math.geometry.rect ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
|
||||
|
|
|
|||
|
|
@ -1,3 +1 @@
|
|||
cons
|
||||
lists
|
||||
sequences
|
||||
collections
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ USING: kernel namespaces threads math math.order math.vectors
|
|||
self pos ori turtle opengl.camera
|
||||
lsys.tortoise lsys.tortoise.graphics
|
||||
lsys.strings.rewrite lsys.strings.interpret
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit accessors ;
|
||||
|
||||
! lsys.strings
|
||||
! lsys.strings.rewrite
|
||||
|
|
@ -99,6 +99,8 @@ DEFER: empty-model
|
|||
|
||||
: lsys-controller ( -- )
|
||||
|
||||
<pile>
|
||||
|
||||
{
|
||||
|
||||
[ "Load" <label> reverse-video-theme ]
|
||||
|
|
@ -145,9 +147,11 @@ DEFER: empty-model
|
|||
[ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
|
||||
camera-action <bevel-button> ]
|
||||
|
||||
} make*
|
||||
[ [ gadget, ] curry ] map concat ! Hack
|
||||
make-pile 1 over set-pack-fill "L-system control" open-window ;
|
||||
}
|
||||
|
||||
[ call add-gadget ] each
|
||||
1 >>fill
|
||||
"L-system control" open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -469,7 +473,7 @@ H{ } >rules ;
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: model-chooser ( -- )
|
||||
|
||||
<pile>
|
||||
{
|
||||
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
|
||||
[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
|
||||
|
|
@ -481,18 +485,21 @@ H{ } >rules ;
|
|||
[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
|
||||
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
|
||||
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
|
||||
} make*
|
||||
[ [ gadget, ] curry ] map concat ! Hack
|
||||
make-pile 1 over set-pack-fill "L-system models" open-window ;
|
||||
}
|
||||
[ call add-gadget ] each
|
||||
1 >>fill
|
||||
"L-system models" open-window ;
|
||||
|
||||
: scene-chooser ( -- )
|
||||
<pile>
|
||||
{
|
||||
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
|
||||
[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
|
||||
[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
|
||||
} make*
|
||||
[ [ gadget, ] curry ] map concat ! Hack
|
||||
make-pile 1 over set-pack-fill "L-system scenes" open-window ;
|
||||
}
|
||||
[ call add-gadget ] each
|
||||
1 >>fill
|
||||
"L-system scenes" open-window ;
|
||||
|
||||
: lsys-window* ( -- )
|
||||
[ lsys-controller lsys-viewer ] with-ui ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,54 @@
|
|||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: math.geometry.rect
|
||||
|
||||
HELP: rect
|
||||
{ $class-description "A rectangle with the following slots:"
|
||||
{ $list
|
||||
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
|
||||
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
|
||||
}
|
||||
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
|
||||
} ;
|
||||
|
||||
HELP: <rect> ( loc dim -- rect )
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
|
||||
|
||||
{ <zero-rect> <rect> <extent-rect> } related-words
|
||||
|
||||
HELP: set-rect-dim ( dim rect -- )
|
||||
{ $values { "dim" "a pair of integers" } { "rect" rect } }
|
||||
{ $description "Modifies the dimensions of a rectangle." }
|
||||
{ $side-effects "rect" } ;
|
||||
|
||||
HELP: rect-bounds
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Outputs the location and dimensions of a rectangle." } ;
|
||||
|
||||
{ rect-bounds rect-extent } related-words
|
||||
|
||||
HELP: <extent-rect> ( loc ext -- rect )
|
||||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
|
||||
|
||||
HELP: rect-extent
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
|
||||
|
||||
HELP: offset-rect
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
|
||||
|
||||
HELP: rect-intersect
|
||||
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
|
||||
{ $description "Computes the intersection of two rectangles." } ;
|
||||
|
||||
HELP: intersects?
|
||||
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
|
||||
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
|
||||
|
||||
HELP: <zero-rect>
|
||||
{ $values { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
|
||||
USING: tools.test math.geometry.rect ;
|
||||
|
||||
IN: math.geometry.rect.tests
|
||||
|
||||
[ T{ rect f { 10 10 } { 20 20 } } ]
|
||||
[
|
||||
T{ rect f { 10 10 } { 50 50 } }
|
||||
T{ rect f { -10 -10 } { 40 40 } }
|
||||
rect-intersect
|
||||
] unit-test
|
||||
|
||||
[ T{ rect f { 200 200 } { 0 0 } } ]
|
||||
[
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 200 200 } { 40 40 } }
|
||||
rect-intersect
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 200 200 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 120 120 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ rect f { 1000 100 } { 50 50 } }
|
||||
T{ rect f { 120 120 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
|
||||
USING: kernel arrays math.vectors ;
|
||||
|
||||
IN: math.geometry.rect
|
||||
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ;
|
||||
|
||||
C: <rect> rect
|
||||
|
||||
M: array rect-loc ;
|
||||
|
||||
M: array rect-dim drop { 0 0 } ;
|
||||
|
||||
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
|
||||
|
||||
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
|
||||
|
||||
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
|
||||
[ rect-extent ] bi@ swapd ;
|
||||
|
||||
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
|
||||
|
||||
: offset-rect ( rect loc -- newrect )
|
||||
over rect-loc v+ swap rect-dim <rect> ;
|
||||
|
||||
: (rect-intersect) ( rect rect -- array array )
|
||||
2rect-extent vmin >r vmax r> ;
|
||||
|
||||
: rect-intersect ( rect1 rect2 -- newrect )
|
||||
(rect-intersect) <extent-rect> ;
|
||||
|
||||
: intersects? ( rect/point rect -- ? )
|
||||
(rect-intersect) [v-] { 0 0 } = ;
|
||||
|
||||
: (rect-union) ( rect rect -- array array )
|
||||
2rect-extent vmax >r vmin r> ;
|
||||
|
||||
: rect-union ( rect1 rect2 -- newrect )
|
||||
(rect-union) <extent-rect> ;
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
USING: kernel sequences multi-methods accessors math.vectors ;
|
||||
|
||||
IN: math.physics.pos
|
||||
|
||||
TUPLE: pos pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: distance ( a b -- c )
|
||||
|
||||
METHOD: distance { sequence sequence } v- norm ;
|
||||
|
||||
METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
USING: math.physics.pos ;
|
||||
|
||||
IN: math.physics.vel
|
||||
|
||||
TUPLE: vel < pos vel ;
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! From http://www.ffconsultancy.com/ocaml/maze/index.html
|
||||
USING: sequences namespaces math math.vectors opengl opengl.gl
|
||||
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
|
||||
math.order ;
|
||||
math.order math.geometry.rect ;
|
||||
IN: maze
|
||||
|
||||
: line-width 8 ;
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
|||
ui.gadgets ui.render ;
|
||||
IN: nehe.2
|
||||
|
||||
TUPLE: nehe2-gadget ;
|
||||
TUPLE: nehe2-gadget < gadget ;
|
||||
|
||||
: width 256 ;
|
||||
: height 256 ;
|
||||
|
||||
: <nehe2-gadget> ( -- gadget )
|
||||
nehe2-gadget construct-gadget ;
|
||||
nehe2-gadget new-gadget ;
|
||||
|
||||
M: nehe2-gadget pref-dim* ( gadget -- dim )
|
||||
drop width height 2array ;
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
|||
ui.gadgets ui.render ;
|
||||
IN: nehe.3
|
||||
|
||||
TUPLE: nehe3-gadget ;
|
||||
TUPLE: nehe3-gadget < gadget ;
|
||||
|
||||
: width 256 ;
|
||||
: height 256 ;
|
||||
|
||||
: <nehe3-gadget> ( -- gadget )
|
||||
nehe3-gadget construct-gadget ;
|
||||
nehe3-gadget new-gadget ;
|
||||
|
||||
M: nehe3-gadget pref-dim* ( gadget -- dim )
|
||||
drop width height 2array ;
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
|||
ui.gadgets ui.render threads ;
|
||||
IN: nehe.4
|
||||
|
||||
TUPLE: nehe4-gadget rtri rquad thread quit? ;
|
||||
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
|
||||
|
||||
: width 256 ;
|
||||
: height 256 ;
|
||||
: redraw-interval 10 ;
|
||||
|
||||
: <nehe4-gadget> ( -- gadget )
|
||||
nehe4-gadget construct-gadget
|
||||
nehe4-gadget new-gadget
|
||||
0.0 over set-nehe4-gadget-rtri
|
||||
0.0 over set-nehe4-gadget-rquad ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
|||
ui.gadgets ui.render threads ;
|
||||
IN: nehe.5
|
||||
|
||||
TUPLE: nehe5-gadget rtri rquad thread quit? ;
|
||||
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
|
||||
: width 256 ;
|
||||
: height 256 ;
|
||||
: redraw-interval 10 ;
|
||||
|
||||
: <nehe5-gadget> ( -- gadget )
|
||||
nehe5-gadget construct-gadget
|
||||
nehe5-gadget new-gadget
|
||||
0.0 over set-nehe5-gadget-rtri
|
||||
0.0 over set-nehe5-gadget-rquad ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,12 +4,12 @@ IN: nehe
|
|||
|
||||
: nehe-window ( -- )
|
||||
[
|
||||
[
|
||||
"Nehe 2" [ drop run2 ] <bevel-button> gadget,
|
||||
"Nehe 3" [ drop run3 ] <bevel-button> gadget,
|
||||
"Nehe 4" [ drop run4 ] <bevel-button> gadget,
|
||||
"Nehe 5" [ drop run5 ] <bevel-button> gadget,
|
||||
] make-filled-pile "Nehe examples" open-window
|
||||
<filled-pile>
|
||||
"Nehe 2" [ drop run2 ] <bevel-button> add-gadget
|
||||
"Nehe 3" [ drop run3 ] <bevel-button> add-gadget
|
||||
"Nehe 4" [ drop run4 ] <bevel-button> add-gadget
|
||||
"Nehe 5" [ drop run5 ] <bevel-button> add-gadget
|
||||
"Nehe examples" open-window
|
||||
] with-ui ;
|
||||
|
||||
MAIN: nehe-window
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: opengl.demo-support
|
|||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
TUPLE: demo-gadget yaw pitch distance ;
|
||||
TUPLE: demo-gadget < gadget yaw pitch distance ;
|
||||
|
||||
: <demo-gadget> ( yaw pitch distance -- gadget )
|
||||
demo-gadget construct-gadget
|
||||
: new-demo-gadget ( yaw pitch distance class -- gadget )
|
||||
new-gadget
|
||||
swap >>distance
|
||||
swap >>pitch
|
||||
swap >>yaw ;
|
||||
|
|
@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz )
|
|||
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
|
||||
|
||||
: yaw-demo-gadget ( yaw gadget -- )
|
||||
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
|
||||
[ + ] with change-yaw relayout-1 ;
|
||||
|
||||
: pitch-demo-gadget ( pitch gadget -- )
|
||||
[ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ;
|
||||
[ + ] with change-pitch relayout-1 ;
|
||||
|
||||
: zoom-demo-gadget ( distance gadget -- )
|
||||
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
|
||||
[ + ] with change-distance relayout-1 ;
|
||||
|
||||
M: demo-gadget pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
dup neg swap ;
|
||||
[ neg ] keep ;
|
||||
|
||||
: demo-gadget-frustum ( gadget -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes inference inference.dataflow io kernel
|
||||
kernel.private math.parser namespaces optimizer prettyprint
|
||||
prettyprint.backend sequences words arrays match macros
|
||||
assocs sequences.private optimizer.specializers generic
|
||||
combinators sorting math quotations accessors ;
|
||||
USING: classes io kernel kernel.private math.parser namespaces
|
||||
optimizer prettyprint prettyprint.backend sequences words arrays
|
||||
match macros assocs sequences.private generic combinators
|
||||
sorting math quotations accessors inference inference.dataflow
|
||||
optimizer.specializers ;
|
||||
IN: optimizer.debugger
|
||||
|
||||
! A simple tool for turning dataflow IR into quotations, for
|
||||
|
|
@ -47,24 +47,28 @@ MATCH-VARS: ?a ?b ?c ;
|
|||
|
||||
: pretty-shuffle ( in out -- word/f )
|
||||
2array {
|
||||
{ { { ?a } { } } drop }
|
||||
{ { { ?a ?b } { } } 2drop }
|
||||
{ { { ?a ?b ?c } { } } 3drop }
|
||||
{ { { ?a } { ?a ?a } } dup }
|
||||
{ { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
|
||||
{ { { ?a ?b } { ?a ?b ?a } } over }
|
||||
{ { { ?b ?a } { ?a ?b } } swap }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
|
||||
{ { { ?a ?b ?c } { ?c ?a ?b } } -rot }
|
||||
{ { { ?a ?b ?c } { ?b ?c ?a } } rot }
|
||||
{ { { ?a ?b } { ?b } } nip }
|
||||
{ { { ?a } { ?a } } [ ] }
|
||||
{ { { ?a ?b } { ?a ?b } } [ ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
|
||||
{ { { ?a } { } } [ drop ] }
|
||||
{ { { ?a ?b } { } } [ 2drop ] }
|
||||
{ { { ?a ?b ?c } { } } [ 3drop ] }
|
||||
{ { { ?a } { ?a ?a } } [ dup ] }
|
||||
{ { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
|
||||
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
|
||||
{ { { ?b ?a } { ?a ?b } } [ swap ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
|
||||
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
|
||||
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
|
||||
{ { { ?a ?b } { ?b } } [ nip ] }
|
||||
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
|
||||
{ _ f }
|
||||
} match-choose ;
|
||||
|
||||
M: #shuffle node>quot
|
||||
dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
|
||||
[ , ] [ >r drop t r> ] if*
|
||||
[ % ] [ >r drop t r> ] if*
|
||||
dup effect-str "#shuffle: " prepend comment, ;
|
||||
|
||||
: pushed-literals ( node -- seq )
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays
|
|||
combinators.cleave
|
||||
rewrite-closures fry accessors newfx
|
||||
processing.color
|
||||
processing.gadget ;
|
||||
processing.gadget math.geometry.rect ;
|
||||
|
||||
IN: processing
|
||||
|
||||
|
|
|
|||
|
|
@ -99,14 +99,13 @@ main()
|
|||
}
|
||||
;
|
||||
|
||||
TUPLE: spheres-gadget
|
||||
TUPLE: spheres-gadget < demo-gadget
|
||||
plane-program solid-sphere-program texture-sphere-program
|
||||
reflection-framebuffer reflection-depthbuffer
|
||||
reflection-texture ;
|
||||
|
||||
: <spheres-gadget> ( -- gadget )
|
||||
20.0 10.0 20.0 <demo-gadget>
|
||||
{ set-delegate } spheres-gadget construct ;
|
||||
20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
|
||||
|
||||
M: spheres-gadget near-plane ( gadget -- z )
|
||||
drop 1.0 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel combinators sequences arrays math math.vectors
|
||||
generalizations vars ;
|
||||
generalizations vars accessors math.physics.vel ;
|
||||
|
||||
IN: springies
|
||||
|
||||
|
|
@ -28,27 +28,27 @@ VAR: gravity
|
|||
! node
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: node mass elas pos vel force ;
|
||||
TUPLE: node < vel mass elas force ;
|
||||
|
||||
C: <node> node
|
||||
|
||||
: >>pos ( node pos -- node ) over set-node-pos ;
|
||||
: node-vel ( node -- vel ) vel>> ;
|
||||
|
||||
: >>vel ( node vel -- node ) over set-node-vel ;
|
||||
: set-node-vel ( vel node -- ) swap >>vel drop ;
|
||||
|
||||
: pos-x ( node -- x ) node-pos first ;
|
||||
: pos-y ( node -- y ) node-pos second ;
|
||||
: vel-x ( node -- y ) node-vel first ;
|
||||
: vel-y ( node -- y ) node-vel second ;
|
||||
: pos-x ( node -- x ) pos>> first ;
|
||||
: pos-y ( node -- y ) pos>> second ;
|
||||
: vel-x ( node -- y ) vel>> first ;
|
||||
: vel-y ( node -- y ) vel>> second ;
|
||||
|
||||
: >>pos-x ( node x -- node ) over node-pos set-first ;
|
||||
: >>pos-y ( node y -- node ) over node-pos set-second ;
|
||||
: >>vel-x ( node x -- node ) over node-vel set-first ;
|
||||
: >>vel-y ( node y -- node ) over node-vel set-second ;
|
||||
: >>pos-x ( node x -- node ) over pos>> set-first ;
|
||||
: >>pos-y ( node y -- node ) over pos>> set-second ;
|
||||
: >>vel-x ( node x -- node ) over vel>> set-first ;
|
||||
: >>vel-y ( node y -- node ) over vel>> set-second ;
|
||||
|
||||
: apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
|
||||
: apply-force ( node vec -- ) over force>> v+ >>force drop ;
|
||||
|
||||
: reset-force ( node -- ) 0 0 2array swap set-node-force ;
|
||||
: reset-force ( node -- node ) 0 0 2array >>force ;
|
||||
|
||||
: node-id ( id -- node ) 1- nodes> nth ;
|
||||
|
||||
|
|
@ -61,12 +61,12 @@ TUPLE: spring rest-length k damp node-a node-b ;
|
|||
C: <spring> spring
|
||||
|
||||
: end-points ( spring -- b-pos a-pos )
|
||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ;
|
||||
[ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
|
||||
|
||||
: spring-length ( spring -- length ) end-points v- norm ;
|
||||
|
||||
: stretch-length ( spring -- length )
|
||||
[ spring-length ] [ spring-rest-length ] bi - ;
|
||||
[ spring-length ] [ rest-length>> ] bi - ;
|
||||
|
||||
: dir ( spring -- vec ) end-points v- normalize ;
|
||||
|
||||
|
|
@ -81,14 +81,14 @@ C: <spring> spring
|
|||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ;
|
||||
: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
|
||||
|
||||
: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
|
||||
|
||||
: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
|
||||
|
||||
: act-on-nodes-hooke ( spring -- )
|
||||
[ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd
|
||||
[ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
|
||||
apply-force
|
||||
apply-force ;
|
||||
|
||||
|
|
@ -112,37 +112,37 @@ C: <spring> spring
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-velocity-a ( spring -- vel )
|
||||
[ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ;
|
||||
[ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
|
||||
|
||||
: unit-vec-b->a ( spring -- vec )
|
||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ;
|
||||
[ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
|
||||
|
||||
: relative-velocity-along-spring-a ( spring -- vel )
|
||||
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
|
||||
|
||||
: damping-force-a ( spring -- vec )
|
||||
[ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ;
|
||||
[ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-velocity-b ( spring -- vel )
|
||||
[ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ;
|
||||
[ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
|
||||
|
||||
: unit-vec-a->b ( spring -- vec )
|
||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ;
|
||||
[ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
|
||||
|
||||
: relative-velocity-along-spring-b ( spring -- vel )
|
||||
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
|
||||
|
||||
: damping-force-b ( spring -- vec )
|
||||
[ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ;
|
||||
[ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: act-on-nodes-damping ( spring -- )
|
||||
dup
|
||||
[ spring-node-a ] [ damping-force-a ] bi apply-force
|
||||
[ spring-node-b ] [ damping-force-b ] bi apply-force ;
|
||||
[ node-a>> ] [ damping-force-a ] bi apply-force
|
||||
[ node-b>> ] [ damping-force-b ] bi apply-force ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -158,22 +158,22 @@ C: <spring> spring
|
|||
|
||||
: bounce-top ( node -- )
|
||||
world-height 1- >>pos-y
|
||||
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
|
||||
dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
|
||||
drop ;
|
||||
|
||||
: bounce-bottom ( node -- )
|
||||
0 >>pos-y
|
||||
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
|
||||
dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
|
||||
drop ;
|
||||
|
||||
: bounce-left ( node -- )
|
||||
0 >>pos-x
|
||||
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
|
||||
dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
|
||||
drop ;
|
||||
|
||||
: bounce-right ( node -- )
|
||||
world-width 1- >>pos-x
|
||||
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
|
||||
dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -207,17 +207,17 @@ C: <spring> spring
|
|||
|
||||
! F = ma
|
||||
|
||||
: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
|
||||
: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
|
||||
|
||||
: new-vel ( node -- vel )
|
||||
[ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ;
|
||||
[ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
|
||||
|
||||
: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ;
|
||||
: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
|
||||
|
||||
: iterate-node ( node -- )
|
||||
dup new-pos >>pos
|
||||
dup new-vel >>vel
|
||||
dup reset-force
|
||||
reset-force
|
||||
handle-bounce ;
|
||||
|
||||
: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
|
||||
|
|
@ -231,16 +231,21 @@ C: <spring> spring
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mass ( id x y x-vel y-vel mass elas -- )
|
||||
7 nrot drop
|
||||
6 nrot 6 nrot 2array
|
||||
5 nrot 5 nrot 2array
|
||||
0 0 2array <node>
|
||||
nodes> swap suffix >nodes ;
|
||||
node new
|
||||
swap >>elas
|
||||
swap >>mass
|
||||
-rot 2array >>vel
|
||||
-rot 2array >>pos
|
||||
0 0 2array >>force
|
||||
nodes> swap suffix >nodes
|
||||
drop ;
|
||||
|
||||
: spng ( id id-a id-b k damp rest-length -- )
|
||||
6 nrot drop
|
||||
-rot
|
||||
5 nrot node-id
|
||||
5 nrot node-id
|
||||
<spring>
|
||||
springs> swap suffix >springs ;
|
||||
spring new
|
||||
swap >>rest-length
|
||||
swap >>damp
|
||||
swap >>k
|
||||
swap node-id >>node-b
|
||||
swap node-id >>node-a
|
||||
springs> swap suffix >springs
|
||||
drop ;
|
||||
|
|
@ -1,16 +1,16 @@
|
|||
|
||||
USING: kernel namespaces threads sequences math math.vectors
|
||||
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
|
||||
fry rewrite-closures vars springies ;
|
||||
fry rewrite-closures vars springies accessors math.geometry.rect ;
|
||||
|
||||
IN: springies.ui
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
||||
: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
||||
|
||||
: draw-spring ( spring -- )
|
||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ;
|
||||
[ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ;
|
||||
|
||||
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
|
||||
ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
|
||||
tetris.game tetris.gl sequences system math math.parser namespaces ;
|
||||
tetris.game tetris.gl sequences system math math.parser namespaces
|
||||
math.geometry.rect ;
|
||||
IN: tetris
|
||||
|
||||
TUPLE: tetris-gadget tetris alarm ;
|
||||
|
|
|
|||
|
|
@ -101,6 +101,7 @@ IN: tools.deploy.shaker
|
|||
"if-intrinsics"
|
||||
"infer"
|
||||
"inferred-effect"
|
||||
"input-classes"
|
||||
"interval"
|
||||
"intrinsics"
|
||||
"loc"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
|
|||
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
||||
cocoa.windows cocoa.classes cocoa.application sequences system
|
||||
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||
ui.cocoa.views core-foundation threads ;
|
||||
ui.cocoa.views core-foundation threads math.geometry.rect ;
|
||||
IN: ui.cocoa
|
||||
|
||||
TUPLE: handle view window ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel
|
|||
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
|
||||
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
|
||||
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
|
||||
core-foundation threads combinators ;
|
||||
core-foundation threads combinators math.geometry.rect ;
|
||||
IN: ui.cocoa.views
|
||||
|
||||
: send-mouse-moved ( view event -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences models ui.gadgets ;
|
||||
USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
|
||||
IN: ui.gadgets.books
|
||||
|
||||
TUPLE: book < gadget ;
|
||||
|
|
@ -19,7 +19,7 @@ M: book model-changed
|
|||
: new-book ( pages model class -- book )
|
||||
new-gadget
|
||||
swap >>model
|
||||
[ add-gadgets ] keep ; inline
|
||||
[ swap add-gadgets drop ] keep ; inline
|
||||
|
||||
: <book> ( pages model -- book )
|
||||
book new-book ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: ui.gadgets.borders.tests
|
||||
USING: tools.test accessors namespaces kernel
|
||||
ui.gadgets ui.gadgets.borders ;
|
||||
ui.gadgets ui.gadgets.borders math.geometry.rect ;
|
||||
|
||||
[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays ui.gadgets kernel math
|
||||
namespaces vectors sequences math.vectors ;
|
||||
namespaces vectors sequences math.vectors math.geometry.rect ;
|
||||
IN: ui.gadgets.borders
|
||||
|
||||
TUPLE: border < gadget
|
||||
|
|
@ -10,7 +10,7 @@ TUPLE: border < gadget
|
|||
{ align initial: { 1/2 1/2 } } ;
|
||||
|
||||
: new-border ( child class -- border )
|
||||
new-gadget [ add-gadget ] keep ; inline
|
||||
new-gadget [ swap add-gadget drop ] keep ; inline
|
||||
|
||||
: <border> ( child gap -- border )
|
||||
swap border new-border
|
||||
|
|
@ -33,7 +33,8 @@ M: border pref-dim*
|
|||
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
|
||||
|
||||
: border-loc ( border dim -- loc )
|
||||
[ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
|
||||
[ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
|
||||
v- v* v+ [ >fixnum ] map ;
|
||||
|
||||
: border-child-rect ( border -- rect )
|
||||
dup border-dim [ border-loc ] keep <rect> ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math models namespaces sequences
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl math.vectors
|
||||
ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render ;
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl math.vectors
|
||||
ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button < border pressed? selected? quot ;
|
||||
|
|
@ -187,9 +188,9 @@ M: radio-control model-changed
|
|||
over set-button-selected?
|
||||
relayout-1 ;
|
||||
|
||||
: <radio-controls> ( model assoc quot -- )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
|
||||
: <radio-controls> ( parent model assoc quot -- parent )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
|
||||
|
||||
: radio-button-theme ( gadget -- gadget )
|
||||
{ 5 5 } >>gap
|
||||
|
|
@ -202,14 +203,18 @@ M: radio-control model-changed
|
|||
{ 5 5 } >>gap drop ;
|
||||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
|
||||
dup radio-buttons-theme ;
|
||||
<filled-pile>
|
||||
-rot
|
||||
[ <radio-button> ] <radio-controls>
|
||||
dup radio-buttons-theme ;
|
||||
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
<radio-control> bevel-button-theme ;
|
||||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
[ [ <toggle-button> ] <radio-controls> ] make-shelf ;
|
||||
<shelf>
|
||||
-rot
|
||||
[ <toggle-button> ] <radio-controls> ;
|
||||
|
||||
: command-button-quot ( target command -- quot )
|
||||
[ invoke-command drop ] 2curry ;
|
||||
|
|
@ -221,9 +226,9 @@ M: radio-control model-changed
|
|||
<bevel-button> ;
|
||||
|
||||
: <toolbar> ( target -- toolbar )
|
||||
[
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> gadget, ] curry assoc-each
|
||||
] make-shelf ;
|
||||
<shelf>
|
||||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
|
||||
: toolbar, ( -- ) g <toolbar> f track, ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles
|
|||
math.vectors sorting colors combinators assocs math.order
|
||||
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
|
||||
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
|
||||
math.geometry.rect ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor < gadget
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
USING: kernel alien.c-types combinators sequences splitting grouping
|
||||
opengl.gl ui.gadgets ui.render
|
||||
math math.vectors accessors ;
|
||||
math math.vectors accessors math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets.frame-buffer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic kernel math namespaces sequences words
|
||||
splitting grouping math.vectors ui.gadgets.grids ui.gadgets ;
|
||||
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
|
||||
math.geometry.rect ;
|
||||
IN: ui.gadgets.frames
|
||||
|
||||
! A frame arranges gadgets in a 3x3 grid, where the center
|
||||
|
|
|
|||
|
|
@ -1,53 +1,7 @@
|
|||
USING: help.markup help.syntax opengl kernel strings
|
||||
classes.tuple classes quotations models ;
|
||||
classes.tuple classes quotations models math.geometry.rect ;
|
||||
IN: ui.gadgets
|
||||
|
||||
HELP: rect
|
||||
{ $class-description "A rectangle with the following slots:"
|
||||
{ $list
|
||||
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
|
||||
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
|
||||
}
|
||||
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
|
||||
} ;
|
||||
|
||||
HELP: <rect> ( loc dim -- rect )
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
|
||||
|
||||
{ <zero-rect> <rect> <extent-rect> } related-words
|
||||
|
||||
HELP: set-rect-dim ( dim rect -- )
|
||||
{ $values { "dim" "a pair of integers" } { "rect" rect } }
|
||||
{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." }
|
||||
{ $side-effects "rect" } ;
|
||||
|
||||
HELP: rect-bounds
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Outputs the location and dimensions of a rectangle." } ;
|
||||
|
||||
{ rect-bounds rect-extent } related-words
|
||||
|
||||
HELP: <extent-rect> ( loc ext -- rect )
|
||||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
|
||||
|
||||
HELP: rect-extent
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
|
||||
|
||||
HELP: offset-rect
|
||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
|
||||
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
|
||||
|
||||
HELP: rect-intersect
|
||||
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
|
||||
{ $description "Computes the intersection of two rectangles." } ;
|
||||
|
||||
HELP: intersects?
|
||||
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
|
||||
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
|
||||
|
||||
HELP: gadget-child
|
||||
{ $values { "gadget" gadget } { "child" gadget } }
|
||||
{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
|
||||
|
|
@ -57,10 +11,6 @@ HELP: nth-gadget
|
|||
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
|
||||
{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
|
||||
|
||||
HELP: <zero-rect>
|
||||
{ $values { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
|
||||
|
||||
HELP: <gadget>
|
||||
{ $values { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Creates a new gadget." } ;
|
||||
|
|
@ -230,10 +180,6 @@ HELP: focusable-child
|
|||
{ $values { "gadget" gadget } { "child" gadget } }
|
||||
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
|
||||
|
||||
HELP: gadget,
|
||||
{ $values { "gadget" gadget } }
|
||||
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
|
||||
|
||||
HELP: make-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||
|
|
|
|||
|
|
@ -2,48 +2,16 @@ IN: ui.gadgets.tests
|
|||
USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
|
||||
tools.test namespaces models kernel dlists dequeues math sets
|
||||
math.parser ui sequences hashtables assocs io arrays prettyprint
|
||||
io.streams.string ;
|
||||
|
||||
[ T{ rect f { 10 10 } { 20 20 } } ]
|
||||
[
|
||||
T{ rect f { 10 10 } { 50 50 } }
|
||||
T{ rect f { -10 -10 } { 40 40 } }
|
||||
rect-intersect
|
||||
] unit-test
|
||||
|
||||
[ T{ rect f { 200 200 } { 0 0 } } ]
|
||||
[
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 200 200 } { 40 40 } }
|
||||
rect-intersect
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 200 200 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ rect f { 100 100 } { 50 50 } }
|
||||
T{ rect f { 120 120 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ rect f { 1000 100 } { 50 50 } }
|
||||
T{ rect f { 120 120 } { 40 40 } }
|
||||
intersects?
|
||||
] unit-test
|
||||
io.streams.string math.geometry.rect ;
|
||||
|
||||
[ { 300 300 } ]
|
||||
[
|
||||
! c contains b contains a
|
||||
<gadget> "a" set
|
||||
<gadget> "b" set
|
||||
"a" get "b" get add-gadget
|
||||
"a" get "b" get swap add-gadget drop
|
||||
<gadget> "c" set
|
||||
"b" get "c" get add-gadget
|
||||
"b" get "c" get swap add-gadget drop
|
||||
|
||||
! position a and b
|
||||
{ 100 200 } "a" get set-rect-loc
|
||||
|
|
@ -65,8 +33,8 @@ io.streams.string ;
|
|||
<gadget> "g3" set
|
||||
{ 100 200 } "g3" get set-rect-dim
|
||||
|
||||
"g1" get "g2" get add-gadget
|
||||
"g2" get "g3" get add-gadget
|
||||
"g1" get "g2" get swap add-gadget drop
|
||||
"g2" get "g3" get swap add-gadget drop
|
||||
|
||||
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
|
||||
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
|
||||
|
|
@ -81,11 +49,11 @@ io.streams.string ;
|
|||
<gadget> "g1" set
|
||||
{ 300 300 } "g1" get set-rect-dim
|
||||
<gadget> "g2" set
|
||||
"g2" get "g1" get add-gadget
|
||||
"g2" get "g1" get swap add-gadget drop
|
||||
{ 20 20 } "g2" get set-rect-loc
|
||||
{ 20 20 } "g2" get set-rect-dim
|
||||
<gadget> "g3" set
|
||||
"g3" get "g1" get add-gadget
|
||||
"g3" get "g1" get swap add-gadget drop
|
||||
{ 100 100 } "g3" get set-rect-loc
|
||||
{ 20 20 } "g3" get set-rect-dim
|
||||
|
||||
|
|
@ -98,7 +66,7 @@ io.streams.string ;
|
|||
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
|
||||
|
||||
<gadget> "g4" set
|
||||
"g4" get "g2" get add-gadget
|
||||
"g4" get "g2" get swap add-gadget drop
|
||||
{ 5 5 } "g4" get set-rect-loc
|
||||
{ 1 1 } "g4" get set-rect-dim
|
||||
|
||||
|
|
@ -155,7 +123,7 @@ M: mock-gadget ungraft*
|
|||
: add-some-children
|
||||
3 [
|
||||
<mock-gadget> over <model> over set-gadget-model
|
||||
dup "g" get add-gadget
|
||||
dup "g" get swap add-gadget drop
|
||||
swap 1+ number>string set
|
||||
] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,56 +1,21 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables kernel models math namespaces
|
||||
sequences quotations math.vectors combinators sorting vectors
|
||||
dlists dequeues models threads concurrency.flags math.order ;
|
||||
sequences quotations math.vectors combinators sorting vectors
|
||||
dlists dequeues models threads concurrency.flags
|
||||
math.order math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets
|
||||
|
||||
SYMBOL: ui-notify-flag
|
||||
|
||||
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
||||
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ;
|
||||
|
||||
C: <rect> rect
|
||||
|
||||
M: array rect-loc ;
|
||||
|
||||
M: array rect-dim drop { 0 0 } ;
|
||||
|
||||
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
|
||||
|
||||
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
|
||||
|
||||
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
|
||||
[ rect-extent ] bi@ swapd ;
|
||||
|
||||
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
|
||||
|
||||
: offset-rect ( rect loc -- newrect )
|
||||
over rect-loc v+ swap rect-dim <rect> ;
|
||||
|
||||
: (rect-intersect) ( rect rect -- array array )
|
||||
2rect-extent vmin >r vmax r> ;
|
||||
|
||||
: rect-intersect ( rect1 rect2 -- newrect )
|
||||
(rect-intersect) <extent-rect> ;
|
||||
|
||||
: intersects? ( rect/point rect -- ? )
|
||||
(rect-intersect) [v-] { 0 0 } = ;
|
||||
|
||||
: (rect-union) ( rect rect -- array array )
|
||||
2rect-extent vmax >r vmin r> ;
|
||||
|
||||
: rect-union ( rect1 rect2 -- newrect )
|
||||
(rect-union) <extent-rect> ;
|
||||
|
||||
TUPLE: gadget < rect
|
||||
pref-dim parent children orientation focus
|
||||
visible? root? clipped? layout-state graft-state graft-node
|
||||
interior boundary
|
||||
model ;
|
||||
pref-dim parent children orientation focus
|
||||
visible? root? clipped? layout-state graft-state graft-node
|
||||
interior boundary
|
||||
model ;
|
||||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
|
|
@ -58,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ;
|
|||
|
||||
M: gadget model-changed 2drop ;
|
||||
|
||||
: gadget-child ( gadget -- child ) gadget-children first ;
|
||||
: gadget-child ( gadget -- child ) children>> first ;
|
||||
|
||||
: nth-gadget ( n gadget -- child ) gadget-children nth ;
|
||||
: nth-gadget ( n gadget -- child ) children>> nth ;
|
||||
|
||||
: new-gadget ( class -- gadget )
|
||||
new
|
||||
|
|
@ -72,7 +37,7 @@ M: gadget model-changed 2drop ;
|
|||
gadget new-gadget ;
|
||||
|
||||
: activate-control ( gadget -- )
|
||||
dup gadget-model dup [
|
||||
dup model>> dup [
|
||||
2dup add-connection
|
||||
swap model-changed
|
||||
] [
|
||||
|
|
@ -80,20 +45,20 @@ M: gadget model-changed 2drop ;
|
|||
] if ;
|
||||
|
||||
: deactivate-control ( gadget -- )
|
||||
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
|
||||
dup model>> dup [ 2dup remove-connection ] when 2drop ;
|
||||
|
||||
: control-value ( control -- value )
|
||||
gadget-model model-value ;
|
||||
model>> model-value ;
|
||||
|
||||
: set-control-value ( value control -- )
|
||||
gadget-model set-model ;
|
||||
model>> set-model ;
|
||||
|
||||
: relative-loc ( fromgadget togadget -- loc )
|
||||
2dup eq? [
|
||||
2drop { 0 0 }
|
||||
] [
|
||||
over rect-loc >r
|
||||
>r gadget-parent r> relative-loc
|
||||
>r parent>> r> relative-loc
|
||||
r> v+
|
||||
] if ;
|
||||
|
||||
|
|
@ -103,22 +68,18 @@ M: gadget user-input* 2drop t ;
|
|||
|
||||
GENERIC: children-on ( rect/point gadget -- seq )
|
||||
|
||||
M: gadget children-on nip gadget-children ;
|
||||
M: gadget children-on nip children>> ;
|
||||
|
||||
: (fast-children-on) ( dim axis gadgets -- i )
|
||||
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
|
||||
|
||||
: fast-children-on ( rect axis children -- from to )
|
||||
3dup
|
||||
>r >r dup rect-loc swap rect-dim v+
|
||||
r> r> (fast-children-on) ?1+
|
||||
>r
|
||||
>r >r rect-loc
|
||||
r> r> (fast-children-on) 0 or
|
||||
r> ;
|
||||
[ >r >r rect-loc r> r> (fast-children-on) 0 or ]
|
||||
[ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
|
||||
3bi ;
|
||||
|
||||
: inside? ( bounds gadget -- ? )
|
||||
dup gadget-visible? [ intersects? ] [ 2drop f ] if ;
|
||||
dup visible?>> [ intersects? ] [ 2drop f ] if ;
|
||||
|
||||
: (pick-up) ( point gadget -- gadget )
|
||||
dupd children-on [ inside? ] with find-last nip ;
|
||||
|
|
@ -132,10 +93,10 @@ M: gadget children-on nip gadget-children ;
|
|||
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
|
||||
|
||||
: orient ( gadget seq1 seq2 -- seq )
|
||||
>r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
|
||||
>r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
|
||||
|
||||
: each-child ( gadget quot -- )
|
||||
>r gadget-children r> each ; inline
|
||||
>r children>> r> each ; inline
|
||||
|
||||
! Selection protocol
|
||||
GENERIC: gadget-selection? ( gadget -- ? )
|
||||
|
|
@ -152,14 +113,14 @@ GENERIC: gadget-text* ( gadget -- )
|
|||
GENERIC: gadget-text-separator ( gadget -- str )
|
||||
|
||||
M: gadget gadget-text-separator
|
||||
gadget-orientation { 0 1 } = "\n" "" ? ;
|
||||
orientation>> { 0 1 } = "\n" "" ? ;
|
||||
|
||||
: gadget-seq-text ( seq gadget -- )
|
||||
gadget-text-separator swap
|
||||
[ dup % ] [ gadget-text* ] interleave drop ;
|
||||
|
||||
M: gadget gadget-text*
|
||||
dup gadget-children swap gadget-seq-text ;
|
||||
dup children>> swap gadget-seq-text ;
|
||||
|
||||
M: array gadget-text*
|
||||
[ gadget-text* ] each ;
|
||||
|
|
@ -167,9 +128,9 @@ M: array gadget-text*
|
|||
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
|
||||
|
||||
: invalidate ( gadget -- )
|
||||
\ invalidate swap set-gadget-layout-state ;
|
||||
\ invalidate swap (>>layout-state) ;
|
||||
|
||||
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
|
||||
: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
|
||||
|
||||
: layout-queue ( -- queue ) \ layout-queue get ;
|
||||
|
||||
|
|
@ -182,22 +143,22 @@ M: array gadget-text*
|
|||
DEFER: relayout
|
||||
|
||||
: invalidate* ( gadget -- )
|
||||
\ invalidate* over set-gadget-layout-state
|
||||
\ invalidate* over (>>layout-state)
|
||||
dup forget-pref-dim
|
||||
dup gadget-root?
|
||||
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
|
||||
[ layout-later ] [ parent>> [ relayout ] when* ] if ;
|
||||
|
||||
: relayout ( gadget -- )
|
||||
dup gadget-layout-state \ invalidate* eq?
|
||||
dup layout-state>> \ invalidate* eq?
|
||||
[ drop ] [ invalidate* ] if ;
|
||||
|
||||
: relayout-1 ( gadget -- )
|
||||
dup gadget-layout-state
|
||||
dup layout-state>>
|
||||
[ drop ] [ dup invalidate layout-later ] if ;
|
||||
|
||||
: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
|
||||
: show-gadget ( gadget -- ) t swap (>>visible?) ;
|
||||
|
||||
: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
|
||||
: hide-gadget ( gadget -- ) f swap (>>visible?) ;
|
||||
|
||||
: (set-rect-dim) ( dim gadget quot -- )
|
||||
>r 2dup rect-dim =
|
||||
|
|
@ -213,11 +174,11 @@ DEFER: relayout
|
|||
GENERIC: pref-dim* ( gadget -- dim )
|
||||
|
||||
: ?set-gadget-pref-dim ( dim gadget -- )
|
||||
dup gadget-layout-state
|
||||
[ 2drop ] [ set-gadget-pref-dim ] if ;
|
||||
dup layout-state>>
|
||||
[ 2drop ] [ (>>pref-dim) ] if ;
|
||||
|
||||
: pref-dim ( gadget -- dim )
|
||||
dup gadget-pref-dim [ ] [
|
||||
dup pref-dim>> [ ] [
|
||||
[ pref-dim* dup ] keep ?set-gadget-pref-dim
|
||||
] ?if ;
|
||||
|
||||
|
|
@ -231,10 +192,10 @@ M: gadget layout* drop ;
|
|||
|
||||
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
|
||||
|
||||
: validate ( gadget -- ) f swap set-gadget-layout-state ;
|
||||
: validate ( gadget -- ) f swap (>>layout-state) ;
|
||||
|
||||
: layout ( gadget -- )
|
||||
dup gadget-layout-state [
|
||||
dup layout-state>> [
|
||||
dup validate
|
||||
dup layout*
|
||||
dup [ layout ] each-child
|
||||
|
|
@ -258,7 +219,7 @@ M: gadget layout* drop ;
|
|||
{ t f } (queue-graft) ;
|
||||
|
||||
: graft-later ( gadget -- )
|
||||
dup gadget-graft-state {
|
||||
dup graft-state>> {
|
||||
{ { f t } [ drop ] }
|
||||
{ { t t } [ drop ] }
|
||||
{ { t f } [ unqueue-graft ] }
|
||||
|
|
@ -266,7 +227,7 @@ M: gadget layout* drop ;
|
|||
} case ;
|
||||
|
||||
: ungraft-later ( gadget -- )
|
||||
dup gadget-graft-state {
|
||||
dup graft-state>> {
|
||||
{ { f f } [ drop ] }
|
||||
{ { t f } [ drop ] }
|
||||
{ { f t } [ unqueue-graft ] }
|
||||
|
|
@ -290,11 +251,11 @@ M: gadget ungraft* drop ;
|
|||
: (unparent) ( gadget -- )
|
||||
dup ungraft
|
||||
dup forget-pref-dim
|
||||
f swap set-gadget-parent ;
|
||||
f swap (>>parent) ;
|
||||
|
||||
: unfocus-gadget ( child gadget -- )
|
||||
tuck gadget-focus eq?
|
||||
[ f swap set-gadget-focus ] [ drop ] if ;
|
||||
tuck focus>> eq?
|
||||
[ f swap (>>focus) ] [ drop ] if ;
|
||||
|
||||
SYMBOL: in-layout?
|
||||
|
||||
|
|
@ -305,10 +266,10 @@ SYMBOL: in-layout?
|
|||
: unparent ( gadget -- )
|
||||
not-in-layout
|
||||
[
|
||||
dup gadget-parent dup [
|
||||
dup parent>> dup [
|
||||
over (unparent)
|
||||
[ unfocus-gadget ] 2keep
|
||||
[ gadget-children delete ] keep
|
||||
[ children>> delete ] keep
|
||||
relayout
|
||||
] [
|
||||
2drop
|
||||
|
|
@ -317,32 +278,37 @@ SYMBOL: in-layout?
|
|||
|
||||
: (clear-gadget) ( gadget -- )
|
||||
dup [ (unparent) ] each-child
|
||||
f over set-gadget-focus
|
||||
f swap set-gadget-children ;
|
||||
f over (>>focus)
|
||||
f swap (>>children) ;
|
||||
|
||||
: clear-gadget ( gadget -- )
|
||||
not-in-layout
|
||||
dup (clear-gadget) relayout ;
|
||||
|
||||
: ((add-gadget)) ( gadget box -- )
|
||||
[ gadget-children ?push ] keep set-gadget-children ;
|
||||
: ((add-gadget)) ( parent child -- parent )
|
||||
over children>> ?push >>children ;
|
||||
|
||||
: (add-gadget) ( gadget box -- )
|
||||
over unparent
|
||||
dup pick set-gadget-parent
|
||||
[ ((add-gadget)) ] 2keep
|
||||
gadget-graft-state second [ graft ] [ drop ] if ;
|
||||
: (add-gadget) ( parent child -- parent )
|
||||
dup unparent
|
||||
over >>parent
|
||||
tuck ((add-gadget))
|
||||
tuck graft-state>> second
|
||||
[ graft ]
|
||||
[ drop ]
|
||||
if ;
|
||||
|
||||
: add-gadget ( gadget parent -- )
|
||||
: add-gadget ( parent child -- parent )
|
||||
not-in-layout
|
||||
[ (add-gadget) ] keep relayout ;
|
||||
|
||||
: add-gadgets ( seq parent -- )
|
||||
(add-gadget)
|
||||
dup relayout ;
|
||||
|
||||
: add-gadgets ( parent children -- parent )
|
||||
not-in-layout
|
||||
swap [ over (add-gadget) ] each relayout ;
|
||||
[ (add-gadget) ] each
|
||||
dup relayout ;
|
||||
|
||||
: parents ( gadget -- seq )
|
||||
[ gadget-parent ] follow ;
|
||||
[ parent>> ] follow ;
|
||||
|
||||
: each-parent ( gadget quot -- ? )
|
||||
>r parents r> all? ; inline
|
||||
|
|
@ -354,7 +320,7 @@ SYMBOL: in-layout?
|
|||
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
||||
|
||||
: (screen-rect) ( gadget -- loc ext )
|
||||
dup gadget-parent [
|
||||
dup parent>> [
|
||||
>r rect-extent r> (screen-rect)
|
||||
>r tuck v+ r> vmin >r v+ r>
|
||||
] [
|
||||
|
|
@ -368,7 +334,7 @@ SYMBOL: in-layout?
|
|||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ dup not ] [ 2drop f ] }
|
||||
[ gadget-parent child? ]
|
||||
[ parent>> child? ]
|
||||
} cond ;
|
||||
|
||||
GENERIC: focusable-child* ( gadget -- child/t )
|
||||
|
|
@ -381,7 +347,7 @@ M: gadget focusable-child* drop t ;
|
|||
|
||||
GENERIC: request-focus-on ( child gadget -- )
|
||||
|
||||
M: gadget request-focus-on gadget-parent request-focus-on ;
|
||||
M: gadget request-focus-on parent>> request-focus-on ;
|
||||
|
||||
M: f request-focus-on 2drop ;
|
||||
|
||||
|
|
@ -389,9 +355,7 @@ M: f request-focus-on 2drop ;
|
|||
[ focusable-child ] keep request-focus-on ;
|
||||
|
||||
: focus-path ( world -- seq )
|
||||
[ gadget-focus ] follow ;
|
||||
|
||||
: gadget, ( gadget -- ) gadget get add-gadget ;
|
||||
[ focus>> ] follow ;
|
||||
|
||||
: g ( -- gadget ) gadget get ;
|
||||
|
||||
|
|
@ -406,7 +370,7 @@ M: f request-focus-on 2drop ;
|
|||
! Deprecated
|
||||
: set-gadget-delegate ( gadget tuple -- )
|
||||
over [
|
||||
dup pick [ set-gadget-parent ] with each-child
|
||||
dup pick [ (>>parent) ] with each-child
|
||||
] when set-delegate ;
|
||||
|
||||
: construct-gadget ( class -- tuple )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces opengl opengl.gl sequences
|
||||
math.vectors ui.gadgets ui.gadgets.grids ui.render ;
|
||||
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||
IN: ui.gadgets.grid-lines
|
||||
|
||||
TUPLE: grid-lines color ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
|
||||
namespaces ;
|
||||
namespaces math.geometry.rect ;
|
||||
IN: ui.gadgets.grids.tests
|
||||
|
||||
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math namespaces sequences words io
|
||||
io.streams.string math.vectors ui.gadgets columns accessors ;
|
||||
io.streams.string math.vectors ui.gadgets columns accessors
|
||||
math.geometry.rect ;
|
||||
IN: ui.gadgets.grids
|
||||
|
||||
TUPLE: grid < gadget
|
||||
|
|
@ -11,7 +12,7 @@ grid
|
|||
|
||||
: new-grid ( children class -- grid )
|
||||
new-gadget
|
||||
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
|
||||
[ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
|
||||
inline
|
||||
|
||||
: <grid> ( children -- grid )
|
||||
|
|
@ -20,7 +21,7 @@ grid
|
|||
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
|
||||
|
||||
: grid-add ( gadget grid i j -- )
|
||||
>r >r 2dup add-gadget r> r>
|
||||
>r >r 2dup swap add-gadget drop r> r>
|
||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||
|
||||
: grid-remove ( grid i j -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io kernel math namespaces math.vectors ui.gadgets
|
||||
ui.gadgets.packs accessors ;
|
||||
ui.gadgets.packs accessors math.geometry.rect ;
|
||||
IN: ui.gadgets.incremental
|
||||
|
||||
! Incremental layout allows adding lines to panes to be O(1).
|
||||
|
|
@ -45,7 +45,7 @@ M: incremental pref-dim*
|
|||
|
||||
: add-incremental ( gadget incremental -- )
|
||||
not-in-layout
|
||||
2dup (add-gadget)
|
||||
2dup swap (add-gadget) drop
|
||||
over prefer-incremental
|
||||
over layout-later
|
||||
2dup incremental-loc
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets
|
|||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
kernel sequences models opengl math math.order namespaces
|
||||
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
|
||||
math.vectors classes.tuple ;
|
||||
math.vectors classes.tuple math.geometry.rect ;
|
||||
IN: ui.gadgets.lists
|
||||
|
||||
TUPLE: list < pack index presenter color hook ;
|
||||
|
|
@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
|
|||
M: list model-changed
|
||||
nip
|
||||
dup clear-gadget
|
||||
dup <list-items> over add-gadgets
|
||||
dup <list-items> over swap add-gadgets drop
|
||||
bound-index ;
|
||||
|
||||
: selected-rect ( list -- rect )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.worlds ui.gestures generic hashtables kernel math
|
||||
models namespaces opengl sequences math.vectors
|
||||
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ;
|
||||
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
|
||||
math.geometry.rect ;
|
||||
IN: ui.gadgets.menus
|
||||
|
||||
: menu-loc ( world menu -- loc )
|
||||
|
|
@ -14,7 +15,7 @@ TUPLE: menu-glass < gadget ;
|
|||
: <menu-glass> ( menu world -- glass )
|
||||
menu-glass new-gadget
|
||||
>r over menu-loc over set-rect-loc r>
|
||||
[ add-gadget ] keep ;
|
||||
[ swap add-gadget drop ] keep ;
|
||||
|
||||
M: menu-glass layout* gadget-child prefer ;
|
||||
|
||||
|
|
@ -25,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ;
|
|||
: show-glass ( gadget world -- )
|
||||
over hand-clicked set-global
|
||||
[ hide-glass ] keep
|
||||
[ add-gadget ] 2keep
|
||||
[ swap add-gadget drop ] 2keep
|
||||
set-world-glass ;
|
||||
|
||||
: show-menu ( gadget owner -- )
|
||||
|
|
@ -47,6 +48,7 @@ M: menu-glass layout* gadget-child prefer ;
|
|||
faint-boundary ;
|
||||
|
||||
: <commands-menu> ( hook target commands -- gadget )
|
||||
[
|
||||
[ >r 2dup r> <menu-item> gadget, ] each 2drop
|
||||
] make-filled-pile 5 <border> menu-theme ;
|
||||
<filled-pile>
|
||||
-roll
|
||||
[ <menu-item> add-gadget ] with with each
|
||||
5 <border> menu-theme ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
|
|||
{ $subsection make-pile }
|
||||
{ $subsection make-filled-pile }
|
||||
{ $subsection make-shelf }
|
||||
{ $subsection gadget, }
|
||||
|
||||
"For more control, custom layouts can reuse portions of pack layout logic:"
|
||||
{ $subsection pack-pref-dim }
|
||||
{ $subsection pack-layout } ;
|
||||
|
|
@ -66,14 +66,14 @@ HELP: pack-pref-dim
|
|||
|
||||
HELP: make-pile
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the " { $link gadget, } " word." } ;
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
HELP: make-filled-pile
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the " { $link gadget, } " word." } ;
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
HELP: make-shelf
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
ABOUT: "ui-pack-layout"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: ui.gadgets.packs.tests
|
||||
USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
|
||||
kernel namespaces tools.test math.parser sequences ;
|
||||
kernel namespaces tools.test math.parser sequences math.geometry.rect ;
|
||||
|
||||
[ t ] [
|
||||
{ 0 0 } { 100 100 } <rect> clip set
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences ui.gadgets kernel math math.functions
|
||||
math.vectors namespaces math.order accessors ;
|
||||
math.vectors namespaces math.order accessors math.geometry.rect ;
|
||||
IN: ui.gadgets.packs
|
||||
|
||||
TUPLE: pack < gadget
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors
|
|||
sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines classes.tuple models continuations
|
||||
destructors accessors ;
|
||||
destructors accessors math.geometry.rect ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane < pack
|
||||
|
|
@ -22,10 +22,10 @@ selection-color caret mark selecting? ;
|
|||
drop ;
|
||||
|
||||
: add-output ( current pane -- )
|
||||
[ set-pane-output ] [ add-gadget ] 2bi ;
|
||||
[ set-pane-output ] [ swap add-gadget drop ] 2bi ;
|
||||
|
||||
: add-current ( current pane -- )
|
||||
[ set-pane-current ] [ add-gadget ] 2bi ;
|
||||
[ set-pane-current ] [ swap add-gadget drop ] 2bi ;
|
||||
|
||||
: prepare-line ( pane -- )
|
||||
[ clear-selection ]
|
||||
|
|
@ -120,7 +120,7 @@ C: <pane-stream> pane-stream
|
|||
GENERIC: write-gadget ( gadget stream -- )
|
||||
|
||||
M: pane-stream write-gadget
|
||||
pane-stream-pane pane-current add-gadget ;
|
||||
pane-stream-pane pane-current swap add-gadget drop ;
|
||||
|
||||
M: style-stream write-gadget
|
||||
stream>> write-gadget ;
|
||||
|
|
@ -299,12 +299,12 @@ M: paragraph dispose drop ;
|
|||
|
||||
: gadget-write ( string gadget -- )
|
||||
over empty?
|
||||
[ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
|
||||
[ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
|
||||
|
||||
M: pack stream-write gadget-write ;
|
||||
|
||||
: gadget-bl ( style stream -- )
|
||||
>r " " <word-break-gadget> style-label r> add-gadget ;
|
||||
>r " " <word-break-gadget> style-label r> swap add-gadget drop ;
|
||||
|
||||
M: paragraph stream-write
|
||||
swap " " split
|
||||
|
|
@ -322,7 +322,7 @@ M: paragraph stream-write1
|
|||
|
||||
: gadget-format ( string style stream -- )
|
||||
pick empty?
|
||||
[ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
|
||||
[ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
|
||||
|
||||
M: pack stream-format
|
||||
gadget-format ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue