steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2008-07-13 15:12:31 -07:00
parent 310acd52c5 dc71e50dc4
commit 8737e58c2c
56 changed files with 502 additions and 360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/alien/c-types/c-types.factor
View File

@ -151,7 +151,8 @@ M: byte-array byte-length length ;
swap dup length memcpy ; swap dup length memcpy ;
: (define-nth) ( word type quot -- ) : (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 ) : nth-word ( name vocab -- word )
>r "-nth" append r> create ; >r "-nth" append r> create ;

20
core/assocs/assocs-docs.factor
View File

@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":" "Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection key? } { $subsection key? }
{ $subsection at } { $subsection at }
{ $subsection value-at }
{ $subsection assoc-empty? } { $subsection assoc-empty? }
{ $subsection keys } { $subsection keys }
{ $subsection values } { $subsection values }
{ $subsection assoc-stack } { $subsection assoc-stack }
{ $see-also at* assoc-size } ; { $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" 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)." "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? } { $subsection assoc-subset? }
@ -111,6 +117,7 @@ $nl
{ $subsection "assocs-protocol" } { $subsection "assocs-protocol" }
"A large set of utility words work on any object whose class implements the associative mapping protocol." "A large set of utility words work on any object whose class implements the associative mapping protocol."
{ $subsection "assocs-lookup" } { $subsection "assocs-lookup" }
{ $subsection "assocs-values" }
{ $subsection "assocs-mutation" } { $subsection "assocs-mutation" }
{ $subsection "assocs-combinators" } { $subsection "assocs-combinators" }
{ $subsection "assocs-sets" } ; { $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 } "." } { $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." } ; { $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 HELP: value-at
{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } } { $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 } "." } { $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." } ;
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* HELP: delete-at*
{ $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } } { $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } }

9
core/assocs/assocs.factor
View File

@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: extract-keys ( seq assoc -- subassoc ) : extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ; [ [ 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 ) M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
swap [ = nip ] curry assoc-find 2drop ;
: value-at ( value assoc -- key/f ) value-at* drop ;
: value? ( value assoc -- ? ) value-at* nip ;
: push-at ( value key assoc -- ) : push-at ( value key assoc -- )
[ ?push ] change-at ; [ ?push ] change-at ;

3
core/bootstrap/image/image.factor
View File

@ -119,6 +119,7 @@ SYMBOL: jit-primitive
SYMBOL: jit-word-jump SYMBOL: jit-word-jump
SYMBOL: jit-word-call SYMBOL: jit-word-call
SYMBOL: jit-push-literal SYMBOL: jit-push-literal
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word SYMBOL: jit-if-word
SYMBOL: jit-if-jump SYMBOL: jit-if-jump
SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch-word
@ -149,6 +150,7 @@ SYMBOL: undefined-quot
{ jit-epilog 33 } { jit-epilog 33 }
{ jit-return 34 } { jit-return 34 }
{ jit-profiling 35 } { jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 } { jit-declare-word 42 }
{ undefined-quot 60 } { undefined-quot 60 }
} at header-size + ; } at header-size + ;
@ -438,6 +440,7 @@ M: quotation '
jit-word-jump jit-word-jump
jit-word-call jit-word-call
jit-push-literal jit-push-literal
jit-push-immediate
jit-if-word jit-if-word
jit-if-jump jit-if-jump
jit-dispatch-word jit-dispatch-word

2
core/classes/tuple/parser/parser-tests.factor
View File

@ -51,7 +51,7 @@ must-fail-with
[ error>> unexpected-eof? ] [ error>> unexpected-eof? ]
must-fail-with 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? ] [ error>> no-initial-value? ]
must-fail-with must-fail-with

6
core/cpu/x86/bootstrap.factor
View File

@ -40,6 +40,12 @@ big-endian off
ds-reg [] arg0 MOV ! store literal on datastack ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define ] 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 arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2 arg1 stack-reg MOV ! pass callstack pointer as arg 2

1
core/generator/fixup/fixup.factor
View File

@ -72,6 +72,7 @@ SYMBOL: label-table
: rt-xt 4 ; : rt-xt 4 ;
: rt-here 5 ; : rt-here 5 ;
: rt-label 6 ; : rt-label 6 ;
: rt-immediate 7 ;
TUPLE: label-fixup label class ; TUPLE: label-fixup label class ;

4
core/grouping/grouping-docs.factor
View File

@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ;
IN: grouping IN: grouping
ARTICLE: "grouping" "Groups and clumps" 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:" "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
{ $subsection groups } { $subsection groups }
{ $subsection <groups> } { $subsection <groups> }
{ $subsection <sliced-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:" "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsection clumps } { $subsection clumps }
{ $subsection <clumps> } { $subsection <clumps> }

6
core/inference/errors/errors.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 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 ; M: inference-error error-help error>> error-help ;

5
core/optimizer/def-use/def-use.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences inference.dataflow USING: namespaces assocs sequences kernel generic assocs classes
inference.backend kernel generic assocs classes vectors vectors accessors combinators inference.dataflow inference.backend ;
accessors combinators ;
IN: optimizer.def-use IN: optimizer.def-use
SYMBOL: def-use SYMBOL: def-use

