swap dup length memcpy ;
: (define-nth) ( word type quot -- )
- >r heap-size [ rot * >fixnum ] swap prefix
- r> append define-inline ;
+ [
+ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
+ ] [ ] make define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
{ $subsection set-at }
{ $subsection delete-at }
{ $subsection clear-assoc }
-"The following two words are optional:"
+"The following three words are optional:"
+{ $subsection value-at* }
{ $subsection new-assoc }
{ $subsection assoc-like }
-"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:"
+"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode* } " generic words. Two utility words will help with the implementation of the last two:"
{ $subsection assoc= }
{ $subsection assoc-hashcode }
"Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:"
[ [ dup pair? [ first2 create ] when ] map ] map ;
: define-builtin-slots ( class slots -- )
- prepare-slots 1 make-slots
+ prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
{ "echelon" { "fixnum" "math" } read-only }
} define-builtin
-"tuple" "kernel" create {
- [ { } define-builtin ]
- [ { "delegate" } "slot-names" set-word-prop ]
- [ define-tuple-layout ]
- [
- { "delegate" }
- [ drop ] [ generate-tuple-slots ] 2bi
- [ "slots" set-word-prop ]
- [ define-accessors ]
- 2bi
- ]
-} cleave
+"tuple" "kernel" create
+[ { } define-builtin ]
+[ define-tuple-layout ]
+[
+ { "delegate" } make-slots
+ [ drop ] [ finalize-tuple-slots ] 2bi
+ [ "slots" set-word-prop ]
+ [ define-accessors ]
+ 2bi
+] tri
! Create special tombstone values
"tombstone" "hashtables.private" create
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
-sequences math kernel slots tools.test parser compiler.units ;
+sequences math kernel slots tools.test parser compiler.units
+arrays classes.tuple ;
TUPLE: test-1 ;
-[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-1 "slots" word-prop empty? ] unit-test
TUPLE: test-2 < test-1 ;
-[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-2 "slots" word-prop empty? ] unit-test
[ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ;
-[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
+[ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ;
-[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
+[ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test
TUPLE: test-5 { a integer } ;
-[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
+[ { { "a" integer } } ]
+[
+ test-5 "slots" word-prop
+ [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
-[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
+[ { { "b" integer } } ]
+[
+ test-6 "slots" word-prop
+ [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
TUPLE: test-7 { b integer initial: 3 } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
+DEFER: foo
+
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ error>> unexpected-eof? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
-[ error>> no-initial-value? ]
-must-fail-with
+2 [
+ [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
+ [ error>> no-initial-value? ]
+ must-fail-with
+
+ [ f ] [ \ foo tuple-class? ] unit-test
+] times
-[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
-[ error>> bad-initial-value? ]
+2 [
+ [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
+ [ error>> bad-initial-value? ]
+ must-fail-with
+
+ [ f ] [ \ foo tuple-class? ] unit-test
+] times
+
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
+[ error>> duplicate-slot-names? ]
must-fail-with
+[ f ] [ \ foo tuple-class? ] unit-test
+
[ ] [
[
- { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
+ { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo }
[ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit
] unit-test
+
+
lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser
+: slot-names ( slots -- seq )
+ [ dup array? [ first ] when ] map ;
+
: shadowed-slots ( superclass slots -- shadowed )
- [ all-slots [ name>> ] map ]
- [ [ dup array? [ first ] when ] map ]
- bi* intersect ;
+ [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
] "" make note.
] with each ;
+ERROR: duplicate-slot-names names ;
+
+M: duplicate-slot-names summary
+ drop "Duplicate slot names" ;
+
+: check-duplicate-slots ( slots -- )
+ slot-names duplicates
+ dup empty? [ drop ] [ duplicate-slot-names ] if ;
+
ERROR: invalid-slot-name name ;
M: invalid-slot-name summary
- drop
- "Invalid slot name" ;
+ drop "Invalid slot name" ;
: parse-long-slot-name ( -- )
[ scan , \ } parse-until % ] { } make ;
#! : ...
{
{ [ dup not ] [ unexpected-eof ] }
- { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
+ { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ;
{ ";" [ tuple f ] }
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
- } case 3dup check-slot-shadowing ;
+ } case
+ dup check-duplicate-slots
+ 3dup check-slot-shadowing ;
$nl
"Tuple classes have additional word properties:"
{ $list
- { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
- { { $snippet "\"tuple-size\"" } " - the number of slots" }
+ { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
} } ;
HELP: define-tuple-predicate
! Hardcore unit tests
USE: threads
-\ thread slot-names "slot-names" set
+\ thread "slots" word-prop "slots" set
[ ] [
[
- \ thread tuple { "xxx" } "slot-names" get append
+ \ thread tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
- \ thread tuple "slot-names" get
+ \ thread tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
USE: vocabs
-\ vocab slot-names "slot-names" set
+\ vocab "slots" word-prop "slots" set
[ ] [
[
- \ vocab tuple { "xxx" } "slot-names" get append
+ \ vocab tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
- \ vocab tuple "slot-names" get
+ \ vocab tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
<PRIVATE
-: (tuple) ( layout -- tuple )
- #! In non-optimized code, this word simply calls the
- #! <tuple> primitive. In optimized code, an intrinsic
- #! is generated which allocates a tuple but does not set
- #! any of its slots. This means that any code that uses
- #! (tuple) must fill in the slots before the next
- #! call to GC.
- #!
- #! This word is only used in the expansion of <tuple-boa>,
- #! where this invariant is guaranteed to hold.
- <tuple> ;
-
: tuple-layout ( class -- layout )
"layout" word-prop ;
: >tuple ( seq -- tuple )
unclip slots>tuple ;
-: slot-names ( class -- seq )
- "slot-names" word-prop ;
-
ERROR: bad-superclass class ;
<PRIVATE
: superclass-size ( class -- n )
superclasses but-last-slice
- [ slot-names length ] sigma ;
+ [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot )
[
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
-: generate-tuple-slots ( class slots -- slot-specs )
- over superclass-size 2 + make-slots deprecated-slots ;
+: finalize-tuple-slots ( class slots -- slots )
+ over superclass-size 2 + finalize-slots deprecated-slots ;
: define-tuple-slots ( class -- )
- dup dup "slot-names" word-prop generate-tuple-slots
- [ "slots" set-word-prop ]
+ dup dup "slots" word-prop finalize-tuple-slots
[ define-accessors ] ! new
[ define-slots ] ! old
- 2tri ;
+ 2bi ;
: make-tuple-layout ( class -- layout )
[ ]
- [ [ superclass-size ] [ slot-names length ] bi + ]
+ [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
+ make-slots
[ drop f f tuple-class define-class ]
- [ nip "slot-names" set-word-prop ]
+ [ nip "slots" set-word-prop ]
[ 2drop update-classes ]
3tri ;
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
- rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+ rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
[ call-next-method ]
[
{
- "layout" "slots" "slot-names" "boa-check" "prototype"
+ "layout" "slots" "boa-check" "prototype"
} reset-props
] bi
] bi ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
-PREDICATE: inline-array < integer 32 < ;
-
: if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and
[ nip r> call r> drop ] [ r> drop r> call ] if ;
{ +output+ { "tuple" } }
} define-intrinsic
-\ <array> [
+\ (array) [
array "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
12 11 cell STW
- ! Store initial element
- "n" get [ "initial" operand 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
-\ <byte-array> [
+\ (byte-array) [
byte-array "n" get 2 cells + %allot
! Store length
"n" operand 12 LI
12 11 cell STW
- ! Store initial element
- 0 12 LI
- "n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
- { +input+ { { [ inline-array? ] "n" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system
-classes.tuple.private strings.private slots.private
-compiler.constants ;
+strings.private slots.private compiler.constants optimizer.allot ;
IN: cpu.x86.intrinsics
! Type checks
"tuple" get tuple %store-tagged
] %allot
] H{
- { +input+ { { [ tuple-layout? ] "layout" } } }
+ { +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } }
} define-intrinsic
-\ <array> [
+\ (array) [
array "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
- ! Zero out the rest of the tuple
- "n" get [ 2 + object@ "initial" operand MOV ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
-\ <byte-array> [
+\ (byte-array) [
byte-array "n" get 2 cells + [
! Store length
1 object@ "n" operand MOV
- ! Store initial element
- "n" get cell align cell /i [ 2 + object@ 0 MOV ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] H{
- { +input+ { { [ inline-array? ] "n" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
+M: no-initial-value summary
+ drop "Initial value must be provided for slots specialized to this class" ;
+
+M: bad-initial-value summary
+ drop "Incompatible initial value" ;
+
M: no-cond summary
drop "Fall-through in cond" ;
{ $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } }
{ $side-effects "hash" } ;
-HELP: (set-hash)
-{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
-{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
-{ $side-effects "hash" } ;
-
HELP: grow-hash
{ $values { "hash" hashtable } }
{ $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." }
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
+
+! We want this to work
+[ ] [ hashtable new "h" set ] unit-test
+
+[ 0 ] [ "h" get assoc-size ] unit-test
+
+[ f f ] [ "goo" "h" get at* ] unit-test
+
+[ ] [ 1 2 "h" get set-at ] unit-test
+
+[ 1 ] [ "h" get assoc-size ] unit-test
+
+[ 1 ] [ 2 "h" get at ] unit-test
: probe ( array i -- array i )
2 fixnum+fast over wrap ; inline
-: (key@) ( key keys i -- array n ? )
+: no-key ( key array -- array n ? ) nip f f ; inline
+
+: (key@) ( key array i -- array n ? )
3dup swap array-nth
dup ((empty)) eq?
- [ 3drop nip f f ] [
+ [ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if
] if ; inline
: key@ ( key hash -- array n ? )
- array>> 2dup hash@ (key@) ; inline
+ array>> dup array-capacity 0 eq?
+ [ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline
: hash-deleted+ ( hash -- )
[ 1+ ] change-deleted drop ; inline
-: (set-hash) ( value key hash -- new? )
- 2dup new-key@
- [ rot hash-count+ set-nth-pair t ]
- [ rot drop set-nth-pair f ] if ; inline
-
: (rehash) ( hash alist -- )
- swap [ swapd (set-hash) drop ] curry assoc-each ;
+ swap [ swapd set-at ] curry assoc-each ; inline
: hash-large? ( hash -- ? )
- [ count>> 3 fixnum*fast ]
- [ array>> array-capacity ] bi > ;
+ [ count>> 3 fixnum*fast 1 fixnum+fast ]
+ [ array>> array-capacity ] bi fixnum> ; inline
: hash-stale? ( hash -- ? )
- [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
+ [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- )
[ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
- swap (rehash) ;
+ swap (rehash) ; inline
: ?grow-hash ( hash -- )
dup hash-large? [
r> (rehash) ;
M: hashtable set-at ( value key hash -- )
- dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
+ dup ?grow-hash
+ 2dup new-key@
+ [ rot hash-count+ set-nth-pair ]
+ [ rot drop set-nth-pair ] if ;
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
-\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
-\ (tuple) make-flushable
-
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable
: write-value ( mirror key -- )
<value-ref> write-slot-editor ;
-: describe-row ( obj key n -- )
+: describe-row ( mirror key n -- )
[
+number-rows+ get [ pprint-cell ] [ drop ] if
- 2dup write-key write-value
+ [ write-key ] [ write-value ] 2bi
] with-row ;
: summary. ( obj -- ) [ summary ] keep write-object nl ;
sort-keys values
] [ keys ] if ;
-: describe* ( obj flags -- )
- clone [
- dup summary.
- make-mirror dup sorted-keys dup empty? [
- 2drop
- ] [
- dup enum? [ +sequence+ on ] when
- standard-table-style [
- dup length
- rot [ -rot describe-row ] curry 2each
- ] tabular-output
- ] if
- ] bind ;
+: describe* ( obj mirror keys -- )
+ rot summary.
+ dup empty? [
+ 2drop
+ ] [
+ dup enum? [ +sequence+ on ] when
+ standard-table-style [
+ swap [ -rot describe-row ] curry each-index
+ ] tabular-output
+ ] if ;
-: describe ( obj -- ) H{ } describe* ;
+: describe ( obj -- )
+ dup make-mirror dup sorted-keys describe* ;
M: tuple error. describe ;
SYMBOL: inspector-hook
-[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
+[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
SYMBOL: inspector-stack
SYMBOL: me
: reinspect ( obj -- )
- dup me set
- dup make-mirror dup mirror set keys \ keys set
- inspector-hook get call ;
+ [ me set ]
+ [
+ dup make-mirror dup mirror set dup sorted-keys dup \ keys set
+ inspector-hook get call
+ ] bi ;
: (inspect) ( obj -- )
- dup inspector-stack get push reinspect ;
+ [ inspector-stack get push ] [ reinspect ] bi ;
: key@ ( n -- key ) \ keys get nth ;
"&add ( value key -- ) add new slot" print
"&delete ( n -- ) remove a slot" print
"&rename ( key n -- ) change a slot's key" print
+ "&globals ( -- ) inspect global namespace" print
"&help -- display this message" print
nl ;
: inspect ( obj -- )
inspector-stack get [ (inspect) ] [ inspector ] if ;
+
+: &globals ( -- ) global inspect ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences sequences.private classes.tuple
+classes.tuple.private kernel effects words quotations namespaces
+definitions math math.order layouts alien.accessors
+slots.private arrays byte-arrays inference.dataflow
+inference.known-words inference.state optimizer.inlining
+optimizer.backend ;
+IN: optimizer.allot
+
+! Expand memory allocation primitives into simpler constructs
+! to simplify the backend.
+
+: first-input ( #call -- obj ) dup in-d>> first node-literal ;
+
+: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
+\ (tuple) make-flushable
+
+! if the input to new is a literal tuple class, we can expand it
+: literal-new? ( #call -- ? )
+ first-input tuple-class? ;
+
+: new-quot ( class -- quot )
+ dup all-slots 1 tail ! delegate slot
+ [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
+
+: expand-new ( #call -- node )
+ dup first-input
+ [ +inlined+ depends-on ] [ new-quot ] bi
+ f splice-quot ;
+
+\ new {
+ { [ dup literal-new? ] [ expand-new ] }
+} define-optimizers
+
+: tuple-boa-quot ( layout -- quot )
+ [ (tuple) ]
+ swap size>> 1 - [ 3 + ] map <reversed>
+ [ [ set-slot ] curry [ keep ] curry ] map concat
+ [ f over 2 set-slot ]
+ 3append ;
+
+: expand-tuple-boa ( #call -- node )
+ dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
+
+\ <tuple-boa> {
+ { [ t ] [ expand-tuple-boa ] }
+} define-optimizers
+
+: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } <effect> set-primitive-effect
+\ (array) make-flushable
+
+: <array>-quot ( n -- quot )
+ [
+ [ swap (array) ] %
+ [ \ 2dup , , [ swap set-array-nth ] % ] each
+ \ nip ,
+ ] [ ] make ;
+
+: literal-<array>? ( #call -- ? )
+ first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+ dup first-input <array>-quot f splice-quot ;
+
+\ <array> {
+ { [ dup literal-<array>? ] [ expand-<array> ] }
+} define-optimizers
+
+: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
+\ (byte-array) make-flushable
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+: <byte-array>-quot ( n -- quot )
+ [
+ \ (byte-array) ,
+ bytes>cells [ cell * ] map
+ [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+ ] [ ] make ;
+
+: literal-<byte-array>? ( #call -- ? )
+ first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- node )
+ dup first-input <byte-array>-quot f splice-quot ;
+
+\ <byte-array> {
+ { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
+} define-optimizers
classes.algebra sequences.private combinators byte-arrays
byte-vectors slots.private inference.dataflow inference.state
inference.class optimizer.def-use optimizer.backend
-optimizer.pattern-match optimizer.inlining ;
+optimizer.pattern-match optimizer.inlining optimizer.allot ;
IN: optimizer.known-words
{ <tuple> <tuple-boa> (tuple) } [
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
-! if the input to new is a literal tuple class, we can expand it
-: literal-new? ( #call -- ? )
- dup in-d>> first node-literal tuple-class? ;
-
-: new-quot ( class -- quot )
- dup all-slots 1 tail ! delegate slot
- [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
-
-: expand-new ( #call -- node )
- dup dup in-d>> first node-literal
- [ +inlined+ depends-on ] [ new-quot ] bi
- f splice-quot ;
-
-\ new {
- { [ dup literal-new? ] [ expand-new ] }
-} define-optimizers
-
-: tuple-boa-quot ( layout -- quot )
- [ (tuple) ]
- swap size>> 1 - [ 3 + ] map <reversed>
- [ [ set-slot ] curry [ keep ] curry ] map concat
- [ f over 2 set-slot ]
- 3append ;
-
-: expand-tuple-boa ( #call -- node )
- dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
-
-\ <tuple-boa> {
- { [ t ] [ expand-tuple-boa ] }
-} define-optimizers
-
! the output of clone has the same type as the input
{ clone (clone) } [
[
: convert-mod-to-and ( #call -- node )
dup
- dup node-in-d second node-literal 1-
+ dup in-d>> second node-literal 1-
[ nip bitand ] curry f splice-quot ;
\ mod [
}
} define-optimizers
+: convert-*-to-shift? ( #call -- ? )
+ dup in-d>> second node-literal
+ dup integer? [ power-of-2? ] [ drop f ] if ;
+
+: convert-*-to-shift ( #call -- ? )
+ dup dup in-d>> second node-literal log2
+ [ nip fixnum-shift-fast ] curry
+ f splice-quot ;
+
+\ fixnum*fast {
+ { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
+} define-optimizers
+
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math optimizer.control
-optimizer.collect optimizer.inlining inference.class ;
+optimizer.known-words optimizer.math optimizer.allot
+optimizer.control optimizer.collect optimizer.inlining
+inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
f <inset unclip text pprint-elements block>
\ } pprint-word block> ;
+: unparse-slot ( slot-spec -- array )
+ [
+ dup name>> ,
+ dup class>> object eq? [
+ dup class>> ,
+ initial: ,
+ dup initial>> ,
+ ] unless
+ dup read-only>> [
+ read-only ,
+ ] when
+ drop
+ ] { } make ;
+
+: pprint-slot ( slot-spec -- )
+ unparse-slot
+ dup length 1 = [ first ] when
+ pprint-slot-name ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
- <block slot-names [ pprint-slot-name ] each block>
+ <block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ;
M: word see-class* drop ;
{ $subsection each }
{ $subsection reduce }
{ $subsection interleave }
-{ $subsection 2each }
-{ $subsection 2reduce }
"Mapping:"
{ $subsection map }
-{ $subsection 2map }
+{ $subsection map-as }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
-{ $subsection filter } ;
+{ $subsection filter }
+"Testing if a sequence contains elements satisfying a predicate:"
+{ $subsection contains? }
+{ $subsection all? }
+"Testing how elements are related:"
+{ $subsection monotonic? }
+{ $subsection "sequence-2combinators" } ;
+
+ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
+"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
+{ $subsection 2each }
+{ $subsection 2reduce }
+{ $subsection 2map }
+{ $subsection 2map-as }
+{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
-"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
-{ $subsection all? }
-{ $subsection 2all? }
"Testing how elements are related:"
-{ $subsection monotonic? }
{ $subsection all-eq? }
{ $subsection all-equal? } ;
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
+HELP: map-as
+{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
+{ $examples
+ "The following example converts a string into an array of one-element strings:"
+ { $example "USING: prettyprint strings sequences ;" "\"Hello\" [ 1string ] { } map-as ." "{ \"H\" \"e\" \"l\" \"l\" \"o\" }" }
+ "Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings."
+} ;
+
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
HELP: 2each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
-{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 2reduce
{ $values { "seq1" sequence }
{ "quot" "a quotation with stack effect "
{ $snippet "( prev elt1 elt2 -- next )" } }
{ "result" "the final result" } }
-{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." }
-{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
+
+HELP: 2map-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
{ $values { "seq" sequence }
: 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline
-: 2map ( seq1 seq2 quot -- newseq )
- pick >r (2each) over r>
+: 2map-as ( seq1 seq2 quot exemplar -- newseq )
+ >r (2each) over r>
[ [ collect ] keep ] new-like ; inline
+: 2map ( seq1 seq2 quot -- newseq )
+ pick 2map-as ; inline
+
: 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline
{ $subsection prune }
"Test for duplicates:"
{ $subsection all-unique? }
+{ $subsection duplicates }
"Set operations on sequences:"
{ $subsection diff }
{ $subsection intersect }
{ $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
+HELP: duplicates
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
+} ;
+
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
+: duplicates ( seq -- newseq )
+ H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
+
: gather ( seq quot -- newseq )
map concat prune ; inline
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop
check-initial-value ;
-: make-slots ( slots base -- specs )
- over length [ + ] with map
- [ [ make-slot ] dip >>offset ] 2map ;
+M: slot-spec make-slot
+ check-initial-value ;
+
+: make-slots ( slots -- specs )
+ [ make-slot ] map ;
+
+: finalize-slots ( specs base -- specs )
+ over length [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
- [ slot-spec-name = ] with find nip ;
+ [ name>> = ] with find nip ;
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
- { { $snippet "\"slot-names\"" } { $link "tuples" } }
-
{ { $snippet "\"type\"" } { $link "builtin-classes" } }
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges math.parser math.vectors sets sequences
+kernel io ;
+IN: benchmark.beust1
+
+: count-numbers ( max -- n )
+ 1 [a,b] [ number>string all-unique? ] count ; inline
+
+: beust ( -- )
+ 10000000 count-numbers
+ number>string " unique numbers." append print ;
+
+MAIN: beust
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.ranges math.parser sequences kernel io locals ;
+IN: benchmark.beust2
+
+:: (count-numbers) ( remaining first value used max listener -- ? )
+ 10 first - [| i |
+ [let* | digit [ i first + ]
+ mask [ digit 2^ ]
+ value' [ i value + ] |
+ used mask bitand zero? [
+ value max > [ t ] [
+ remaining 1 <= [
+ listener call f
+ ] [
+ remaining 1-
+ 0
+ value' 10 *
+ used mask bitor
+ max
+ listener
+ (count-numbers)
+ ] if
+ ] if
+ ] [ f ] if
+ ]
+ ] contains? ; inline
+
+:: count-numbers ( max listener -- )
+ 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
+ inline
+
+:: beust ( -- )
+ [let | i! [ 0 ] |
+ 10000000000 [ i 1+ i! ] count-numbers
+ i number>string " unique numbers." append print
+ ] ;
+
+MAIN: beust
<frame>
+ <shelf>
+
{
[ "ESC - Pause" [ drop toggle-loop ] button* ]
"e - +0.1" [ drop inc-separation-weight ] button* add-gadget
"d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
- } [ call ] map [ [ gadget, ] each ] make-shelf
+ } [ call ] map [ add-gadget ] each
1 over set-pack-fill
over @top grid-add
: <color-preview> ( model -- gadget )
color-preview new-gadget
- { 100 100 } over set-rect-dim ;
+ swap >>model
+ { 100 100 } >>dim ;
M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
- swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
+ swap
+ <filled-pile>
+ swap
+ [ <color-slider> add-gadget ] each ;
: <color-picker> ( -- gadget )
[
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
USING: help.syntax help.markup kernel sequences quotations\r
-math ;\r
+math arrays ;\r
IN: generalizations\r
\r
+HELP: narray\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link 1array } ", "\r
+{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "\r
+"that constructs an array from the top " { $snippet "n" } " elements of the stack."\r
+} ;\r
+\r
+HELP: firstn\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link first } ", "\r
+{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "\r
+"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."\r
+} ;\r
+\r
HELP: npick\r
{ $values { "n" integer } }\r
{ $description "A generalization of " { $link dup } ", "\r
"macros where the arity of the input quotations depends on an "\r
"input parameter."\r
{ $subsection narray }\r
+{ $subsection firstn }\r
{ $subsection ndup }\r
{ $subsection npick }\r
{ $subsection nrot }\r
[ [ dup 2^ 2array ] 5 napply ] must-infer\r
\r
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
+\r
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test\r
+[ ] [ { } 0 firstn ] unit-test\r
+[ "a" ] [ { "a" } 1 firstn ] unit-test\r
-! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.\r
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo\r
+! Cavazos, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences sequences.private namespaces math math.ranges\r
-combinators macros quotations fry locals arrays ;\r
+USING: kernel sequences sequences.private namespaces math\r
+math.ranges combinators macros quotations fry arrays ;\r
IN: generalizations\r
\r
MACRO: narray ( n -- quot )\r
- dup [ f <array> ] curry\r
- swap <reversed> [\r
- [ swap [ set-nth-unsafe ] keep ] curry\r
- ] map concat append ;\r
+ [ <reversed> ] [ '[ , f <array> ] ] bi\r
+ [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;\r
+\r
+MACRO: firstn ( n -- )\r
+ dup zero? [ drop [ drop ] ] [\r
+ [ [ '[ , _ nth-unsafe ] ] map ]\r
+ [ 1- '[ , _ bounds-check 2drop ] ]\r
+ bi prefix '[ , cleave ]\r
+ ] if ;\r
\r
MACRO: npick ( n -- )\r
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
2 + [ dupd -nrot ] curry ;\r
\r
MACRO: nrev ( n -- quot )\r
- 1 [a,b] [ '[ , -nrot ] ] map concat ;\r
+ 1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;\r
\r
MACRO: ndip ( quot n -- )\r
dup saver -rot restorer 3append ;\r
[ ] [ 1+ ] [ ] tri\r
'[ [ , ndup ] dip , -nrot , nslip ] ;\r
\r
-MACRO: ncurry ( n -- ) [ curry ] n*quot ;\r
+MACRO: ncurry ( n -- )\r
+ [ curry ] n*quot ;\r
\r
-MACRO:: nwith ( quot n -- )\r
- [let | n' [ n 1+ ] |\r
- [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;\r
+MACRO: nwith ( n -- )\r
+ [ with ] n*quot ;\r
\r
MACRO: napply ( n -- )\r
2 [a,b]\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io.files io.launcher io.encodings.ascii
-io.streams.string http.client sequences.lib combinators
+io.streams.string http.client generalizations combinators
math.parser math.vectors math.intervals interval-maps memoize
csv accessors assocs strings math splitting grouping arrays ;
IN: geo-ip
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret
- combinators.short-circuit ;
+ combinators.short-circuit accessors ;
! lsys.strings
! lsys.strings.rewrite
: lsys-controller ( -- )
+<pile>
+
{
[ "Load" <label> reverse-video-theme ]
[ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system control" open-window ;
+}
+
+[ call add-gadget ] each
+1 >>fill
+"L-system control" open-window ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: model-chooser ( -- )
-
+<pile>
{
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system models" open-window ;
+}
+[ call add-gadget ] each
+1 >>fill
+"L-system models" open-window ;
: scene-chooser ( -- )
+<pile>
{
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system scenes" open-window ;
+}
+[ call add-gadget ] each
+1 >>fill
+"L-system scenes" open-window ;
: lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ;
ARTICLE: "ranges" "Ranges"
- "A " { $emphasis "range" } " is a virtual sequence with elements "
- "ranging from a to b by step."
+ "A " { $emphasis "range" } " is a virtual sequence with real elements "
+ "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
$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 }
-{ $subsection "models-impl" } ;
+{ $subsection "models-impl" }
+{ $subsection "models-filter" }
+{ $subsection "models-compose" }
+{ $subsection "models-history" }
+{ $subsection "models-range" }
+{ $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models"
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib locals mirrors ;
+ assocs.lib math.parser math generalizations locals mirrors ;
IN: namespaces.lib
: nehe-window ( -- )
[
- [
- "Nehe 2" [ drop run2 ] <bevel-button> gadget,
- "Nehe 3" [ drop run3 ] <bevel-button> gadget,
- "Nehe 4" [ drop run4 ] <bevel-button> gadget,
- "Nehe 5" [ drop run5 ] <bevel-button> gadget,
- ] make-filled-pile "Nehe examples" open-window
+ <filled-pile>
+ "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
+ "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
+ "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
+ "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
+ "Nehe examples" open-window
] with-ui ;
MAIN: nehe-window
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
{ { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
-
-[ ] [ { } 0 firstn ] unit-test
-[ "a" ] [ { "a" } 1 firstn ] unit-test
-
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-MACRO: firstn ( n -- )
- [ [ swap nth ] curry [ keep ] curry ] map
- concat >quotation
- [ drop ] compose ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
-strings quotations assocs combinators classes colors
-classes.tuple opengl math.vectors
-ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-ui.render math.geometry.rect ;
+ strings quotations assocs combinators classes colors
+ classes.tuple opengl math.vectors
+ ui.commands ui.gadgets ui.gadgets.borders
+ ui.gadgets.labels ui.gadgets.theme
+ ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ ui.render math.geometry.rect ;
+
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
over set-button-selected?
relayout-1 ;
-: <radio-controls> ( model assoc quot -- )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call gadget, ] 2curry assoc-each ; inline
+: <radio-controls> ( parent model assoc quot -- parent )
+ #! quot has stack effect ( value model label -- )
+ swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
{ 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
- [ [ <radio-button> ] <radio-controls> ] make-filled-pile
- dup radio-buttons-theme ;
+ <filled-pile>
+ -rot
+ [ <radio-button> ] <radio-controls>
+ dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
- [ [ <toggle-button> ] <radio-controls> ] make-shelf ;
+ <shelf>
+ -rot
+ [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
<bevel-button> ;
: <toolbar> ( target -- toolbar )
- [
- "toolbar" over class command-map commands>> swap
- [ -rot <command-button> gadget, ] curry assoc-each
- ] make-shelf ;
+ <shelf>
+ swap
+ "toolbar" over class command-map commands>> swap
+ [ -rot <command-button> add-gadget ] curry assoc-each ;
: toolbar, ( -- ) g <toolbar> f track, ;
{ $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
-HELP: gadget,
-{ $values { "gadget" gadget } }
-{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
-
HELP: make-gadget
{ $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
: focus-path ( world -- seq )
[ focus>> ] follow ;
-: gadget, ( gadget -- ) gadget get swap add-gadget drop ;
-
: g ( -- gadget ) gadget get ;
: g-> ( x -- x x gadget ) dup g ;
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
- [
- [ >r 2dup r> <menu-item> gadget, ] each 2drop
- ] make-filled-pile 5 <border> menu-theme ;
+ <filled-pile>
+ -roll
+ [ <menu-item> add-gadget ] with with each
+ 5 <border> menu-theme ;
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
-{ $subsection gadget, }
+
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
HELP: make-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
HELP: make-filled-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
ABOUT: "ui-pack-layout"
: track-add ( gadget track constraint -- )
over track-sizes push swap add-gadget drop ;
+: track-add* ( track gadget constraint -- track )
+ pick sizes>> push
+ add-gadget ;
+
: track, ( gadget constraint -- )
gadget get swap track-add ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
-ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
-ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
-ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
-models namespaces sequences sequences words continuations
-debugger prettyprint ui.tools.traceback help editors ;
+ ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
+ ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
+ models namespaces sequences sequences words continuations
+ debugger prettyprint ui.tools.traceback help editors ;
+
IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget )
- [
- <pane> [ [ print-error ] with-pane ] keep gadget,
- gadget,
- ] make-filled-pile ;
+ <filled-pile>
+ <pane>
+ swapd tuck [ print-error ] with-pane
+ add-gadget
+
+ swap add-gadget ;
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
- [
- toolbar,
- <restart-list> g-> set-debugger-restarts
- swap <debugger-display> <scroller> 1 track,
- ] make-gadget ;
+ dup <toolbar> f track-add*
+ -rot <restart-list> >>restarts
+ dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
M: debugger focusable-child* debugger-restarts ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
-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
-tools.deploy vocabs ui.tools.workspace system accessors ;
+ 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
+ tools.deploy vocabs ui.tools.workspace system accessors ;
+
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
-: bundle-name ( -- )
+: bundle-name ( parent -- parent )
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
- "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
- "Exit when last UI window closed" <checkbox> gadget, ;
-
-: io-settings ( -- )
- "Input/output support:" <label> gadget,
- deploy-io get deploy-io-options <radio-buttons> gadget, ;
-
-: reflection-settings ( -- )
- "Reflection support:" <label> gadget,
- deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ;
-
-: advanced-settings ( -- )
- "Advanced:" <label> gadget,
- deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
- deploy-math? get "Rational and complex number support" <checkbox> gadget,
- deploy-threads? get "Threading support" <checkbox> gadget,
- deploy-random? get "Random number generator support" <checkbox> gadget,
- deploy-word-props? get "Retain all word properties" <checkbox> gadget,
- deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
- deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
-
-: deploy-settings-theme ( gadget -- )
- { 10 10 } >>gap
- 1 >>fill
- drop ;
+ "Exit when last UI window closed" <checkbox> add-gadget ;
+
+: io-settings ( parent -- parent )
+ "Input/output support:" <label> add-gadget
+ deploy-io get deploy-io-options <radio-buttons> add-gadget ;
+
+: reflection-settings ( parent -- parent )
+ "Reflection support:" <label> add-gadget
+ deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
+
+: advanced-settings ( parent -- parent )
+ "Advanced:" <label> add-gadget
+ deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
+ deploy-math? get "Rational and complex number support" <checkbox> add-gadget
+ deploy-threads? get "Threading support" <checkbox> add-gadget
+ deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
+ deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
+ deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
+
+: deploy-settings-theme ( gadget -- gadget )
+ { 10 10 } >>gap
+ 1 >>fill ;
: <deploy-settings> ( vocab -- control )
- default-config [ <model> ] assoc-map [
+ default-config [ <model> ] assoc-map
[
+ <pile>
bundle-name
deploy-ui
os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
- ] make-pile dup deploy-settings-theme
- namespace <mapping> over set-gadget-model
- ] bind ;
+
+ deploy-settings-theme
+ namespace <mapping> over set-gadget-model
+ ]
+ bind ;
: find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ;
{ T{ key-down f f "RET" } com-deploy }
} define-command-map
-: buttons, ( -- )
- g <toolbar> { 10 10 } over set-pack-gap gadget, ;
-
: <deploy-gadget> ( vocab -- gadget )
deploy-gadget new-gadget
- swap >>vocab
- { 0 1 } >>orientation
- [
- g vocab>> <deploy-settings>
- g-> set-deploy-gadget-settings gadget,
- buttons,
- ] make-gadget
- dup deploy-settings-theme
+ over >>vocab
+ { 0 1 } >>orientation
+ swap <deploy-settings> >>settings
+ dup settings>> add-gadget
+ dup <toolbar> { 10 10 } >>gap add-gadget
+ deploy-settings-theme
dup com-revert ;
-
+
: deploy-tool ( vocab -- )
vocab-name dup <deploy-gadget> 10 <border>
"Deploying \"" rot "\"" 3append open-window ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.workspace inspector kernel ui.commands
+USING: accessors ui.tools.workspace inspector kernel ui.commands
ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ;
TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- )
- dup inspector-gadget-object swap inspector-gadget-pane [
- H{ { +editable+ t } { +number-rows+ t } } describe*
+ [ object>> ] [ pane>> ] bi [
+ +editable+ on
+ +number-rows+ on
+ describe
] with-pane ;
: <inspector-gadget> ( -- gadget )
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
] make-gadget ;
-: inspect-object ( obj inspector -- )
- [ set-inspector-gadget-object ] keep refresh ;
+: inspect-object ( obj mirror keys inspector -- )
+ 2nip swap >>object refresh ;
\ &push H{ { +nullary+ t } { +listener+ t } } define-command
\ &back H{ { +nullary+ t } { +listener+ t } } define-command
-: globals ( -- ) global inspect ;
-
-\ globals H{ { +nullary+ t } { +listener+ t } } define-command
+\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
: inspector-help ( -- ) "ui-inspector" help-window ;
{ T{ update-object } refresh }
{ f &push }
{ f &back }
- { f globals }
+ { f &globals }
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures
-: <search-model> ( producer -- model )
- >r g live-search-field gadget-model
+: <search-model> ( live-search producer -- live-search filter )
+ >r dup field>> model>> ! live-search model :: producer
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
-: <search-list> ( seq limited? presenter -- gadget )
+: <search-list> ( live-search seq limited? presenter -- live-search list )
>r
[ limited-completions ] [ completions ] ? curry
<search-model>
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- [
- <search-field> g-> set-live-search-field f track,
- <search-list> g-> set-live-search-list
- <scroller> 1 track,
- ] make-gadget
- [ live-search-field set-editor-string ] keep
- [ live-search-field end-of-document ] keep ;
+ { 0 1 } live-search new-track
+ <search-field> >>field
+ dup field>> f track-add*
+ -roll <search-list> >>list
+ dup list>> <scroller> 1 track-add*
+
+ swap
+ over field>> set-editor-string
+ dup field>> end-of-document ;
M: live-search focusable-child* live-search-field ;
$nl
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
{ $subsection make-gadget }
-"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable."
+"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
$nl
"A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.ascii sequences sequences.lib
+USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv symbols summary
words accessors math.order sorting ;
IN: usa-cities
projects / factor.git / commitdiff