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-05 12:24:09 -07:00
parent ed8fa96c01 d532c819a2
commit eec1758fd6
57 changed files with 801 additions and 637 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/alien/alien-tests.factor
View File

@ -1,5 +1,5 @@
IN: alien.tests
USING: alien alien.accessors alien.syntax byte-arrays arrays
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts ;
@ -65,6 +65,10 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test

3
core/classes/algebra/algebra-tests.factor
View File

@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs math.order ;
random inference effects kernel.private sbufs math.order
classes.tuple ;
IN: classes.algebra.tests
\ class< must-infer

106
core/classes/algebra/algebra.factor
View File

@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ;
IN: classes.algebra
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
GENERIC: (classes-intersect?) ( first second -- ? )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
classes-intersect-cache get [
normalize-class (classes-intersect?)
] 2cache ;
DEFER: (class-and)
@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
M: anonymous-complement (classes-intersect?)
class>> class<= not ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
: (classes-intersect?) ( first second -- ? )
normalize-class {
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
} cond ;
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
GENERIC: (flatten-class) ( class -- )
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;
M: word (flatten-class)
normalize-class (flatten-class) ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@ -258,7 +222,7 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when

25
core/classes/builtin/builtin.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences math math.private ;
USING: accessors classes classes.algebra words kernel
kernel.private namespaces sequences math math.private
combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@ -31,3 +32,23 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance?
class>type builtin-instance? ;
M: builtin-class (flatten-class) dup set ;
M: builtin-class (classes-intersect?)
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
M: anonymous-intersection (flatten-class)
participants>> [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;

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

@ -65,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

3
core/classes/classes.factor
View File

@ -32,9 +32,6 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )

2
core/classes/intersection/intersection.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class

10
core/classes/predicate/predicate.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words sequences quotations
arrays kernel.private assocs combinators ;
USING: classes classes.algebra kernel namespaces words sequences
quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
M: predicate-class (flatten-class)
superclass (flatten-class) ;
M: predicate-class (classes-intersect?)
superclass classes-intersect? ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -332,6 +332,10 @@ $nl
ABOUT: "tuples"
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }

23
core/classes/tuple/tuple.factor
View File

@ -3,10 +3,13 @@
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs effects ;
classes.builtin classes.private slots.deprecated slots.private
slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
@ -135,7 +138,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ all-slots [ initial>> ] map ] keep slots>tuple ;
[ all-slots [ initial>> ] map ] keep
over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@ -289,6 +293,16 @@ M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
M: tuple-class (classes-intersect?)
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -304,7 +318,8 @@ M: tuple hashcode*
] recursive-hashcode ;
M: tuple-class new
"prototype" word-prop (clone) ;
dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]

2
core/classes/union/union.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class

2
core/generator/registers/registers.factor
View File

@ -563,7 +563,7 @@ M: loc lazy-store
] if ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
: class-matches? ( actual expected -- ? )
{

8
core/generic/standard/standard-tests.factor
View File

@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test

4
core/generic/standard/standard.factor
View File

@ -105,7 +105,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
[ order [ instance? ] with find-last nip ] keep method ;
[ [ order [ instance? ] with find-last nip ] keep method ]
[ "default-method" word-prop ]
bi or ;
TUPLE: standard-combination # ;

2
core/slots/slots-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard classes.builtin
slots.private classes strings math assocs byte-arrays alien
math ;
math classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"

2
extra/benchmark/dispatch1/dispatch1.factor
View File

@ -1,4 +1,4 @@
USING: classes kernel sequences vocabs math ;
USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )

2
extra/benchmark/dispatch5/dispatch5.factor
View File

@ -1,4 +1,4 @@
USING: classes kernel sequences vocabs math ;
USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch5
MIXIN: g

19
extra/combinators/cleave/cleave-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: kernel math math.functions tools.test combinators.cleave ;
IN: combinators.cleave.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: unit-test* ( input output -- ) swap unit-test ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*

27
extra/combinators/cleave/cleave.factor
View File

@ -1,17 +1,36 @@
USING: kernel arrays sequences macros combinators ;
USING: kernel combinators words quotations arrays sequences locals macros
shuffle combinators.lib arrays.lib fry ;
IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
: >quots ( seq -- seq ) [ >quot ] map ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: [ncleave] ( SEQ N -- quot )
SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
MACRO: ncleave ( seq n -- quot ) [ncleave] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: words quotations fry arrays.lib ;
: [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ;
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
MACRO: narr ( seq n -- array ) [narr] ;
: >quots ( seq -- seq ) [ >quot ] map ;
MACRO: 0arr ( seq -- array ) 0 [narr] ;
MACRO: 1arr ( seq -- array ) 1 [narr] ;
MACRO: 2arr ( seq -- array ) 2 [narr] ;
MACRO: 3arr ( seq -- array ) 3 [narr] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi

6
extra/delegate/delegate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )

2
extra/io/unix/backend/backend.factor
View File

@ -168,7 +168,7 @@ M: stdin dispose
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
[ size>> "uint" heap-size swap io:stream-read *uint ]
[ size>> "size_t" heap-size swap io:stream-read *uint ]
bi ;
:: refill-stdin ( buffer stdin size -- )

31
extra/models/compose/compose-docs.factor Executable file
View File

@ -0,0 +1,31 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar models ;
IN: models.compose
HELP: compose
{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."
$nl
"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
{ $examples
"The following code displays a pair of sliders, and an updating label showing their current values:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
": <funny-slider> <x-slider> 100 over set-slider-max ;"
"<funny-slider> <funny-slider> 2array"
"dup make-pile gadget."
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
"<label-control> gadget."
}
} ;
HELP: <compose>
{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
{ $examples "See the example in the documentation for " { $link compose } "." } ;
ARTICLE: "models-compose" "Composed models"
"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."
{ $subsection compose }
{ $subsection <compose> } ;
ABOUT: "models-compose"

24
extra/models/compose/compose-tests.factor Executable file
View File

@ -0,0 +1,24 @@
IN: models.compose.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.compose ;
! Test compose
[ ] [
1 <model> "a" set
2 <model> "b" set
"a" get "b" get 2array <compose> "c" set
] unit-test
[ ] [ "c" get activate-model ] unit-test
[ { 1 2 } ] [ "c" get model-value ] unit-test
[ ] [ 3 "b" get set-model ] unit-test
[ { 1 3 } ] [ "c" get model-value ] unit-test
[ ] [ { 4 5 } "c" get set-model ] unit-test
[ { 4 5 } ] [ "c" get model-value ] unit-test
[ ] [ "c" get deactivate-model ] unit-test

49
extra/models/compose/compose.factor Executable file
View File

@ -0,0 +1,49 @@
USING: models kernel sequences ;
IN: models.compose
TUPLE: compose ;
: <compose> ( models -- compose )
f compose construct-model
swap clone over set-model-dependencies ;
: composed-value >r model-dependencies r> map ; inline
: set-composed-value >r model-dependencies r> 2each ; inline
M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ;
M: compose model-activated dup model-changed ;
M: compose update-model
dup model-value swap [ set-model ] set-composed-value ;
M: compose range-value
[ range-value ] composed-value ;
M: compose range-page-value
[ range-page-value ] composed-value ;
M: compose range-min-value
[ range-min-value ] composed-value ;
M: compose range-max-value
[ range-max-value ] composed-value ;
M: compose range-max-value*
[ range-max-value* ] composed-value ;
M: compose set-range-value
[ clamp-value ] keep
[ set-range-value ] set-composed-value ;
M: compose set-range-page-value
[ set-range-page-value ] set-composed-value ;
M: compose set-range-min-value
[ set-range-min-value ] set-composed-value ;
M: compose set-range-max-value
[ set-range-max-value ] set-composed-value ;

29
extra/models/delay/delay-docs.factor Executable file
View File

@ -0,0 +1,29 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar models ;
IN: models.delay
HELP: delay
{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
{ $examples
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
"<label-control> gadget."
}
} ;
HELP: <delay>
{ $values { "model" model } { "timeout" duration } { "delay" delay } }
{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
{ $examples "See the example in the documentation for " { $link delay } "." } ;
ARTICLE: "models-delay" "Delay models"
"Delay models are used to implement delayed updating of gadgets in response to user input."
{ $subsection delay }
{ $subsection <delay> } ;
ABOUT: "models-delay"

25
extra/models/delay/delay.factor Executable file
View File

@ -0,0 +1,25 @@
USING: kernel models alarms ;
IN: models.delay
TUPLE: delay model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
: <delay> ( model timeout -- delay )
f delay construct-model
[ set-delay-timeout ] keep
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
: cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup [ f over set-delay-alarm update-delay-model ] curry
over delay-timeout later
swap set-delay-alarm ;
M: delay model-changed nip dup cancel-delay start-delay ;
M: delay model-activated update-delay-model ;

27
extra/models/filter/filter-docs.factor Executable file
View File

@ -0,0 +1,27 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar models ;
IN: models.filter
HELP: filter
{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }
{ $examples
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
"<label-control> gadget."
}
"An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
} ;
HELP: <filter>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
{ $examples "See the example in the documentation for " { $link filter } "." } ;
ARTICLE: "models-filter" "Filter models"
"Filter model values are computed by applying a quotation to the value of another model."
{ $subsection filter }
{ $subsection <filter> } ;
ABOUT: "models-filter"

24
extra/models/filter/filter-tests.factor Executable file
View File

@ -0,0 +1,24 @@
IN: models.filter.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.filter ;
! Test multiple filters
3 <model> "x" set
"x" get [ 2 * ] <filter> dup "z" set
[ 1+ ] <filter> "y" set
[ ] [ "y" get activate-model ] unit-test
[ t ] [ "z" get "x" get model-connections memq? ] unit-test
[ 7 ] [ "y" get model-value ] unit-test
[ ] [ 4 "x" get set-model ] unit-test
[ 9 ] [ "y" get model-value ] unit-test
[ ] [ "y" get deactivate-model ] unit-test
[ f ] [ "z" get "x" get model-connections memq? ] unit-test
3 <model> "x" set
"x" get [ sq ] <filter> "y" set
4 "x" get set-model
"y" get activate-model
[ 16 ] [ "y" get model-value ] unit-test
"y" get deactivate-model

16
extra/models/filter/filter.factor Executable file
View File

@ -0,0 +1,16 @@
USING: models kernel ;
IN: models.filter
TUPLE: filter model quot ;
: <filter> ( model quot -- filter )
f filter construct-model
[ set-filter-quot ] keep
[ set-filter-model ] 2keep
[ add-dependency ] keep ;
M: filter model-changed
swap model-value over filter-quot call
swap set-model ;
M: filter model-activated dup filter-model swap model-changed ;

36
extra/models/history/history-docs.factor Executable file
View File

@ -0,0 +1,36 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar models ;
IN: models.history
HELP: history
{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
HELP: <history>
{ $values { "value" object } { "history" "a new " { $link history } } }
{ $description "Creates a new history model with an initial value." } ;
{ <history> add-history go-back go-forward } related-words
HELP: go-back
{ $values { "history" history } }
{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: go-forward
{ $values { "history" history } }
{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: add-history
{ $values { "history" history } }
{ $description "Adds the current value to the history." } ;
ARTICLE: "models-history" "History models"
"History models record previous values."
{ $subsection history }
{ $subsection <history> }
"Recording history:"
{ $subsection add-history }
"Navigating the history:"
{ $subsection go-back }
{ $subsection go-forward } ;
ABOUT: "models-history"

37
extra/models/history/history-tests.factor Executable file
View File

@ -0,0 +1,37 @@
IN: models.history.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.history ;
f <history> "history" set
"history" get add-history
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
3 "history" get set-model
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
4 "history" get set-model
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get go-back
[ 3 ] [ "history" get model-value ] unit-test
[ t ] [ "history" get history-back empty? ] unit-test
[ f ] [ "history" get history-forward empty? ] unit-test
"history" get go-forward
[ 4 ] [ "history" get model-value ] unit-test
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test

29
extra/models/history/history.factor Executable file
View File

@ -0,0 +1,29 @@
USING: kernel models sequences ;
IN: models.history
TUPLE: history back forward ;
: reset-history ( history -- )
V{ } clone over set-history-back
V{ } clone swap set-history-forward ;
: <history> ( value -- history )
history construct-model dup reset-history ;
: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
[ 3drop ]
[ >r dupd (add-history) r> pop swap set-model ] if ;
: go-back ( history -- )
dup history-forward over history-back go-back/forward ;
: go-forward ( history -- )
dup history-back over history-forward go-back/forward ;
: add-history ( history -- )
dup history-forward delete-all
dup history-back (add-history) ;

34
extra/models/mapping/mapping-tests.factor Executable file
View File

@ -0,0 +1,34 @@
IN: models.mapping.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.mapping ;
! Test mapping
[ ] [
[
1 <model> "one" set
2 <model> "two" set
] H{ } make-assoc
<mapping> "m" set
] unit-test
[ ] [ "m" get activate-model ] unit-test
[ H{ { "one" 1 } { "two" 2 } } ] [
"m" get model-value
] unit-test
[ ] [
H{ { "one" 3 } { "two" 4 } }
"m" get set-model
] unit-test
[ H{ { "one" 3 } { "two" 4 } } ] [
"m" get model-value
] unit-test
[ H{ { "one" 5 } { "two" 4 } } ] [
5 "one" "m" get mapping-assoc at set-model
"m" get model-value
] unit-test
[ ] [ "m" get deactivate-model ] unit-test

20
extra/models/mapping/mapping.factor Executable file
View File

@ -0,0 +1,20 @@
USING: models kernel assocs ;
IN: models.mapping
TUPLE: mapping assoc ;
: <mapping> ( models -- mapping )
f mapping construct-model
over values over set-model-dependencies
tuck set-mapping-assoc ;
M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
M: mapping model-activated dup model-changed ;
M: mapping update-model
dup model-value swap mapping-assoc
[ swapd at set-model ] curry assoc-each ;

172
extra/models/models-docs.factor
View File

@ -5,10 +5,10 @@ IN: models
HELP: model
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
{ $list
{ { $link model-value } " - the value of the model. Use " { $link set-model } " to change the value." }
{ { $link model-connections } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
{ { $link model-dependencies } " - a sequence of models which should have this model added to their sequence of connections when activated." }
{ { $link model-ref } " - a reference count tracking the number of models which depend on this one." }
{ { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
{ { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
{ { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
{ { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
}
"Other classes may delegate to " { $link model } "."
} ;
@ -79,84 +79,6 @@ HELP: (change-model)
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
HELP: filter
{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }
{ $examples
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
"<label-control> gadget."
}
"An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
} ;
HELP: <filter>
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
{ $examples "See the example in the documentation for " { $link filter } "." } ;
HELP: compose
{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."
$nl
"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
{ $examples
"The following code displays a pair of sliders, and an updating label showing their current values:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
": <funny-slider> <x-slider> 100 over set-slider-max ;"
"<funny-slider> <funny-slider> 2array"
"dup make-pile gadget."
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
"<label-control> gadget."
}
} ;
HELP: <compose>
{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
{ $examples "See the example in the documentation for " { $link compose } "." } ;
HELP: history
{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
HELP: <history>
{ $values { "value" object } { "history" "a new " { $link history } } }
{ $description "Creates a new history model with an initial value." } ;
{ <history> add-history go-back go-forward } related-words
HELP: go-back
{ $values { "history" history } }
{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: go-forward
{ $values { "history" history } }
{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: add-history
{ $values { "history" history } }
{ $description "Adds the current value to the history." } ;
HELP: delay
{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
{ $examples
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
{ $code
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
"<label-control> gadget."
}
} ;
HELP: <delay>
{ $values { "model" model } { "timeout" duration } { "delay" delay } }
{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
{ $examples "See the example in the documentation for " { $link delay } "." } ;
HELP: range-value
{ $values { "model" model } { "value" object } }
{ $contract "Outputs the current value of a range model." } ;
@ -197,40 +119,6 @@ HELP: set-range-max-value
{ $description "Sets the maximum value of a range model." }
{ $side-effects "model" } ;
HELP: range
{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
HELP: range-model
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's current value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-min
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's minimum value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-max
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's maximum value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-page
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's page size." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: move-by
{ $values { "amount" real } { "range" range } }
{ $description "Adds a number to a range model's current value." }
{ $side-effects "range" } ;
HELP: move-by-page
{ $values { "amount" real } { "range" range } }
{ $description "Adds a multiple of the page size to a range model's current value." }
{ $side-effects "range" } ;
ARTICLE: "models" "Models"
"The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values."
$nl
@ -246,60 +134,10 @@ $nl
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
{ $subsection activate-model }
{ $subsection deactivate-model }
"Special types of models:"
{ $subsection "models-filter" }
{ $subsection "models-compose" }
{ $subsection "models-history" }
{ $subsection "models-delay" }
{ $subsection "models-range" }
{ $subsection "models-impl" } ;
ARTICLE: "models-filter" "Filter models"
"Filter model values are computed by applying a quotation to the value of another model."
{ $subsection filter }
{ $subsection <filter> } ;
ARTICLE: "models-compose" "Composed models"
"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."
{ $subsection compose }
{ $subsection <compose> } ;
ARTICLE: "models-history" "History models"
"History models record previous values."
{ $subsection history }
{ $subsection <history> }
"Recording history:"
{ $subsection add-history }
"Navigating the history:"
{ $subsection go-back }
{ $subsection go-forward } ;
ARTICLE: "models-delay" "Delay models"
"Delay models are used to implement delayed updating of gadgets in response to user input."
{ $subsection delay }
{ $subsection <delay> } ;
ARTICLE: "models-range" "Range models"
"Range models ensure their value is a real number within a fixed range."
{ $subsection range }
{ $subsection <range> }
"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
{ $subsection "range-model-protocol" } ;
ARTICLE: "range-model-protocol" "Range model protocol"
"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
{ $subsection range-value }
{ $subsection range-page-value }
{ $subsection range-min-value }
{ $subsection range-max-value }
{ $subsection range-max-value* }
{ $subsection set-range-value }
{ $subsection set-range-page-value }
{ $subsection set-range-min-value }
{ $subsection set-range-max-value } ;
ARTICLE: "models-impl" "Implementing models"
"New types of models can be defined, along the lines of " { $link filter } " and such."
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
$nl
"Models can execute hooks when activated:"
{ $subsection model-activated }

141
extra/models/models-tests.factor
View File

@ -31,144 +31,3 @@ T{ model-tester f f } "tester" set
"tester" get
"model-c" get model-value
] unit-test
f <history> "history" set
"history" get add-history
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
3 "history" get set-model
[ t ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get add-history
4 "history" get set-model
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
"history" get go-back
[ 3 ] [ "history" get model-value ] unit-test
[ t ] [ "history" get history-back empty? ] unit-test
[ f ] [ "history" get history-forward empty? ] unit-test
"history" get go-forward
[ 4 ] [ "history" get model-value ] unit-test
[ f ] [ "history" get history-back empty? ] unit-test
[ t ] [ "history" get history-forward empty? ] unit-test
! Test multiple filters
3 <model> "x" set
"x" get [ 2 * ] <filter> dup "z" set
[ 1+ ] <filter> "y" set
[ ] [ "y" get activate-model ] unit-test
[ t ] [ "z" get "x" get model-connections memq? ] unit-test
[ 7 ] [ "y" get model-value ] unit-test
[ ] [ 4 "x" get set-model ] unit-test
[ 9 ] [ "y" get model-value ] unit-test
[ ] [ "y" get deactivate-model ] unit-test
[ f ] [ "z" get "x" get model-connections memq? ] unit-test
3 <model> "x" set
"x" get [ sq ] <filter> "y" set
4 "x" get set-model
"y" get activate-model
[ 16 ] [ "y" get model-value ] unit-test
"y" get deactivate-model
! Test compose
[ ] [
1 <model> "a" set
2 <model> "b" set
"a" get "b" get 2array <compose> "c" set
] unit-test
[ ] [ "c" get activate-model ] unit-test
[ { 1 2 } ] [ "c" get model-value ] unit-test
[ ] [ 3 "b" get set-model ] unit-test
[ { 1 3 } ] [ "c" get model-value ] unit-test
[ ] [ { 4 5 } "c" get set-model ] unit-test
[ { 4 5 } ] [ "c" get model-value ] unit-test
[ ] [ "c" get deactivate-model ] unit-test
! Test mapping
[ ] [
[
1 <model> "one" set
2 <model> "two" set
] H{ } make-assoc
<mapping> "m" set
] unit-test
[ ] [ "m" get activate-model ] unit-test
[ H{ { "one" 1 } { "two" 2 } } ] [
"m" get model-value
] unit-test
[ ] [
H{ { "one" 3 } { "two" 4 } }
"m" get set-model
] unit-test
[ H{ { "one" 3 } { "two" 4 } } ] [
"m" get model-value
] unit-test
[ H{ { "one" 5 } { "two" 4 } } ] [
5 "one" "m" get mapping-assoc at set-model
"m" get model-value
] unit-test
[ ] [ "m" get deactivate-model ] unit-test
! Test <range>
: setup-range 0 0 0 255 <range> ;
! clamp-value should not go past range ends
[ 0 ] [ -10 setup-range clamp-value ] unit-test
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
[ 14 ] [ 14 setup-range clamp-value ] unit-test
! range min/max/page values should be correct
[ 0 ] [ setup-range range-page-value ] unit-test
[ 0 ] [ setup-range range-min-value ] unit-test
[ 255 ] [ setup-range range-max-value ] unit-test
! should be able to set the value within the range and get back
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
! should be able to change the range min/max/page value
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
! should be able to move by positive and negative values
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
! should be able to move by a page of 10
[ 10 ] [
setup-range 10 over set-range-page-value
1 over move-by-page range-value
] unit-test

180
extra/models/models.factor
View File

@ -1,14 +1,21 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel math sequences arrays assocs alarms
calendar math.order ;
USING: accessors generic kernel math sequences arrays assocs
alarms calendar math.order ;
IN: models
TUPLE: model < identity-tuple
value connections dependencies ref locked? ;
: new-model ( value class -- model )
new
swap >>value
V{ } clone >>connections
V{ } clone >>dependencies
0 >>ref ; inline
: <model> ( value -- model )
V{ } clone V{ } clone 0 f model boa ;
model new-model ;
M: model hashcode* drop model hashcode* ;
@ -96,107 +103,6 @@ M: model update-model drop ;
: construct-model ( value class -- instance )
>r <model> { set-delegate } r> construct ; inline
TUPLE: filter model quot ;
: <filter> ( model quot -- filter )
f filter construct-model
[ set-filter-quot ] keep
[ set-filter-model ] 2keep
[ add-dependency ] keep ;
M: filter model-changed
swap model-value over filter-quot call
swap set-model ;
M: filter model-activated dup filter-model swap model-changed ;
TUPLE: compose ;
: <compose> ( models -- compose )
f compose construct-model
swap clone over set-model-dependencies ;
: composed-value >r model-dependencies r> map ; inline
: set-composed-value >r model-dependencies r> 2each ; inline
M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ;
M: compose model-activated dup model-changed ;
M: compose update-model
dup model-value swap [ set-model ] set-composed-value ;
TUPLE: mapping assoc ;
: <mapping> ( models -- mapping )
f mapping construct-model
over values over set-model-dependencies
tuck set-mapping-assoc ;
M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
M: mapping model-activated dup model-changed ;
M: mapping update-model
dup model-value swap mapping-assoc
[ swapd at set-model ] curry assoc-each ;
TUPLE: history back forward ;
: reset-history ( history -- )
V{ } clone over set-history-back
V{ } clone swap set-history-forward ;
: <history> ( value -- history )
history construct-model dup reset-history ;
: (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
[ 3drop ]
[ >r dupd (add-history) r> pop swap set-model ] if ;
: go-back ( history -- )
dup history-forward over history-back go-back/forward ;
: go-forward ( history -- )
dup history-back over history-forward go-back/forward ;
: add-history ( history -- )
dup history-forward delete-all
dup history-back (add-history) ;
TUPLE: delay model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
: <delay> ( model timeout -- delay )
f delay construct-model
[ set-delay-timeout ] keep
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
: cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup [ f over set-delay-alarm update-delay-model ] curry
over delay-timeout later
swap set-delay-alarm ;
M: delay model-changed nip dup cancel-delay start-delay ;
M: delay model-activated update-delay-model ;
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value )
@ -207,72 +113,6 @@ GENERIC: set-range-page-value ( value model -- )
GENERIC: set-range-min-value ( value model -- )
GENERIC: set-range-max-value ( value model -- )
TUPLE: range ;
: <range> ( value min max page -- range )
4array [ <model> ] map <compose>
{ set-delegate } range construct ;
: range-model ( range -- model ) model-dependencies first ;
: range-page ( range -- model ) model-dependencies second ;
: range-min ( range -- model ) model-dependencies third ;
: range-max ( range -- model ) model-dependencies fourth ;
: clamp-value ( value range -- newvalue )
[ range-min-value max ] keep
range-max-value* min ;
M: range range-value
[ range-model model-value ] keep clamp-value ;
M: range range-page-value range-page model-value ;
M: range range-min-value range-min model-value ;
M: range range-max-value range-max model-value ;
M: range range-max-value*
dup range-max-value swap range-page-value [-] ;
M: range set-range-value
[ clamp-value ] keep range-model set-model ;
M: range set-range-page-value range-page set-model ;
M: range set-range-min-value range-min set-model ;
M: range set-range-max-value range-max set-model ;
M: compose range-value
[ range-value ] composed-value ;
M: compose range-page-value
[ range-page-value ] composed-value ;
M: compose range-min-value
[ range-min-value ] composed-value ;
M: compose range-max-value
[ range-max-value ] composed-value ;
M: compose range-max-value*
[ range-max-value* ] composed-value ;
M: compose set-range-value
[ clamp-value ] keep
[ set-range-value ] set-composed-value ;
M: compose set-range-page-value
[ set-range-page-value ] set-composed-value ;
M: compose set-range-min-value
[ set-range-min-value ] set-composed-value ;
M: compose set-range-max-value
[ set-range-max-value ] set-composed-value ;
: move-by ( amount range -- )
[ range-value + ] keep set-range-value ;
: move-by-page ( amount range -- )
[ range-page-value * ] keep move-by ;

58
extra/models/range/range-docs.factor Executable file
View File

@ -0,0 +1,58 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar models ;
IN: models.range
HELP: range
{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
HELP: range-model
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's current value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-min
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's minimum value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-max
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's maximum value." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: range-page
{ $values { "range" range } { "model" model } }
{ $description "Outputs a model holding a range model's page size." }
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
HELP: move-by
{ $values { "amount" real } { "range" range } }
{ $description "Adds a number to a range model's current value." }
{ $side-effects "range" } ;
HELP: move-by-page
{ $values { "amount" real } { "range" range } }
{ $description "Adds a multiple of the page size to a range model's current value." }
{ $side-effects "range" } ;
ARTICLE: "models-range" "Range models"
"Range models ensure their value is a real number within a fixed range."
{ $subsection range }
{ $subsection <range> }
"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
{ $subsection "range-model-protocol" } ;
ARTICLE: "range-model-protocol" "Range model protocol"
"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
{ $subsection range-value }
{ $subsection range-page-value }
{ $subsection range-min-value }
{ $subsection range-max-value }
{ $subsection range-max-value* }
{ $subsection set-range-value }
{ $subsection set-range-page-value }
{ $subsection set-range-min-value }
{ $subsection set-range-max-value } ;
ABOUT: "models-range"

36
extra/models/range/range-tests.factor Executable file
View File

@ -0,0 +1,36 @@
IN: models.range.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.range ;
! Test <range>
: setup-range 0 0 0 255 <range> ;
! clamp-value should not go past range ends
[ 0 ] [ -10 setup-range clamp-value ] unit-test
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
[ 14 ] [ 14 setup-range clamp-value ] unit-test
! range min/max/page values should be correct
[ 0 ] [ setup-range range-page-value ] unit-test
[ 0 ] [ setup-range range-min-value ] unit-test
[ 255 ] [ setup-range range-max-value ] unit-test
! should be able to set the value within the range and get back
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
! should be able to change the range min/max/page value
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
! should be able to move by positive and negative values
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
! should be able to move by a page of 10
[ 10 ] [
setup-range 10 over set-range-page-value
1 over move-by-page range-value
] unit-test

41
extra/models/range/range.factor Executable file
View File

@ -0,0 +1,41 @@
USING: kernel models arrays sequences math math.order
models.compose ;
IN: models.range
TUPLE: range ;
: <range> ( value min max page -- range )
4array [ <model> ] map <compose>
{ set-delegate } range construct ;
: range-model ( range -- model ) model-dependencies first ;
: range-page ( range -- model ) model-dependencies second ;
: range-min ( range -- model ) model-dependencies third ;
: range-max ( range -- model ) model-dependencies fourth ;
M: range range-value
[ range-model model-value ] keep clamp-value ;
M: range range-page-value range-page model-value ;
M: range range-min-value range-min model-value ;
M: range range-max-value range-max model-value ;
M: range range-max-value*
dup range-max-value swap range-page-value [-] ;
M: range set-range-value
[ clamp-value ] keep range-model set-model ;
M: range set-range-page-value range-page set-model ;
M: range set-range-min-value range-min set-model ;
M: range set-range-max-value range-max set-model ;
: move-by ( amount range -- )
[ range-value + ] keep set-range-value ;
: move-by-page ( amount range -- )
[ range-page-value * ] keep move-by ;

6
extra/newfx/newfx.factor
View File

@ -237,3 +237,9 @@ METHOD: as-mutate { object object assoc } set-at ;
: prepend! ( a b -- ba ) over append 0 pick copy ;
: prepended! ( a b -- ) over append 0 rot copy ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: insert ( seq i obj -- seq ) >r cut r> prefix append ;
: splice ( seq i seq -- seq ) >r cut r> prepend append ;

27
extra/reports/optimizer/optimizer.factor
View File

@ -2,20 +2,31 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs words sequences arrays compiler
tools.time io.styles io prettyprint vocabs kernel sorting
generator optimizer math math.order ;
generator optimizer math math.order math.statistics combinators ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: results
[ [ second ] prepose compare ] curry sort 20 tail*
print
: table. ( alist -- )
20 short tail*
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
] tabular-output ; inline
] tabular-output ;
: results ( results quot title -- )
print
[ second ] prepose
[ [ compare ] curry sort table. ]
[
map
[ "Mean: " write mean >float . ]
[ "Median: " write median >float . ]
[ "Standard deviation: " write std >float . ]
tri
] 2bi ; inline
: optimizer-measurements ( -- alist )
all-words [ compiled>> ] filter
@ -26,8 +37,10 @@ IN: report.optimizer
] { } map>assoc ;
: optimizer-measurements. ( alist -- )
[ [ first ] "Worst number of optimizer passes:" results ]
[ [ second ] "Worst compile times:" results ] bi ;
{
[ [ first ] "Optimizer passes:" results ]
[ [ second ] "Compile times:" results ]
} cleave ;
: optimizer-report ( -- )
optimizer-measurements optimizer-measurements. ;

28
extra/tools/deploy/deploy-tests.factor
View File

@ -12,42 +12,36 @@ namespaces continuations layouts accessors ;
] with-directory ;
: small-enough? ( n -- ? )
>r "test.image" temp-file file-info size>> r> <= ;
>r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test
[ t ] [
cell 8 = 8 5 ? 100000 * small-enough?
] unit-test
[ t ] [ 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
cell 8 = 20 10 ? 100000 * small-enough?
] unit-test
[ t ] [ 800000 small-enough? ] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [ 1300000 small-enough? ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
[ t ] [
cell 8 = 35 17 ? 100000 * small-enough?
] unit-test
[ ] [ "maze" shake-and-bake ] unit-test
[ t ] [
cell 8 = 30 15 ? 100000 * small-enough?
] unit-test
[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "tetris" shake-and-bake ] unit-test
[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [
cell 8 = 50 30 ? 100000 * small-enough?
] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"

37
extra/tools/deploy/shaker/shaker.factor
View File

@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
strings sets ;
strings sets vectors quotations byte-arrays ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@ -79,8 +79,8 @@ IN: tools.deploy.shaker
[
[
props>> swap
'[ drop , member? not ] assoc-filter
sift-assoc f assoc-like
'[ drop , member? not ] assoc-filter sift-assoc
dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
@ -93,7 +93,10 @@ IN: tools.deploy.shaker
"compiled-uses"
"constraints"
"declared-effect"
"default"
"default-method"
"default-output-classes"
"derived-from"
"identities"
"if-intrinsics"
"infer"
@ -103,15 +106,18 @@ IN: tools.deploy.shaker
"loc"
"members"
"methods"
"method-class"
"method-generic"
"combination"
"cannot-infer"
"default-method"
"no-compile"
"optimizer-hooks"
"output-classes"
"participants"
"predicate"
"predicate-definition"
"predicating"
"tuple-dispatch-generic"
"slots"
"slot-names"
"specializer"
@ -127,6 +133,8 @@ IN: tools.deploy.shaker
strip-prettyprint? [
{
"break-before"
"break-after"
"delimiter"
"flushable"
"foldable"
@ -265,13 +273,27 @@ IN: tools.deploy.shaker
21 setenv
] [ drop ] if ;
: compress ( pred string -- )
"Compressing " prepend show
instances
dup H{ } clone [ [ ] cache ] curry map
become ; inline
: compress-byte-arrays ( -- )
[ byte-array? ] "byte arrays" compress ;
: compress-quotations ( -- )
[ quotation? ] "quotations" compress ;
: compress-strings ( -- )
[ string? ] "strings" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
[ save-image-and-exit ] call-clear ;
@ -295,7 +317,10 @@ SYMBOL: deploy-vocab
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
r> strip-words ;
r> strip-words
compress-byte-arrays
compress-quotations
compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave

6
extra/tools/walker/walker-tests.factor
View File

@ -1,6 +1,7 @@
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug ;
continuations math.parser threads arrays tools.walker.debug
generic.standard ;
IN: tools.walker.tests
[ { } ] [
@ -97,6 +98,9 @@ IN: tools.walker.tests
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
[ { T{ no-method f + nth } } ]
[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test

6
extra/tools/walker/walker.factor
View File

@ -3,7 +3,7 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models arrays accessors
sequences.private assocs models models.filter arrays accessors
generic generic.standard definitions ;
IN: tools.walker
@ -83,6 +83,9 @@ M: object add-breakpoint ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
: (step-into-call-next-method) ( class generic -- )
next-method-quot (step-into-quot) ;
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
@ -132,6 +135,7 @@ SYMBOL: +stopped+
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
{ (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
{

3
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -3,7 +3,8 @@
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models combinators math.vectors classes.tuple ;
models models.range models.compose
combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;

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

@ -1,4 +1,4 @@
USING: help.markup help.syntax ui.gadgets models ;
USING: help.markup help.syntax ui.gadgets models models.range ;
IN: ui.gadgets.sliders
HELP: elevator

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

@ -3,7 +3,8 @@
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models math.vectors math.functions quotations colors ;
vectors models models.range math.vectors math.functions
quotations colors ;
IN: ui.gadgets.sliders
TUPLE: elevator direction ;

6
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models sequences ui.gadgets.labels
ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
ui kernel calendar ;
USING: accessors models models.delay models.filter
sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets ui kernel calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )

2
extra/ui/tools/browser/browser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger ui.tools.workspace help help.topics kernel
models ui.commands ui.gadgets ui.gadgets.panes
models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs
accessors ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
models sequences ui.gadgets.buttons
models models.mapping sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener

12
extra/ui/tools/interactor/interactor.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
models namespaces parser lexer prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
concurrency.mailboxes ui.tools.workspace accessors sets
destructors ;
models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking

13
extra/ui/tools/search/search.factor
View File

@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
source-files definitions strings tools.completion tools.crossref
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.vocabs unicode.case calendar ui ;
models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings
tools.completion tools.crossref classes.tuple ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.lists
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
;
IN: ui.tools.search
TUPLE: live-search field list ;

2
extra/ui/tools/walker/walker.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.gadgets.tracks ui.commands ui.gadgets models models.filter
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs combinators ;
IN: ui.tools.walker

6
extra/ui/windows/windows.factor
View File

@ -207,9 +207,9 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
: set-window-active ( hwnd uMsg wParam lParam ? -- n )
>r 4dup r> 2nip nip
swap window set-world-active? DefWindowProc ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
? hwnd window set-world-active?
hwnd uMsg wParam lParam DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
{

6
vm/code_gc.c
View File

@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room)
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
CELL size = 0;
F_BLOCK *scan = first_block(heap);
while(scan)
@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap)
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap)
scan = next_block(heap,scan);
}
printf("%ld bytes of relocation data\n",size);
}
/* Compute where each block is going to go, after compaction */