18
core/optimizer/known-words/known-words.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays generic hashtables definitions USING: accessors alien arrays generic hashtables definitions
inference.dataflow inference.state inference.class kernel assocs kernel assocs math math.order math.private kernel.private
math math.order math.private kernel.private sequences words sequences words parser vectors strings sbufs io namespaces
parser vectors strings sbufs io namespaces assocs quotations assocs quotations sequences.private io.binary io.streams.string
sequences.private io.binary io.streams.string layouts splitting layouts splitting math.intervals math.floats.private
math.intervals math.floats.private classes.tuple classes.predicate classes.tuple classes.predicate classes.tuple.private classes
classes.tuple.private classes classes.algebra optimizer.def-use classes.algebra sequences.private combinators byte-arrays
optimizer.backend optimizer.pattern-match optimizer.inlining byte-vectors slots.private inference.dataflow inference.state
sequences.private combinators byte-arrays byte-vectors inference.class optimizer.def-use optimizer.backend
slots.private ; optimizer.pattern-match optimizer.inlining ;
IN: optimizer.known-words IN: optimizer.known-words
{ <tuple> <tuple-boa> (tuple) } [ { <tuple> <tuple-boa> (tuple) } [

13
core/optimizer/math/math.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: effects alien alien.accessors arrays generic hashtables USING: effects alien alien.accessors arrays generic hashtables
kernel assocs math math.libm math.private kernel.private kernel assocs math math.libm math.private kernel.private
sequences words parser inference.class inference.dataflow sequences words parser vectors strings sbufs io namespaces
vectors strings sbufs io namespaces assocs quotations assocs quotations math.intervals sequences.private combinators
math.intervals sequences.private combinators splitting layouts splitting layouts math.parser classes classes.algebra
math.parser classes classes.algebra generic.math generic.math inference.class inference.dataflow
optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.pattern-match optimizer.backend optimizer.def-use
optimizer.inlining optimizer.math.partial generic.standard optimizer.inlining optimizer.math.partial generic.standard
system accessors ; system accessors ;
@ -444,7 +444,10 @@ most-negative-fixnum most-positive-fixnum [a,b]
{ /f < > <= >= } { /f < > <= >= }
[ { real real } "input-classes" set-word-prop ] each [ { real real } "input-classes" set-word-prop ] each
{ /i bitand bitor bitxor bitnot shift } { /i mod /mod }
[ { rational rational } "input-classes" set-word-prop ] each
{ bitand bitor bitxor bitnot shift }
[ { integer integer } "input-classes" set-word-prop ] each [ { integer integer } "input-classes" set-word-prop ] each
{ {

5
core/optimizer/pattern-match/pattern-match.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: optimizer.pattern-match
USING: kernel sequences inference namespaces generic
combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching ! Funny pattern matching
SYMBOL: @ SYMBOL: @

12
core/sets/sets-docs.factor
View File

@ -38,6 +38,18 @@ HELP: adjoin
} }
{ $side-effects "seq" } ; { $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 HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." } { $description "Outputs a new assoc where the keys and values are equal." }

9
extra/assocs/lib/lib.factor
View File

@ -1,13 +1,8 @@
USING: arrays assocs kernel vectors sequences namespaces USING: arrays assocs kernel vectors sequences namespaces
random math.parser math fry ; random math.parser math fry ;
IN: assocs.lib 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 -- ) : set-assoc-stack ( value key seq -- )
dupd [ key? ] with find-last nip set-at ; dupd [ key? ] with find-last nip set-at ;

2
extra/automata/automata.factor
View File

@ -32,7 +32,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
! step-wrapped-line ! step-wrapped-line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pattern>state ( {_a_b_c_} -- state ) >array rule> at ; : pattern>state ( {_a_b_c_} -- state ) rule> at ;
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;

62
extra/automata/ui/ui.factor
View File

@ -14,13 +14,22 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui.gadgets.packs ui.gadgets.packs
ui.gadgets.grids ui.gadgets.grids
ui.gadgets.theme ui.gadgets.theme
accessors
qualified
namespaces.lib assocs.lib vars namespaces.lib assocs.lib vars
rewrite-closures automata math.geometry.rect ; rewrite-closures automata math.geometry.rect newfx ;
IN: automata.ui 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-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ; : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@ -57,29 +66,40 @@ slate> relayout-1 ;
DEFER: automata-window DEFER: automata-window
: automata-window* ( -- ) init-rule set-interesting <frame> : automata-window* ( -- )
init-rule
set-interesting
{ <frame>
[ "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
[ display ] closed-quot <slate> { 400 400 } over set-slate-dim dup >slate <shelf>
over @center grid-add
{ "1 - Center" [ start-center ] view-button add-gadget
{ T{ key-down f f "1" } [ [ start-center ] view-action ] } "2 - Random" [ start-random ] view-button add-gadget
{ T{ key-down f f "2" } [ [ start-random ] view-action ] } "3 - Continue" [ run-rule ] view-button add-gadget
{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } "5 - Random Rule" [ random-rule ] view-button add-gadget
{ T{ key-down f f "5" } [ [ random-rule ] view-action ] } "n - New" [ automata-window ] view-button add-gadget
{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
} [ make* ] map >hashtable <handler> tuck set-gadget-delegate @top grid-add
"Automata" open-window ;
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

1
extra/biassocs/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

28
extra/biassocs/biassocs-docs.factor Normal file
View File

@ -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"

22
extra/biassocs/biassocs-tests.factor Normal file
View File

@ -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

35
extra/biassocs/biassocs.factor Normal file
View File

@ -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

1
extra/biassocs/summary.txt Normal file
View File

@ -0,0 +1 @@
Bidirectional assocs

1
extra/biassocs/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
extra/bitfields/tags.txt
View File

@ -1,2 +1 @@
collections
extensions extensions

4
extra/boids/boids.factor
View File

@ -73,10 +73,6 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: constrain ( n a b -- n ) rot min max ; : constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle ) : angle-between ( vec vec -- angle )

47
extra/boids/ui/ui.factor
View File

@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces
ui.gadgets.grids ui.gadgets.grids
ui.gestures ui.gestures
assocs.lib vars rewrite-closures boids accessors assocs.lib vars rewrite-closures boids accessors
math.geometry.rect ; math.geometry.rect
newfx ;
IN: boids.ui IN: boids.ui
@ -119,24 +120,24 @@ VARS: population-label cohesion-label alignment-label separation-label ;
[ "1 - Randomize" [ drop randomize ] button* ] [ "1 - Randomize" [ drop randomize ] button* ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
population-label> over add-gadget population-label> add-gadget
"3 - Add 10" [ drop add-10-boids ] button* over add-gadget "3 - Add 10" [ drop add-10-boids ] button* add-gadget
"2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ] "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
cohesion-label> over add-gadget cohesion-label> add-gadget
"q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
"a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ] "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
alignment-label> over add-gadget alignment-label> add-gadget
"w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
"s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ] "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
separation-label> over add-gadget separation-label> add-gadget
"e - +0.1" [ drop inc-separation-weight ] button* over add-gadget "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
"d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ] "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
} [ call ] map [ [ gadget, ] each ] make-shelf } [ call ] map [ [ gadget, ] each ] make-shelf
1 over set-pack-fill 1 over set-pack-fill
@ -145,20 +146,20 @@ VARS: population-label cohesion-label alignment-label separation-label ;
slate> over @center grid-add slate> over @center grid-add
H{ } clone H{ } clone
T{ key-down f f "1" } C[ drop randomize ] put-at T{ key-down f f "1" } C[ drop randomize ] is
T{ key-down f f "2" } C[ drop sub-10-boids ] put-at T{ key-down f f "2" } C[ drop sub-10-boids ] is
T{ key-down f f "3" } C[ drop add-10-boids ] put-at 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 "q" } C[ drop inc-cohesion-weight ] is
T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at 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 "w" } C[ drop inc-alignment-weight ] is
T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at 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 "e" } C[ drop inc-separation-weight ] is
T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at 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 ; <handler> tuck set-gadget-delegate "Boids" open-window ;
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

24
extra/float-arrays/float-arrays.factor
View File

@ -9,16 +9,8 @@ TUPLE: float-array
{ length array-capacity read-only } { length array-capacity read-only }
{ underlying byte-array 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 ) : <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 M: float-array clone
[ length>> ] [ underlying>> clone ] bi float-array boa ; [ length>> ] [ underlying>> clone ] bi float-array boa ;
@ -26,13 +18,13 @@ M: float-array clone
M: float-array length length>> ; M: float-array length length>> ;
M: float-array nth-unsafe M: float-array nth-unsafe
float-array@ alien-double ; underlying>> double-nth ;
M: float-array set-nth-unsafe M: float-array set-nth-unsafe
[ >float ] 2dip float-array@ set-alien-double ; [ >float ] 2dip underlying>> set-double-nth ;
: >float-array ( seq -- float-array ) : >float-array ( seq -- float-array )
T{ float-array f 0 B{ } } clone-like ; inline T{ float-array } clone-like ; inline
M: float-array like M: float-array like
drop dup float-array? [ >float-array ] unless ; drop dup float-array? [ >float-array ] unless ;
@ -45,7 +37,7 @@ M: float-array equal?
M: float-array resize M: float-array resize
[ drop ] [ [ drop ] [
[ floats>bytes ] [ underlying>> ] bi* [ "double" heap-size * ] [ underlying>> ] bi*
resize-byte-array resize-byte-array
] 2bi ] 2bi
float-array boa ; float-array boa ;
@ -58,13 +50,13 @@ INSTANCE: float-array sequence
1 <float-array> [ set-first ] keep ; flushable 1 <float-array> [ set-first ] keep ; flushable
: 2float-array ( x y -- array ) : 2float-array ( x y -- array )
T{ float-array f 0 B{ } } 2sequence ; flushable T{ float-array } 2sequence ; flushable
: 3float-array ( x y z -- array ) : 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 ) : 4float-array ( w x y z -- array )
T{ float-array f 0 B{ } } 4sequence ; flushable T{ float-array } 4sequence ; flushable
: F{ ( parsed -- parsed ) : F{ ( parsed -- parsed )
\ } [ >float-array ] parse-literal ; parsing \ } [ >float-array ] parse-literal ; parsing

4
extra/lists/tags.txt
View File

@ -1,3 +1 @@
cons collections
lists
sequences

29
extra/lsys/ui/ui.factor
View File

@ -17,7 +17,7 @@ USING: kernel namespaces threads math math.order math.vectors
self pos ori turtle opengl.camera self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret lsys.strings.rewrite lsys.strings.interpret
combinators.short-circuit ; combinators.short-circuit accessors ;
! lsys.strings ! lsys.strings
! lsys.strings.rewrite ! lsys.strings.rewrite
@ -99,6 +99,8 @@ DEFER: empty-model
: lsys-controller ( -- ) : lsys-controller ( -- )
<pile>
{ {
[ "Load" <label> reverse-video-theme ] [ "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 ] [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action <bevel-button> ] 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 ( -- ) : model-chooser ( -- )
<pile>
{ {
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ] [ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2 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> ] [ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
[ "spiral-0" <label> [ drop spiral-0 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> ] [ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
} make* }
[ [ gadget, ] curry ] map concat ! Hack [ call add-gadget ] each
make-pile 1 over set-pack-fill "L-system models" open-window ; 1 >>fill
"L-system models" open-window ;
: scene-chooser ( -- ) : scene-chooser ( -- )
<pile>
{ {
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ] [ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2-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> ] [ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
} make* }
[ [ gadget, ] curry ] map concat ! Hack [ call add-gadget ] each
make-pile 1 over set-pack-fill "L-system scenes" open-window ; 1 >>fill
"L-system scenes" open-window ;
: lsys-window* ( -- ) : lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ; [ lsys-controller lsys-viewer ] with-ui ;

12
extra/math/physics/pos/pos.factor
View File

@ -1,5 +1,17 @@
USING: kernel sequences multi-methods accessors math.vectors ;
IN: math.physics.pos IN: math.physics.pos
TUPLE: pos pos ; TUPLE: pos pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: distance ( a b -- c )
METHOD: distance { sequence sequence } v- norm ;
METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

12
extra/nehe/nehe.factor
View File

@ -4,12 +4,12 @@ IN: nehe
: nehe-window ( -- ) : nehe-window ( -- )
[ [
[ <filled-pile>
"Nehe 2" [ drop run2 ] <bevel-button> gadget, "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
"Nehe 3" [ drop run3 ] <bevel-button> gadget, "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
"Nehe 4" [ drop run4 ] <bevel-button> gadget, "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
"Nehe 5" [ drop run5 ] <bevel-button> gadget, "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
] make-filled-pile "Nehe examples" open-window "Nehe examples" open-window
] with-ui ; ] with-ui ;
MAIN: nehe-window MAIN: nehe-window

10
extra/optimizer/debugger/debugger.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes inference inference.dataflow io kernel USING: classes io kernel kernel.private math.parser namespaces
kernel.private math.parser namespaces optimizer prettyprint optimizer prettyprint prettyprint.backend sequences words arrays
prettyprint.backend sequences words arrays match macros match macros assocs sequences.private generic combinators
assocs sequences.private optimizer.specializers generic sorting math quotations accessors inference inference.dataflow
combinators sorting math quotations accessors ; optimizer.specializers ;
IN: optimizer.debugger IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for ! A simple tool for turning dataflow IR into quotations, for

46
extra/springies/springies.factor
View File

@ -28,16 +28,10 @@ VAR: gravity
! node ! node
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TUPLE: node mass elas pos vel force ;
TUPLE: node < vel mass elas force ; TUPLE: node < vel mass elas force ;
C: <node> node C: <node> node
! : >>pos ( node pos -- node ) over set-node-pos ;
! : >>vel ( node vel -- node ) over set-node-vel ;
: node-vel ( node -- vel ) vel>> ; : node-vel ( node -- vel ) vel>> ;
: set-node-vel ( vel node -- ) swap >>vel drop ; : set-node-vel ( vel node -- ) swap >>vel drop ;
@ -52,9 +46,9 @@ C: <node> node
: >>vel-x ( node x -- node ) over vel>> set-first ; : >>vel-x ( node x -- node ) over vel>> set-first ;
: >>vel-y ( node y -- node ) over vel>> set-second ; : >>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 ; : node-id ( id -- node ) 1- nodes> nth ;
@ -67,12 +61,12 @@ TUPLE: spring rest-length k damp node-a node-b ;
C: <spring> spring C: <spring> spring
: end-points ( spring -- b-pos a-pos ) : end-points ( spring -- b-pos a-pos )
[ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
: spring-length ( spring -- length ) end-points v- norm ; : spring-length ( spring -- length ) end-points v- norm ;
: stretch-length ( spring -- length ) : stretch-length ( spring -- length )
[ spring-length ] [ spring-rest-length ] bi - ; [ spring-length ] [ rest-length>> ] bi - ;
: dir ( spring -- vec ) end-points v- normalize ; : dir ( spring -- vec ) end-points v- normalize ;
@ -87,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-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
: hooke-forces ( spring -- a b ) hooke-force dup vneg ; : hooke-forces ( spring -- a b ) hooke-force dup vneg ;
: act-on-nodes-hooke ( spring -- ) : 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
apply-force ; apply-force ;
@ -118,37 +112,37 @@ C: <spring> spring
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-velocity-a ( spring -- vel ) : relative-velocity-a ( spring -- vel )
[ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
: unit-vec-b->a ( spring -- vec ) : unit-vec-b->a ( spring -- vec )
[ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
: relative-velocity-along-spring-a ( spring -- vel ) : relative-velocity-along-spring-a ( spring -- vel )
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
: damping-force-a ( spring -- vec ) : 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 ) : relative-velocity-b ( spring -- vel )
[ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
: unit-vec-a->b ( spring -- vec ) : unit-vec-a->b ( spring -- vec )
[ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
: relative-velocity-along-spring-b ( spring -- vel ) : relative-velocity-along-spring-b ( spring -- vel )
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
: damping-force-b ( spring -- vec ) : 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 -- ) : act-on-nodes-damping ( spring -- )
dup dup
[ spring-node-a ] [ damping-force-a ] bi apply-force [ node-a>> ] [ damping-force-a ] bi apply-force
[ spring-node-b ] [ damping-force-b ] bi apply-force ; [ node-b>> ] [ damping-force-b ] bi apply-force ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -164,22 +158,22 @@ C: <spring> spring
: bounce-top ( node -- ) : bounce-top ( node -- )
world-height 1- >>pos-y world-height 1- >>pos-y
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
drop ; drop ;
: bounce-bottom ( node -- ) : bounce-bottom ( node -- )
0 >>pos-y 0 >>pos-y
dup [ vel-y ] [ node-elas ] bi * neg >>vel-y dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
drop ; drop ;
: bounce-left ( node -- ) : bounce-left ( node -- )
0 >>pos-x 0 >>pos-x
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
drop ; drop ;
: bounce-right ( node -- ) : bounce-right ( node -- )
world-width 1- >>pos-x world-width 1- >>pos-x
dup [ vel-x ] [ node-elas ] bi * neg >>vel-x dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
drop ; drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -213,7 +207,7 @@ C: <spring> spring
! F = ma ! 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 ) : new-vel ( node -- vel )
[ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
@ -223,7 +217,7 @@ C: <spring> spring
: iterate-node ( node -- ) : iterate-node ( node -- )
dup new-pos >>pos dup new-pos >>pos
dup new-vel >>vel dup new-vel >>vel
dup reset-force reset-force
handle-bounce ; handle-bounce ;
: iterate-nodes ( -- ) nodes> [ iterate-node ] each ; : iterate-nodes ( -- ) nodes> [ iterate-node ] each ;

2
extra/ui/gadgets/books/books.factor
View File

@ -19,7 +19,7 @@ M: book model-changed
: new-book ( pages model class -- book ) : new-book ( pages model class -- book )
new-gadget new-gadget
swap >>model swap >>model
[ add-gadgets ] keep ; inline [ swap add-gadgets drop ] keep ; inline
: <book> ( pages model -- book ) : <book> ( pages model -- book )
book new-book ; book new-book ;

2
extra/ui/gadgets/borders/borders.factor
View File

@ -10,7 +10,7 @@ TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ; { align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border ) : new-border ( child class -- border )
new-gadget [ add-gadget ] keep ; inline new-gadget [ swap add-gadget drop ] keep ; inline
: <border> ( child gap -- border ) : <border> ( child gap -- border )
swap border new-border swap border new-border

37
extra/ui/gadgets/buttons/buttons.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect ; ui.render math.geometry.rect ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;
@ -187,9 +188,9 @@ M: radio-control model-changed
over set-button-selected? over set-button-selected?
relayout-1 ; relayout-1 ;
: <radio-controls> ( model assoc quot -- ) : <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- ) #! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
@ -202,14 +203,18 @@ M: radio-control model-changed
{ 5 5 } >>gap drop ; { 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget ) : <radio-buttons> ( model assoc -- gadget )
[ [ <radio-button> ] <radio-controls> ] make-filled-pile <filled-pile>
dup radio-buttons-theme ; -rot
[ <radio-button> ] <radio-controls>
dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ; <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
[ [ <toggle-button> ] <radio-controls> ] make-shelf ; <shelf>
-rot
[ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot ) : command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ; [ invoke-command drop ] 2curry ;
@ -221,9 +226,9 @@ M: radio-control model-changed
<bevel-button> ; <bevel-button> ;
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
[ <shelf>
"toolbar" over class command-map commands>> swap swap
[ -rot <command-button> gadget, ] curry assoc-each "toolbar" over class command-map commands>> swap
] make-shelf ; [ -rot <command-button> add-gadget ] curry assoc-each ;
: toolbar, ( -- ) g <toolbar> f track, ; : toolbar, ( -- ) g <toolbar> f track, ;

16
extra/ui/gadgets/gadgets-tests.factor
View File

@ -9,9 +9,9 @@ io.streams.string math.geometry.rect ;
! c contains b contains a ! c contains b contains a
<gadget> "a" set <gadget> "a" set
<gadget> "b" set <gadget> "b" set
"a" get "b" get add-gadget "a" get "b" get swap add-gadget drop
<gadget> "c" set <gadget> "c" set
"b" get "c" get add-gadget "b" get "c" get swap add-gadget drop
! position a and b ! position a and b
{ 100 200 } "a" get set-rect-loc { 100 200 } "a" get set-rect-loc
@ -33,8 +33,8 @@ io.streams.string math.geometry.rect ;
<gadget> "g3" set <gadget> "g3" set
{ 100 200 } "g3" get set-rect-dim { 100 200 } "g3" get set-rect-dim
"g1" get "g2" get add-gadget "g1" get "g2" get swap add-gadget drop
"g2" get "g3" get add-gadget "g2" get "g3" get swap add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@ -49,11 +49,11 @@ io.streams.string math.geometry.rect ;
<gadget> "g1" set <gadget> "g1" set
{ 300 300 } "g1" get set-rect-dim { 300 300 } "g1" get set-rect-dim
<gadget> "g2" set <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-loc
{ 20 20 } "g2" get set-rect-dim { 20 20 } "g2" get set-rect-dim
<gadget> "g3" set <gadget> "g3" set
"g3" get "g1" get add-gadget "g3" get "g1" get swap add-gadget drop
{ 100 100 } "g3" get set-rect-loc { 100 100 } "g3" get set-rect-loc
{ 20 20 } "g3" get set-rect-dim { 20 20 } "g3" get set-rect-dim
@ -66,7 +66,7 @@ io.streams.string math.geometry.rect ;
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set <gadget> "g4" set
"g4" get "g2" get add-gadget "g4" get "g2" get swap add-gadget drop
{ 5 5 } "g4" get set-rect-loc { 5 5 } "g4" get set-rect-loc
{ 1 1 } "g4" get set-rect-dim { 1 1 } "g4" get set-rect-dim
@ -123,7 +123,7 @@ M: mock-gadget ungraft*
: add-some-children : add-some-children
3 [ 3 [
<mock-gadget> over <model> over set-gadget-model <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 swap 1+ number>string set
] each ; ] each ;

131
extra/ui/gadgets/gadgets.factor
View File

@ -12,10 +12,10 @@ SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: gadget < rect TUPLE: gadget < rect
pref-dim parent children orientation focus pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node visible? root? clipped? layout-state graft-state graft-node
interior boundary interior boundary
model ; model ;
M: gadget equal? 2drop f ; M: gadget equal? 2drop f ;
@ -23,9 +23,9 @@ M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ; 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-gadget ( class -- gadget )
new new
@ -37,7 +37,7 @@ M: gadget model-changed 2drop ;
gadget new-gadget ; gadget new-gadget ;
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ dup model>> dup [
2dup add-connection 2dup add-connection
swap model-changed swap model-changed
] [ ] [
@ -45,20 +45,20 @@ M: gadget model-changed 2drop ;
] if ; ] if ;
: deactivate-control ( gadget -- ) : deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ; dup model>> dup [ 2dup remove-connection ] when 2drop ;
: control-value ( control -- value ) : control-value ( control -- value )
gadget-model model-value ; model>> model-value ;
: set-control-value ( value control -- ) : set-control-value ( value control -- )
gadget-model set-model ; model>> set-model ;
: relative-loc ( fromgadget togadget -- loc ) : relative-loc ( fromgadget togadget -- loc )
2dup eq? [ 2dup eq? [
2drop { 0 0 } 2drop { 0 0 }
] [ ] [
over rect-loc >r over rect-loc >r
>r gadget-parent r> relative-loc >r parent>> r> relative-loc
r> v+ r> v+
] if ; ] if ;
@ -68,22 +68,18 @@ M: gadget user-input* 2drop t ;
GENERIC: children-on ( rect/point gadget -- seq ) 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 ) : (fast-children-on) ( dim axis gadgets -- i )
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ; swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
: fast-children-on ( rect axis children -- from to ) : fast-children-on ( rect axis children -- from to )
3dup [ >r >r rect-loc r> r> (fast-children-on) 0 or ]
>r >r dup rect-loc swap rect-dim v+ [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
r> r> (fast-children-on) ?1+ 3bi ;
>r
>r >r rect-loc
r> r> (fast-children-on) 0 or
r> ;
: inside? ( bounds gadget -- ? ) : inside? ( bounds gadget -- ? )
dup gadget-visible? [ intersects? ] [ 2drop f ] if ; dup visible?>> [ intersects? ] [ 2drop f ] if ;
: (pick-up) ( point gadget -- gadget ) : (pick-up) ( point gadget -- gadget )
dupd children-on [ inside? ] with find-last nip ; dupd children-on [ inside? ] with find-last nip ;
@ -97,10 +93,10 @@ M: gadget children-on nip gadget-children ;
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ; : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
: orient ( gadget seq1 seq2 -- seq ) : 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 -- ) : each-child ( gadget quot -- )
>r gadget-children r> each ; inline >r children>> r> each ; inline
! Selection protocol ! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? ) GENERIC: gadget-selection? ( gadget -- ? )
@ -117,14 +113,14 @@ GENERIC: gadget-text* ( gadget -- )
GENERIC: gadget-text-separator ( gadget -- str ) GENERIC: gadget-text-separator ( gadget -- str )
M: gadget gadget-text-separator M: gadget gadget-text-separator
gadget-orientation { 0 1 } = "\n" "" ? ; orientation>> { 0 1 } = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- ) : gadget-seq-text ( seq gadget -- )
gadget-text-separator swap gadget-text-separator swap
[ dup % ] [ gadget-text* ] interleave drop ; [ dup % ] [ gadget-text* ] interleave drop ;
M: gadget gadget-text* M: gadget gadget-text*
dup gadget-children swap gadget-seq-text ; dup children>> swap gadget-seq-text ;
M: array gadget-text* M: array gadget-text*
[ gadget-text* ] each ; [ gadget-text* ] each ;
@ -132,9 +128,9 @@ M: array gadget-text*
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- ) : 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 ; : layout-queue ( -- queue ) \ layout-queue get ;
@ -147,22 +143,22 @@ M: array gadget-text*
DEFER: relayout DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over set-gadget-layout-state \ invalidate* over (>>layout-state)
dup forget-pref-dim dup forget-pref-dim
dup gadget-root? dup gadget-root?
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ; [ layout-later ] [ parent>> [ relayout ] when* ] if ;
: relayout ( gadget -- ) : relayout ( gadget -- )
dup gadget-layout-state \ invalidate* eq? dup layout-state>> \ invalidate* eq?
[ drop ] [ invalidate* ] if ; [ drop ] [ invalidate* ] if ;
: relayout-1 ( gadget -- ) : relayout-1 ( gadget -- )
dup gadget-layout-state dup layout-state>>
[ drop ] [ dup invalidate layout-later ] if ; [ 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 -- ) : (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim = >r 2dup rect-dim =
@ -178,11 +174,11 @@ DEFER: relayout
GENERIC: pref-dim* ( gadget -- dim ) GENERIC: pref-dim* ( gadget -- dim )
: ?set-gadget-pref-dim ( dim gadget -- ) : ?set-gadget-pref-dim ( dim gadget -- )
dup gadget-layout-state dup layout-state>>
[ 2drop ] [ set-gadget-pref-dim ] if ; [ 2drop ] [ (>>pref-dim) ] if ;
: pref-dim ( gadget -- dim ) : pref-dim ( gadget -- dim )
dup gadget-pref-dim [ ] [ dup pref-dim>> [ ] [
[ pref-dim* dup ] keep ?set-gadget-pref-dim [ pref-dim* dup ] keep ?set-gadget-pref-dim
] ?if ; ] ?if ;
@ -196,10 +192,10 @@ M: gadget layout* drop ;
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; : 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 -- ) : layout ( gadget -- )
dup gadget-layout-state [ dup layout-state>> [
dup validate dup validate
dup layout* dup layout*
dup [ layout ] each-child dup [ layout ] each-child
@ -223,7 +219,7 @@ M: gadget layout* drop ;
{ t f } (queue-graft) ; { t f } (queue-graft) ;
: graft-later ( gadget -- ) : graft-later ( gadget -- )
dup gadget-graft-state { dup graft-state>> {
{ { f t } [ drop ] } { { f t } [ drop ] }
{ { t t } [ drop ] } { { t t } [ drop ] }
{ { t f } [ unqueue-graft ] } { { t f } [ unqueue-graft ] }
@ -231,7 +227,7 @@ M: gadget layout* drop ;
} case ; } case ;
: ungraft-later ( gadget -- ) : ungraft-later ( gadget -- )
dup gadget-graft-state { dup graft-state>> {
{ { f f } [ drop ] } { { f f } [ drop ] }
{ { t f } [ drop ] } { { t f } [ drop ] }
{ { f t } [ unqueue-graft ] } { { f t } [ unqueue-graft ] }
@ -255,11 +251,11 @@ M: gadget ungraft* drop ;
: (unparent) ( gadget -- ) : (unparent) ( gadget -- )
dup ungraft dup ungraft
dup forget-pref-dim dup forget-pref-dim
f swap set-gadget-parent ; f swap (>>parent) ;
: unfocus-gadget ( child gadget -- ) : unfocus-gadget ( child gadget -- )
tuck gadget-focus eq? tuck focus>> eq?
[ f swap set-gadget-focus ] [ drop ] if ; [ f swap (>>focus) ] [ drop ] if ;
SYMBOL: in-layout? SYMBOL: in-layout?
@ -270,10 +266,10 @@ SYMBOL: in-layout?
: unparent ( gadget -- ) : unparent ( gadget -- )
not-in-layout not-in-layout
[ [
dup gadget-parent dup [ dup parent>> dup [
over (unparent) over (unparent)
[ unfocus-gadget ] 2keep [ unfocus-gadget ] 2keep
[ gadget-children delete ] keep [ children>> delete ] keep
relayout relayout
] [ ] [
2drop 2drop
@ -282,32 +278,37 @@ SYMBOL: in-layout?
: (clear-gadget) ( gadget -- ) : (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child dup [ (unparent) ] each-child
f over set-gadget-focus f over (>>focus)
f swap set-gadget-children ; f swap (>>children) ;
: clear-gadget ( gadget -- ) : clear-gadget ( gadget -- )
not-in-layout not-in-layout
dup (clear-gadget) relayout ; dup (clear-gadget) relayout ;
: ((add-gadget)) ( gadget box -- ) : ((add-gadget)) ( parent child -- parent )
[ gadget-children ?push ] keep set-gadget-children ; over children>> ?push >>children ;
: (add-gadget) ( gadget box -- ) : (add-gadget) ( parent child -- parent )
over unparent dup unparent
dup pick set-gadget-parent over >>parent
[ ((add-gadget)) ] 2keep tuck ((add-gadget))
gadget-graft-state second [ graft ] [ drop ] if ; tuck graft-state>> second
[ graft ]
[ drop ]
if ;
: add-gadget ( gadget parent -- ) : add-gadget ( parent child -- parent )
not-in-layout not-in-layout
[ (add-gadget) ] keep relayout ; (add-gadget)
dup relayout ;
: add-gadgets ( seq parent -- )
: add-gadgets ( parent children -- parent )
not-in-layout not-in-layout
swap [ over (add-gadget) ] each relayout ; [ (add-gadget) ] each
dup relayout ;
: parents ( gadget -- seq ) : parents ( gadget -- seq )
[ gadget-parent ] follow ; [ parent>> ] follow ;
: each-parent ( gadget quot -- ? ) : each-parent ( gadget quot -- ? )
>r parents r> all? ; inline >r parents r> all? ; inline
@ -319,7 +320,7 @@ SYMBOL: in-layout?
parents { 0 0 } [ rect-loc v+ ] reduce ; parents { 0 0 } [ rect-loc v+ ] reduce ;
: (screen-rect) ( gadget -- loc ext ) : (screen-rect) ( gadget -- loc ext )
dup gadget-parent [ dup parent>> [
>r rect-extent r> (screen-rect) >r rect-extent r> (screen-rect)
>r tuck v+ r> vmin >r v+ r> >r tuck v+ r> vmin >r v+ r>
] [ ] [
@ -333,7 +334,7 @@ SYMBOL: in-layout?
{ {
{ [ 2dup eq? ] [ 2drop t ] } { [ 2dup eq? ] [ 2drop t ] }
{ [ dup not ] [ 2drop f ] } { [ dup not ] [ 2drop f ] }
[ gadget-parent child? ] [ parent>> child? ]
} cond ; } cond ;
GENERIC: focusable-child* ( gadget -- child/t ) GENERIC: focusable-child* ( gadget -- child/t )
@ -346,7 +347,7 @@ M: gadget focusable-child* drop t ;
GENERIC: request-focus-on ( child gadget -- ) 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 ; M: f request-focus-on 2drop ;
@ -354,9 +355,9 @@ M: f request-focus-on 2drop ;
[ focusable-child ] keep request-focus-on ; [ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq ) : focus-path ( world -- seq )
[ gadget-focus ] follow ; [ focus>> ] follow ;
: gadget, ( gadget -- ) gadget get add-gadget ; : gadget, ( gadget -- ) gadget get swap add-gadget drop ;
: g ( -- gadget ) gadget get ; : g ( -- gadget ) gadget get ;
@ -371,7 +372,7 @@ M: f request-focus-on 2drop ;
! Deprecated ! Deprecated
: set-gadget-delegate ( gadget tuple -- ) : set-gadget-delegate ( gadget tuple -- )
over [ over [
dup pick [ set-gadget-parent ] with each-child dup pick [ (>>parent) ] with each-child
] when set-delegate ; ] when set-delegate ;
: construct-gadget ( class -- tuple ) : construct-gadget ( class -- tuple )

4
extra/ui/gadgets/grids/grids.factor
View File

@ -12,7 +12,7 @@ grid
: new-grid ( children class -- grid ) : new-grid ( children class -- grid )
new-gadget new-gadget
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ; [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
inline inline
: <grid> ( children -- grid ) : <grid> ( children -- grid )
@ -21,7 +21,7 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- ) : 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 ; 3dup grid-child unparent rot grid>> nth set-nth ;
: grid-remove ( grid i j -- ) : grid-remove ( grid i j -- )

2
extra/ui/gadgets/incremental/incremental.factor
View File

@ -45,7 +45,7 @@ M: incremental pref-dim*
: add-incremental ( gadget incremental -- ) : add-incremental ( gadget incremental -- )
not-in-layout not-in-layout
2dup (add-gadget) 2dup swap (add-gadget) drop
over prefer-incremental over prefer-incremental
over layout-later over layout-later
2dup incremental-loc 2dup incremental-loc

2
extra/ui/gadgets/lists/lists.factor
View File

@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
M: list model-changed M: list model-changed
nip nip
dup clear-gadget dup clear-gadget
dup <list-items> over add-gadgets dup <list-items> over swap add-gadgets drop
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )

11
extra/ui/gadgets/menus/menus.factor
View File

@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass ) : <menu-glass> ( menu world -- glass )
menu-glass new-gadget menu-glass new-gadget
>r over menu-loc over set-rect-loc r> >r over menu-loc over set-rect-loc r>
[ add-gadget ] keep ; [ swap add-gadget drop ] keep ;
M: menu-glass layout* gadget-child prefer ; M: menu-glass layout* gadget-child prefer ;
@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ;
: show-glass ( gadget world -- ) : show-glass ( gadget world -- )
over hand-clicked set-global over hand-clicked set-global
[ hide-glass ] keep [ hide-glass ] keep
[ add-gadget ] 2keep [ swap add-gadget drop ] 2keep
set-world-glass ; set-world-glass ;
: show-menu ( gadget owner -- ) : show-menu ( gadget owner -- )
@ -48,6 +48,7 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ; faint-boundary ;
: <commands-menu> ( hook target commands -- gadget ) : <commands-menu> ( hook target commands -- gadget )
[ <filled-pile>
[ >r 2dup r> <menu-item> gadget, ] each 2drop -roll
] make-filled-pile 5 <border> menu-theme ; [ <menu-item> add-gadget ] with with each
5 <border> menu-theme ;

12
extra/ui/gadgets/panes/panes.factor
View File

@ -22,10 +22,10 @@ selection-color caret mark selecting? ;
drop ; drop ;
: add-output ( current pane -- ) : add-output ( current pane -- )
[ set-pane-output ] [ add-gadget ] 2bi ; [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
: add-current ( current pane -- ) : add-current ( current pane -- )
[ set-pane-current ] [ add-gadget ] 2bi ; [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
: prepare-line ( pane -- ) : prepare-line ( pane -- )
[ clear-selection ] [ clear-selection ]
@ -120,7 +120,7 @@ C: <pane-stream> pane-stream
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget 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 M: style-stream write-gadget
stream>> write-gadget ; stream>> write-gadget ;
@ -299,12 +299,12 @@ M: paragraph dispose drop ;
: gadget-write ( string gadget -- ) : gadget-write ( string gadget -- )
over empty? 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 ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : 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 M: paragraph stream-write
swap " " split swap " " split
@ -322,7 +322,7 @@ M: paragraph stream-write1
: gadget-format ( string style stream -- ) : gadget-format ( string style stream -- )
pick empty? 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 M: pack stream-format
gadget-format ; gadget-format ;

2
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -61,7 +61,7 @@ tools.test.ui math.geometry.rect ;
<gadget> { 600 400 } over set-rect-dim "g1" set <gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" set <gadget> { 600 10 } over set-rect-dim "g2" set
"g2" get "g1" get add-gadget "g2" get "g1" get swap add-gadget drop
"g1" get <scroller> "g1" get <scroller>
{ 300 300 } over set-rect-dim { 300 300 } over set-rect-dim

2
extra/ui/gadgets/sliders/sliders.factor
View File

@ -140,7 +140,7 @@ M: elevator layout*
: elevator, ( orientation -- ) : elevator, ( orientation -- )
dup <elevator> g-> set-slider-elevator dup <elevator> g-> set-slider-elevator
swap <thumb> g-> set-slider-thumb over add-gadget swap <thumb> g-> set-slider-thumb add-gadget
@center frame, ; @center frame, ;
: <left-button> ( -- button ) : <left-button> ( -- button )

4
extra/ui/gadgets/tabs/tabs.factor
View File

@ -16,7 +16,7 @@ DEFER: (del-page)
[ [ gadget-parent '[ , , , (del-page) ] "X" swap [ [ gadget-parent '[ , , , (del-page) ] "X" swap
<bevel-button> @right frame, ] 3keep <bevel-button> @right frame, ] 3keep
[ swapd <toggle-button> @center frame, ] dip ] make-frame [ swapd <toggle-button> @center frame, ] dip ] make-frame
swap add-gadget ; add-gadget drop ;
: redo-toggler ( tabbed -- ) : redo-toggler ( tabbed -- )
[ names>> ] [ model>> ] [ toggler>> ] tri [ names>> ] [ model>> ] [ toggler>> ] tri
@ -41,7 +41,7 @@ DEFER: (del-page)
[ [ model>> swap ] [ [ model>> swap ]
[ names>> length 1 - swap ] [ names>> length 1 - swap ]
[ toggler>> ] tri add-toggle ] [ toggler>> ] tri add-toggle ]
[ content>> add-gadget ] [ content>> swap add-gadget drop ]
[ refresh-book ] tri ; [ refresh-book ] tri ;
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )

6
extra/ui/gadgets/tracks/tracks.factor
View File

@ -47,7 +47,11 @@ M: track pref-dim*
rot gadget-orientation set-axis ; rot gadget-orientation set-axis ;
: track-add ( gadget track constraint -- ) : track-add ( gadget track constraint -- )
over track-sizes push add-gadget ; over track-sizes push swap add-gadget drop ;
: track-add* ( track gadget constraint -- track )
pick sizes>> push
add-gadget ;
: track, ( gadget constraint -- ) : track, ( gadget constraint -- )
gadget get swap track-add ; gadget get swap track-add ;

2
extra/ui/gadgets/viewports/viewports.factor
View File

@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
viewport new-gadget viewport new-gadget
swap >>model swap >>model
t >>clipped? t >>clipped?
[ add-gadget ] keep ; [ swap add-gadget drop ] keep ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- dup rect-dim viewport-gap 2 v*n v-

8
extra/ui/gadgets/worlds/worlds-tests.factor
View File

@ -18,7 +18,7 @@ namespaces models kernel ;
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
"g1" get "g2" get add-gadget "g1" get "g2" get swap add-gadget drop
[ ] [ [ ] [
"g2" get <test-world> "w" set "g2" get <test-world> "w" set
@ -33,8 +33,8 @@ namespaces models kernel ;
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
<gadget> "g3" set <gadget> "g3" set
"g1" get "g3" get add-gadget "g1" get "g3" get swap add-gadget drop
"g2" get "g3" get add-gadget "g2" get "g3" get swap add-gadget drop
[ ] [ [ ] [
"g3" get <test-world> "w" set "g3" get <test-world> "w" set
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
: <focus-test> : <focus-test>
focus-test new-gadget focus-test new-gadget
<focusing> over add-gadget ; <focusing> over swap add-gadget drop ;
M: focus-test focusable-child* gadget-child ; M: focus-test focusable-child* gadget-child ;

2
extra/ui/gadgets/wrappers/wrappers.factor
View File

@ -7,7 +7,7 @@ TUPLE: wrapper < gadget ;
: new-wrapper ( child class -- wrapper ) : new-wrapper ( child class -- wrapper )
new-gadget new-gadget
[ add-gadget ] keep ; inline [ swap add-gadget drop ] keep ; inline
: <wrapper> ( child -- border ) : <wrapper> ( child -- border )
wrapper new-wrapper ; wrapper new-wrapper ;

31
extra/ui/tools/debugger/debugger.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui ui.commands ui.gestures ui.gadgets USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
models namespaces sequences sequences words continuations models namespaces sequences sequences words continuations
debugger prettyprint ui.tools.traceback help editors ; debugger prettyprint ui.tools.traceback help editors ;
IN: ui.tools.debugger IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget ) : <restart-list> ( restarts restart-hook -- gadget )
@ -15,18 +16,18 @@ IN: ui.tools.debugger
TUPLE: debugger < track restarts ; TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget ) : <debugger-display> ( restart-list error -- gadget )
[ <filled-pile>
<pane> [ [ print-error ] with-pane ] keep gadget, <pane>
gadget, swapd tuck [ print-error ] with-pane
] make-filled-pile ; add-gadget
swap add-gadget ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
[ dup <toolbar> f track-add*
toolbar, -rot <restart-list> >>restarts
<restart-list> g-> set-debugger-restarts dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
swap <debugger-display> <scroller> 1 track,
] make-gadget ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;

90
extra/ui/tools/deploy/deploy.factor
View File

@ -1,62 +1,65 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces USING: ui.gadgets colors kernel ui.render namespaces
models models.mapping sequences ui.gadgets.buttons models models.mapping sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ; tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ; TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( -- ) : bundle-name ( parent -- parent )
deploy-name get <field> deploy-name get <field>
"Executable name:" label-on-left gadget, ; "Executable name:" label-on-left add-gadget ;
: deploy-ui ( -- ) : deploy-ui ( parent -- parent )
deploy-ui? get deploy-ui? get
"Include user interface framework" <checkbox> gadget, ; "Include user interface framework" <checkbox> add-gadget ;
: exit-when-windows-closed ( -- ) : exit-when-windows-closed ( parent -- parent )
"stop-after-last-window?" get "stop-after-last-window?" get
"Exit when last UI window closed" <checkbox> gadget, ; "Exit when last UI window closed" <checkbox> add-gadget ;
: io-settings ( -- ) : io-settings ( parent -- parent )
"Input/output support:" <label> gadget, "Input/output support:" <label> add-gadget
deploy-io get deploy-io-options <radio-buttons> gadget, ; deploy-io get deploy-io-options <radio-buttons> add-gadget ;
: reflection-settings ( -- ) : reflection-settings ( parent -- parent )
"Reflection support:" <label> gadget, "Reflection support:" <label> add-gadget
deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ; deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
: advanced-settings ( -- ) : advanced-settings ( parent -- parent )
"Advanced:" <label> gadget, "Advanced:" <label> add-gadget
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget, deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> gadget, deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> gadget, deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-random? get "Random number generator support" <checkbox> gadget, deploy-random? get "Random number generator support" <checkbox> add-gadget
deploy-word-props? get "Retain all word properties" <checkbox> gadget, deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget, deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
deploy-c-types? get "Retain all C types" <checkbox> gadget, ; deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
: deploy-settings-theme ( gadget -- ) : deploy-settings-theme ( gadget -- gadget )
{ 10 10 } >>gap { 10 10 } >>gap
1 >>fill 1 >>fill ;
drop ;
: <deploy-settings> ( vocab -- control ) : <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map [ default-config [ <model> ] assoc-map
[ [
<pile>
bundle-name bundle-name
deploy-ui deploy-ui
os macosx? [ exit-when-windows-closed ] when os macosx? [ exit-when-windows-closed ] when
io-settings io-settings
reflection-settings reflection-settings
advanced-settings advanced-settings
] make-pile dup deploy-settings-theme
namespace <mapping> over set-gadget-model deploy-settings-theme
] bind ; namespace <mapping> over set-gadget-model
]
bind ;
: find-deploy-gadget ( gadget -- deploy-gadget ) : find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ; [ deploy-gadget? ] find-parent ;
@ -101,21 +104,16 @@ deploy-gadget "toolbar" f {
{ T{ key-down f f "RET" } com-deploy } { T{ key-down f f "RET" } com-deploy }
} define-command-map } define-command-map
: buttons, ( -- )
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget ) : <deploy-gadget> ( vocab -- gadget )
deploy-gadget new-gadget deploy-gadget new-gadget
swap >>vocab over >>vocab
{ 0 1 } >>orientation { 0 1 } >>orientation
[ swap <deploy-settings> >>settings
g vocab>> <deploy-settings> dup settings>> add-gadget
g-> set-deploy-gadget-settings gadget, dup <toolbar> { 10 10 } >>gap add-gadget
buttons, deploy-settings-theme
] make-gadget
dup deploy-settings-theme
dup com-revert ; dup com-revert ;
: deploy-tool ( vocab -- ) : deploy-tool ( vocab -- )
vocab-name dup <deploy-gadget> 10 <border> vocab-name dup <deploy-gadget> 10 <border>
"Deploying \"" rot "\"" 3append open-window ; "Deploying \"" rot "\"" 3append open-window ;

2
vm/code_heap.c
View File

@ -63,6 +63,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return (CELL)get_rel_symbol(rel,literals_start); return (CELL)get_rel_symbol(rel,literals_start);
case RT_LITERAL: case RT_LITERAL:
return CREF(literals_start,REL_ARGUMENT(rel)); return CREF(literals_start,REL_ARGUMENT(rel));
case RT_IMMEDIATE:
return get(CREF(literals_start,REL_ARGUMENT(rel)));
case RT_XT: case RT_XT:
return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE: case RT_HERE:

4
vm/code_heap.h
View File

@ -12,7 +12,9 @@ typedef enum {
/* current offset */ /* current offset */
RT_HERE, RT_HERE,
/* a local label */ /* a local label */
RT_LABEL RT_LABEL,
/* immeditae literal */
RT_IMMEDIATE
} F_RELTYPE; } F_RELTYPE;
typedef enum { typedef enum {

7
vm/quotations.c
View File

@ -30,9 +30,8 @@ push the array and immediately drop it after.
in the VM. They are open-coded and no subroutine call is generated. This in the VM. They are open-coded and no subroutine call is generated. This
includes stack shufflers, some fixnum arithmetic words, and words such as tag, includes stack shufflers, some fixnum arithmetic words, and words such as tag,
slot and eq?. A primitive call is relatively expensive (two subroutine calls) slot and eq?. A primitive call is relatively expensive (two subroutine calls)
so this results in a big speedup for relatively little effort. so this results in a big speedup for relatively little effort. */
*/
bool jit_primitive_call_p(F_ARRAY *array, CELL i) bool jit_primitive_call_p(F_ARRAY *array, CELL i)
{ {
return (i + 2) == array_capacity(array) return (i + 2) == array_capacity(array)
@ -253,7 +252,7 @@ void jit_compile(CELL quot, bool relocate)
} }
default: default:
GROWABLE_ARRAY_ADD(literals,obj); GROWABLE_ARRAY_ADD(literals,obj);
EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1);
break; break;
} }
} }
@ -387,7 +386,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
break; break;
} }
default: default:
COUNT(userenv[JIT_PUSH_LITERAL],i) COUNT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],i)
break; break;
} }
} }

26
vm/run.h
View File

@ -47,29 +47,9 @@ typedef enum {
JIT_EPILOG, JIT_EPILOG,
JIT_RETURN, JIT_RETURN,
JIT_PROFILING, JIT_PROFILING,
JIT_TAG, JIT_PUSH_IMMEDIATE,
JIT_TAG_WORD,
JIT_EQP, JIT_DECLARE_WORD = 42,
JIT_EQP_WORD,
JIT_SLOT,
JIT_SLOT_WORD,
JIT_DECLARE_WORD,
JIT_DROP,
JIT_DROP_WORD,
JIT_DUP,
JIT_DUP_WORD,
JIT_TO_R,
JIT_TO_R_WORD,
JIT_FROM_R,
JIT_FROM_R_WORD,
JIT_SWAP,
JIT_SWAP_WORD,
JIT_OVER,
JIT_OVER_WORD,
JIT_FIXNUM_MINUS,
JIT_FIXNUM_MINUS_WORD,
JIT_FIXNUM_GE,
JIT_FIXNUM_GE_WORD,
STACK_TRACES_ENV = 59, STACK_TRACES_ENV = 59,