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-19 11:04:39 -07:00
parent f30042cc8c 541cff7dca
commit b5d2f7f219
63 changed files with 985 additions and 738 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
core/binary-search/binary-search-docs.factor Normal file
View File

@ -0,0 +1,43 @@
IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsection search }
"Variants of sequence words optimized for sorted sequences:"
{ $subsection sorted-index }
{ $subsection sorted-member? }
{ $subsection sorted-memq? }
{ $see-also "order-specifiers" "sequences-sorting" } ;
ABOUT: "binary-search"
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
$nl
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
$nl
"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
{ find find-from find-last find-last find-last-from search } related-words
HELP: sorted-index
{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words
HELP: sorted-member?
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
{ member? sorted-member? } related-words
HELP: sorted-memq?
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
{ memq? sorted-memq? } related-words

17
core/binary-search/binary-search-tests.factor Normal file
View File

@ -0,0 +1,17 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
\ sorted-member? must-infer
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

46
core/binary-search/binary-search.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators ;
IN: binary-search
<PRIVATE
: midpoint ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline
: decide ( quot seq -- quot seq <=> )
[ midpoint swap call ] 2keep rot ; inline
: finish ( quot slice -- i elt )
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
: (search) ( quot seq -- i elt )
dup length 1 <= [
finish
] [
decide {
{ +eq+ [ finish ] }
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
} case
] if ; inline
PRIVATE>
: search ( seq quot -- i elt )
over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
inline
: natural-search ( obj seq -- i elt )
[ <=> ] with search ;
: sorted-index ( obj seq -- i )
natural-search drop ;
: sorted-member? ( obj seq -- ? )
dupd natural-search nip = ;
: sorted-memq? ( obj seq -- ? )
dupd natural-search nip eq? ;

7
core/compiler/tests/stack-trace.factor
View File

@ -30,10 +30,3 @@ words splitting grouping sorting ;
\ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test
: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
\ sort stack-trace-contains?
] unit-test

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

@ -143,6 +143,14 @@ IN: optimizer.known-words
{ [ dup optimize-instance? ] [ optimize-instance ] }
} define-optimizers
! This is a special-case hack
: redundant-array-capacity-check? ( #call -- ? )
dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ;
\ array-capacity? {
{ [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] }
} define-optimizers
! eq? on the same object is always t
{ eq? = } {
{ { @ @ } [ 2drop t ] }

4
core/optimizer/optimizer-tests.factor
View File

@ -219,7 +219,7 @@ M: number detect-number ;
! Regression
USE: sorting
USE: sorting.private
USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
@ -227,7 +227,7 @@ USE: sorting.private
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if
[ dup midpoint@ cut-slice old-binsearch ] if
] if ; inline
[ 10 ] [

3
core/sequences/sequences-docs.factor
View File

@ -243,6 +243,7 @@ $nl
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
@ -585,8 +586,6 @@ HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
{ index index-from last-index last-index-from member? memq? } related-words
HELP: index-from
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;

33
core/sorting/sorting-docs.factor
View File

@ -2,18 +2,19 @@ USING: help.markup help.syntax kernel words math
sequences math.order ;
IN: sorting
ARTICLE: "sequences-sorting" "Sorting and binary search"
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
ARTICLE: "sequences-sorting" "Sorting sequences"
"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
$nl
"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
$nl
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
$nl
"Sorting a sequence with a custom comparator:"
{ $subsection sort }
"Sorting a sequence with common comparators:"
{ $subsection natural-sort }
{ $subsection sort-keys }
{ $subsection sort-values }
"Binary search:"
{ $subsection binsearch }
{ $subsection binsearch* } ;
{ $subsection sort-values } ;
ABOUT: "sequences-sorting"
@ -41,24 +42,4 @@ HELP: midpoint@
{ $values { "seq" "a sequence" } { "n" integer } }
{ $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
HELP: midpoint
{ $values { "seq" "a sequence" } { "elt" object } }
{ $description "Outputs the element at the midpoint of a sequence." } ;
HELP: partition
{ $values { "seq" "a sequence" } { "n" integer } { "slice" slice } }
{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
HELP: binsearch
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
$nl
"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
HELP: binsearch*
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
$nl
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
{ <=> compare natural-sort sort-keys sort-values } related-words

20
core/sorting/sorting-tests.factor
View File

@ -1,8 +1,8 @@
USING: sorting sequences kernel math math.order random
tools.test vectors ;
tools.test vectors sets ;
IN: sorting.tests
[ [ ] ] [ [ ] natural-sort ] unit-test
[ { } ] [ { } natural-sort ] unit-test
[ { 270000000 270000001 } ]
[ T{ slice f 270000000 270000002 270000002 } natural-sort ]
@ -11,18 +11,16 @@ unit-test
[ t ] [
100 [
drop
100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
100 [ 20 random [ 1000 random ] replicate ] replicate
dup natural-sort
[ set= ] [ nip [ before=? ] monotonic? ] 2bi and
] all?
] unit-test
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
! Is it a stable sort?
[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test
[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test

173
core/sorting/sorting.factor
View File

@ -1,49 +1,142 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math sequences vectors math.order
sequences sequences.private math.order ;
IN: sorting
DEFER: sort
! Optimized merge-sort:
!
! 1) only allocates 2 temporary arrays
! 2) first phase (interchanging pairs x[i], x[i+1] where
! x[i] > x[i+1]) is handled specially
<PRIVATE
: <iterator> 0 tail-slice ; inline
TUPLE: merge
{ seq array }
{ accum vector }
{ accum1 vector }
{ accum2 vector }
{ from1 array-capacity }
{ to1 array-capacity }
{ from2 array-capacity }
{ to2 array-capacity } ;
: this ( slice -- obj )
dup slice-from swap slice-seq nth-unsafe ; inline
: next ( iterator -- )
dup slice-from 1+ swap set-slice-from ; inline
: smallest ( iter1 iter2 quot -- elt )
>r over this over this r> call +lt+ eq?
-rot ? [ this ] keep next ; inline
: (merge) ( iter1 iter2 quot accum -- )
>r pick empty? [
drop nip r> push-all
] [
over empty? [
2drop r> push-all
: dump ( from to seq accum -- )
#! Optimize common case where to - from = 1, 2, or 3.
>r >r 2dup swap - dup 1 =
[ 2drop r> nth-unsafe r> push ] [
dup 2 = [
2drop dup 1+
r> [ nth-unsafe ] curry bi@
r> [ push ] curry bi@
] [
3dup smallest r> [ push ] keep (merge)
dup 3 = [
2drop dup 1+ dup 1+
r> [ nth-unsafe ] curry tri@
r> [ push ] curry tri@
] [
drop r> subseq r> push-all
] if
] if
] if ; inline
: merge ( sorted1 sorted2 quot -- result )
>r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector>
[ (merge) ] [ underlying>> ] bi ; inline
: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
: dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
: conquer ( first second quot -- result )
[ tuck >r >r sort r> r> sort ] keep merge ; inline
: (merge) ( merge quot -- )
over r-done? [ drop dump-l ] [
over l-done? [ drop dump-r ] [
2dup decide
[ over r-next ] [ over l-next ] if
(merge)
] if
] if ; inline
: flip-accum ( merge -- )
dup [ accum>> ] [ accum1>> ] bi eq? [
dup accum1>> underlying>> >>seq
dup accum2>> >>accum
] [
dup accum1>> >>accum
dup accum2>> underlying>> >>seq
] if
dup accum>> 0 >>length 2drop ; inline
: <merge> ( seq -- merge )
\ merge new
over >vector >>accum1
swap length <vector> >>accum2
dup accum1>> underlying>> >>seq
dup accum2>> >>accum
dup accum>> 0 >>length drop ; inline
: compute-midpoint ( merge -- merge )
dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
: merging ( from to merge -- )
swap >>to2
swap >>from1
compute-midpoint
dup [ to1>> ] [ seq>> length ] bi min >>to1
dup [ to2>> ] [ seq>> length ] bi min >>to2
dup to1>> >>from2
drop ; inline
: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
: chunks ( length size -- n ) [ align ] keep /i ; inline
: each-chunk ( length size quot -- )
[ [ chunks ] keep ] dip
[ nth-chunk ] prepose curry
each-integer ; inline
: merge ( from to merge quot -- )
[ [ merging ] keep ] dip (merge) ; inline
: sort-pass ( merge size quot -- )
[
over flip-accum
over [ seq>> length ] 2dip
] dip
[ merge ] 2curry each-chunk ; inline
: sort-loop ( merge quot -- )
2 swap
[ pick seq>> length pick > ]
[ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
[ ] while 3drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- )
>r >r 2dup length = [
nip nth r> drop r> push
] [
tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
[ swap ] when r> tuck [ push ] 2bi@
] if ; inline
: sort-pairs ( merge quot -- )
[ [ seq>> ] [ accum>> ] bi ] dip swap
[ (sort-pairs) ] 2curry each-pair ; inline
PRIVATE>
: sort ( seq quot -- sortedseq )
over length 1 <=
[ drop ] [ over >r >r halves r> conquer r> like ] if ;
: sort ( seq quot -- seq' )
[ <merge> ] dip
[ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@ -53,25 +146,3 @@ PRIVATE>
: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
: midpoint ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline
: partition ( seq n -- slice )
+gt+ eq? not swap halves ? ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
slice-from 2nip
] [
[ midpoint swap call ] 3keep roll dup +eq+ eq?
[ drop dup slice-from swap midpoint@ + 2nip ]
[ partition (binsearch) ] if
] if ; inline
: binsearch ( elt seq quot -- i )
swap dup empty?
[ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
: binsearch* ( elt seq quot -- result )
over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline

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

@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui
ui.gestures
ui.gadgets
ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.labels
ui.gadgets.buttons
@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui.gadgets.packs
ui.gadgets.grids
ui.gadgets.theme
ui.gadgets.handler
accessors
qualified
namespaces.lib assocs.lib vars
rewrite-closures automata math.geometry.rect newfx ;
@ -23,13 +22,6 @@ IN: automata.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
QUALIFIED: ui.gadgets.grids
: grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
@ -80,13 +72,15 @@ DEFER: automata-window
"5 - Random Rule" [ random-rule ] view-button add-gadget
"n - New" [ automata-window ] view-button add-gadget
@top grid-add
@top grid-add*
C[ display ] <slate>
{ 400 400 } >>dim
{ 400 400 } >>pdim
dup >slate
@center grid-add
@center grid-add*
<handler>
H{ }
T{ key-down f f "1" } [ start-center ] view-action is
@ -95,9 +89,7 @@ DEFER: automata-window
T{ key-down f f "5" } [ random-rule ] view-action is
T{ key-down f f "n" } [ automata-window ] view-action is
<handler>
tuck set-gadget-delegate
>>table
"Automata" open-window ;

67
extra/benchmark/backtrack/backtrack.factor Normal file
View File

@ -0,0 +1,67 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: backtrack shuffle math math.ranges quotations locals fry
kernel words io memoize macros io prettyprint sequences assocs
combinators namespaces ;
IN: benchmark.backtrack
! This was suggested by Dr_Ford. Compute the number of quadruples
! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
! placing them on the stack, and applying the operations
! +, -, * and rot as many times as we wish.
: nop ;
MACRO: amb-execute ( seq -- quot )
[ length ] [ <enum> [ 1quotation ] assoc-map ] bi
'[ , amb , case ] ;
: if-amb ( true false -- )
[
[ { t f } amb ]
[ '[ @ require t ] ]
[ '[ @ f ] ]
tri* if
] with-scope ; inline
: do-something ( a b -- c )
{ + - * } amb-execute ;
: some-rots ( a b c -- a b c )
#! Try to rot 0, 1 or 2 times.
{ nop rot -rot } amb-execute ;
MEMO: 24-from-1 ( a -- ? )
24 = ;
MEMO: 24-from-2 ( a b -- ? )
[ do-something 24-from-1 ] [ 2drop ] if-amb ;
MEMO: 24-from-3 ( a b c -- ? )
[ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
MEMO: 24-from-4 ( a b c d -- ? )
[ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
: find-impossible-24 ( -- n )
1 10 [a,b] [| a |
1 10 [a,b] [| b |
1 10 [a,b] [| c |
1 10 [a,b] [| d |
a b c d 24-from-4
] count
] sigma
] sigma
] sigma ;
: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
: backtrack-benchmark ( -- )
words [ reset-memoized ] each
find-impossible-24 pprint "/10000 quadruples can make 24." print
words [
dup pprint " tested " write "memoize" word-prop assoc-size pprint
" possibilities" print
] each ;
MAIN: backtrack-benchmark

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

@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ display ] <slate> >slate
t slate> set-gadget-clipped?
{ 600 400 } slate> set-slate-dim
{ 600 400 } slate> set-slate-pdim
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
} [ call ] map [ add-gadget ] each
1 over set-pack-fill
over @top grid-add
@top grid-add*
slate> over @center grid-add
slate> @center grid-add*
<handler>
H{ } clone
T{ key-down f f "1" } C[ drop randomize ] is
@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
<handler> tuck set-gadget-delegate "Boids" open-window ;
>>table
"Boids" open-window ;
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

2
extra/cfdg/cfdg.factor
View File

@ -204,7 +204,7 @@ VAR: start-shape
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
{ 500 500 } over set-slate-dim
{ 500 500 } over set-slate-pdim
dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;

4
extra/channels/channels-tests.factor
View File

@ -17,7 +17,7 @@ IN: channels.tests
from
] unit-test
{ V{ 1 2 3 4 } } [
{ { 1 2 3 4 } } [
V{ } clone <channel>
[ from swap push ] in-thread
[ from swap push ] in-thread
@ -30,7 +30,7 @@ IN: channels.tests
natural-sort
] unit-test
{ V{ 1 2 4 9 } } [
{ { 1 2 4 9 } } [
V{ } clone <channel>
[ 4 swap to ] in-thread
[ 2 swap to ] in-thread

6
extra/cords/cords.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting math math.order
arrays combinators kernel ;
USING: accessors assocs sequences sorting binary-search math
math.order arrays combinators kernel ;
IN: cords
<PRIVATE
@ -23,7 +23,7 @@ M: multi-cord length count>> ;
M: multi-cord virtual@
dupd
seqs>> [ first <=> ] binsearch*
seqs>> [ first <=> ] with search nip
[ first - ] [ second ] bi ;
M: multi-cord virtual-seq

43
extra/display-stack/display-stack.factor Normal file
View File

@ -0,0 +1,43 @@
USING: kernel namespaces sequences math
listener io prettyprint sequences.lib fry ;
IN: display-stack
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: watched-variables
: watch-var ( sym -- ) watched-variables get push ;
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
: unwatch-var ( sym -- ) watched-variables get delete ;
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
: print-watched-variables ( -- )
watched-variables get length 0 >
[
"----------" print
watched-variables get
watched-variables get [ unparse ] map longest length 2 +
'[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
each
]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: display-stack ( -- )
V{ } clone watched-variables set
[
print-watched-variables
"----------" print
datastack [ . ] each
"----------" print
retainstack reverse [ . ] each
]
listener-hook set ;

2
extra/farkup/authors.factor
View File

@ -1,2 +0,0 @@
Doug Coleman
Slava Pestov

1
extra/farkup/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Slava Pestov

45
extra/farkup/farkup-tests.factor Executable file → Normal file
View File

@ -1,12 +1,19 @@
USING: farkup kernel tools.test ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test ;
IN: farkup.tests
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23"
"paragraph" \ farkup rule parse drop
] unit-test
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
"paragraph" \ farkup rule parse drop
] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
@ -15,11 +22,20 @@ IN: farkup.tests
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
[ "" ] [ "\n\n" convert-farkup ] unit-test
[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
@ -29,7 +45,7 @@ IN: farkup.tests
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "" ] [ "" convert-farkup ] unit-test
@ -77,8 +93,5 @@ IN: farkup.tests
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

288
extra/farkup/farkup.factor Executable file → Normal file
View File

@ -1,72 +1,111 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.styles kernel memoize namespaces peg math
combinators sequences strings html.elements xml.entities
xmode.code2html splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
USING: accessors arrays combinators html.elements io io.streams.string
kernel math memoize namespaces peg peg.ebnf prettyprint
sequences sequences.deep strings xml.entities vectors splitting
xmode.code2html ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
<PRIVATE
TUPLE: heading1 obj ;
TUPLE: heading2 obj ;
TUPLE: heading3 obj ;
TUPLE: heading4 obj ;
TUPLE: strong obj ;
TUPLE: emphasis obj ;
TUPLE: superscript obj ;
TUPLE: subscript obj ;
TUPLE: inline-code obj ;
TUPLE: paragraph obj ;
TUPLE: list-item obj ;
TUPLE: list obj ;
TUPLE: table obj ;
TUPLE: table-row obj ;
TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
: delimiters ( -- string )
"*_^~%[-=|\\\r\n" ; inline
EBNF: farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
MEMO: text ( -- parser )
[ delimiters member? not ] satisfy repeat1
[ >string escape-string ] action ;
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
MEMO: delimiter ( -- parser )
[ dup delimiters member? swap "\r\n=" member? not and ] satisfy
[ 1string ] action ;
heading2 = "==" (!("=" | nl).)+ "=="
=> [[ second >string heading2 boa ]]
: surround-with-foo ( string tag -- seq )
dup <foo> swap </foo> swapd 3array ;
heading3 = "===" (!("=" | nl).)+ "==="
=> [[ second >string heading3 boa ]]
: delimited ( str html -- parser )
[
over token hide ,
text [ surround-with-foo ] swapd curry action ,
token hide ,
] seq* ;
heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]]
MEMO: escaped-char ( -- parser )
[ "\\" token hide , any-char , ] seq* [ >string ] action ;
strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]]
MEMO: strong ( -- parser ) "*" "strong" delimited ;
MEMO: emphasis ( -- parser ) "_" "em" delimited ;
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
MEMO: nl ( -- parser )
"\r\n" token [ drop "\n" ] action
"\r" token [ drop "\n" ] action
"\n" token 3choice ;
MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
emphasis = "_" (!("_" | nl).)+ "_"
=> [[ second >string emphasis boa ]]
superscript = "^" (!("^" | nl).)+ "^"
=> [[ second >string superscript boa ]]
subscript = "~" (!("~" | nl).)+ "~"
=> [[ second >string subscript boa ]]
inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
escaped-char = "\" . => [[ second ]]
image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
| "[[image:" (!("]").)+ "]]"
=> [[ second >string f image boa ]]
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
=> [[ second >string dup link boa ]]
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
link = image-link | labelled-link | simple-link
heading = heading4 | heading3 | heading2 | heading1
inline-tag = strong | emphasis | superscript | subscript | inline-code
| link | escaped-char
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
=> [[ first ]]
table-row = "|" (table-column)+
=> [[ second table-row boa ]]
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
=> [[ table boa ]]
paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item?
| paragraph-item)
=> [[ paragraph boa ]]
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
=> [[ second list-item boa ]]
list = ((list-item nl)+ list-item? | list-item)
=> [[ list boa ]]
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
stand-alone = (code | heading | list | table | paragraph | nl)*
;EBNF
MEMO: eq ( -- parser )
[
h1 ensure-not ,
h2 ensure-not ,
h3 ensure-not ,
h4 ensure-not ,
"=" token ,
] seq* ;
: render-code ( string mode -- string' )
>r string-lines r>
[
<pre>
htmlize-lines
</pre>
] with-string-writer ;
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
: write-link ( text href -- )
escape-link
[
"<a" ,
" href=\"" , >r , r> "\"" ,
link-no-follow? get [ " nofollow=\"true\"" , ] when
">" , , "</a>" ,
] { } make ;
"<a" write
" href=\"" write write "\"" write
link-no-follow? get [ " nofollow=\"true\"" write ] when
">" write write "</a>" write ;
: make-image-link ( href alt -- seq )
: write-image-link ( href text -- )
disable-images? get [
2drop "<strong>Images are not allowed</strong>"
2drop "<strong>Images are not allowed</strong>" write
] [
escape-link
[
"<img src=\"" , swap , "\"" ,
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
"/>" ,
] { } make
>r "<img src=\"" write write "\"" write r>
dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
"/>" write
] if ;
MEMO: image-link ( -- parser )
: render-code ( string mode -- string' )
>r string-lines r>
[
"[[image:" token hide ,
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
"|" token hide
[ CHAR: ] = not ] satisfy repeat0 2seq
[ first >string ] action optional ,
"]]" token hide ,
] seq* [ first2 make-image-link ] action ;
<pre>
htmlize-lines
</pre>
] with-string-writer write ;
MEMO: simple-link ( -- parser )
[
"[[" token hide ,
[ "|]" member? not ] satisfy repeat1 ,
"]]" token hide ,
] seq* [ first dup make-link ] action ;
MEMO: labelled-link ( -- parser )
[
"[[" token hide ,
[ CHAR: | = not ] satisfy repeat1 ,
"|" token hide ,
[ CHAR: ] = not ] satisfy repeat1 ,
"]]" token hide ,
] seq* [ first2 make-link ] action ;
MEMO: link ( -- parser )
[ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
[
"-" token hide , ! text ,
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
] seq* [ "li" surround-with-foo ] action ;
MEMO: list ( -- parser )
list-item nl hide list-of
[ "ul" surround-with-foo ] action ;
MEMO: table-column ( -- parser )
text [ "td" surround-with-foo ] action ;
MEMO: table-row ( -- parser )
"|" token hide
table-column "|" token hide list-of
"|" token hide nl hide optional 4seq
[ "tr" surround-with-foo ] action ;
MEMO: table ( -- parser )
table-row repeat1
[ "table" surround-with-foo ] action ;
MEMO: code ( -- parser )
[
"[" token hide ,
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
"{" token hide ,
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
"}]" token hide ,
] seq* [ first2 swap render-code ] action ;
MEMO: line ( -- parser )
[
nl table 2seq ,
nl list 2seq ,
text , strong , emphasis , link ,
superscript , subscript , inline-code ,
escaped-char , delimiter , eq ,
] choice* repeat1 ;
MEMO: paragraph ( -- parser )
line
nl over 2seq repeat0
nl nl ensure-not 2seq optional 3seq
[
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
[ "<p>" swap "</p>" 3array ] unless
] action ;
PRIVATE>
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
] choice* repeat0 nl optional 2seq ;
: write-farkup ( parse-result -- )
[ dup string? [ write ] [ drop ] if ] deep-each ;
GENERIC: write-farkup ( obj -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row write-farkup ( obj -- )
obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
M: fixnum write-farkup ( obj -- ) write1 ;
M: string write-farkup ( obj -- ) write ;
M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
M: f write-farkup ( obj -- ) drop ;
: convert-farkup ( string -- string' )
parse-farkup [ write-farkup ] with-string-writer ;
farkup [ write-farkup ] with-string-writer ;

68
extra/golden-section/golden-section.factor
View File

@ -1,64 +1,64 @@
USING: kernel namespaces math math.constants math.functions arrays sequences
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors ;
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors accessors combinators.cleave ;
IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! To run:
! "golden-section" run
: disk ( radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: disk ( quadric radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
0 1 10 10 gluDisk
glPopMatrix ;
! omega(i) = 2*pi*i*(phi-1)
! x(i) = 0.5*i*cos(omega(i))
! y(i) = 0.5*i*sin(omega(i))
! radius(i) = 10*sin((pi*i)/720)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: omega ( i -- omega ) phi 1- * 2 * pi * ;
: x ( i -- x ) dup omega cos * 0.5 * ;
: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
: y ( i -- y ) dup omega sin * 0.5 * ;
: center ( i -- point ) dup x swap y 2array ;
: center ( i -- point ) { x y } 1arr ;
: radius ( i -- radius ) pi * 720 / sin 10 * ;
: color ( i -- color ) 360.0 / dup 0.25 1 4array ;
: rim ( quadric i -- )
black gl-color dup radius 1.5 * swap center disk ;
: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
: inner ( quadric i -- )
dup color gl-color dup radius swap center disk ;
: dot ( i -- ) [ rim ] [ inner ] bi ;
: dot ( quadric i -- ) 2dup rim inner ;
: golden-section ( quadric -- ) 720 [ dot ] with each ;
: golden-section ( -- ) 720 [ dot ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: with-quadric ( quot -- )
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
: display ( -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ golden-section ] with-quadric ;
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
golden-section ;
: golden-section-window ( -- )
[
[ display ] <slate>
{ 600 600 } over set-slate-dim
"Golden Section" open-window
] with-ui ;
[ display ] <slate>
{ 600 600 } >>pdim
"Golden Section" open-window
]
with-ui ;
MAIN: golden-section-window

3
extra/help/markup/markup.factor
View File

@ -188,6 +188,9 @@ M: f print-element drop ;
: $links ( topics -- )
[ [ ($link) ] textual-list ] ($span) ;
: $vocab-links ( vocabs -- )
[ vocab ] map $links ;
: $see-also ( topics -- )
"See also" $heading $links ;

2
extra/html/components/components-tests.factor
View File

@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
[ "farkup" T{ farkup } render ] with-string-writer
] unit-test

8
extra/interval-maps/interval-maps.factor
View File

@ -1,5 +1,7 @@
USING: kernel sequences arrays accessors grouping
math.order sorting math assocs locals namespaces ;
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays accessors grouping math.order
sorting binary-search math assocs locals namespaces ;
IN: interval-maps
TUPLE: interval-map array ;
@ -7,7 +9,7 @@ TUPLE: interval-map array ;
<PRIVATE
: find-interval ( key interval-map -- interval-node )
[ first <=> ] binsearch* ;
[ first <=> ] with search nip ;
: interval-contains? ( key interval-node -- ? )
first2 between? ;

90
extra/irc/client/client.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays qualified fry
continuations threads strings classes combinators
irc.messages irc.messages.private ;
continuations threads strings classes combinators splitting hashtables
ascii irc.messages irc.messages.private ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.client
@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages
TUPLE: irc-listener in-messages out-messages ;
TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
TUPLE: irc-nick-listener < irc-listener name ;
SYMBOL: +server-listener+
@ -37,10 +37,10 @@ SYMBOL: +server-listener+
<mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
<mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
[ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener )
<mailbox> <mailbox> rot irc-nick-listener boa ;
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
! ======================================
! Message objects
@ -52,8 +52,8 @@ SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ]
[ f >>is-running drop ]
[ [ irc-end ] dip in-messages>> mailbox-put ]
[ [ f ] dip (>>is-running) ]
[ stream>> dispose ]
tri ;
@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
: remove-participant ( nick channel -- )
listener> [ participants>> delete-at ] [ drop ] if* ;
: remove-participant-from-all ( nick -- )
irc> listeners>>
[ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
assoc-each ;
: add-participant ( nick mode channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ;
DEFER: me?
: maybe-forward-join ( join -- )
[ prefix>> parse-name me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ;
! ======================================
! IRC client messages
! ======================================
GENERIC: irc-message>string ( irc-message -- string )
M: irc-message irc-message>string ( irc-message -- string )
[ command>> ]
[ parameters>> " " sjoin ]
[ trailing>> dup [ CHAR: : prefix ] when ]
tri 3array " " sjoin ;
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string )
: /JOIN ( channel password -- )
"JOIN " irc-write
[ " :" swap 3append ] when* irc-print ;
[ [ " :" ] dip 3append ] when* irc-print ;
: /PART ( channel text -- )
[ "PART " irc-write irc-write ] dip
@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
[ [ prefix>> parse-name me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ]
[ maybe-forward-join ]
[ dup trailing>> to-listener ]
bi ;
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
tri ;
M: part handle-incoming-irc ( part -- )
dup channel>> to-listener ;
[ dup channel>> to-listener ] keep
[ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
M: kick handle-incoming-irc ( kick -- )
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
to-listener ;
[ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
tri ;
M: quit handle-incoming-irc ( quit -- )
[ prefix>> parse-name remove-participant-from-all ] keep
call-next-method ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ f ] if ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- )
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
M: part handle-outgoing-irc ( privmsg -- )
M: part handle-outgoing-irc ( part -- )
[ channel>> ] [ trailing>> "" or ] bi /PART ;
! ======================================
@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- )
! ======================================
: irc-mailbox-get ( mailbox quot -- )
swap 5 seconds
'[ , , , mailbox-get-timeout swap call ]
[ 5 seconds ] dip
'[ , , , [ mailbox-get-timeout ] dip call ]
[ drop ] recover ; inline
: handle-reader-message ( irc-message -- )
@ -199,11 +225,12 @@ DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ in-messages>> irc-disconnected swap mailbox-put ]
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- )
drop irc> is-running>> [ (handle-disconnect) ] when ;
@ -236,6 +263,7 @@ DEFER: (connect-irc)
{
{ [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
[ nip ]
} cond ;
: listener-loop ( name listener -- )
@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
[ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
+server-listener+ swap set+run-listener ;
[ +server-listener+ ] dip set+run-listener ;
GENERIC: (remove-listener) ( irc-listener -- )
@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
name>> unregister-listener ;
M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
[ [ out-messages>> ] [ name>> ] bi
\ part new swap >>channel mailbox-put ] keep
[ [ name>> ] [ out-messages>> ] bi
[ [ part new ] dip >>channel ] dip mailbox-put ] keep
name>> unregister-listener ;
M: irc-server-listener (remove-listener) ( irc-server-listener -- )
@ -294,10 +322,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
swap >>stream
t >>is-running
in-messages>> irc-connected swap mailbox-put ;
in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot -- )
>r current-irc-client r> with-variable ; inline
[ current-irc-client ] dip with-variable ; inline
PRIVATE>

22
extra/irc/messages/messages.factor
View File

@ -1,13 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry sequences splitting ascii calendar accessors combinators
classes.tuple math.order ;
USING: kernel fry splitting ascii calendar accessors combinators qualified
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ;
TUPLE: join < irc-message channel ;
TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ;
TUPLE: privmsg < irc-message name ;
@ -16,8 +18,21 @@ TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message asterisk name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name channel mode ;
TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ;
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
[ command>> ]
[ parameters>> " " sjoin ]
[ trailing>> dup [ CHAR: : prefix ] when ]
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
<PRIVATE
! ======================================
! Message parsing
@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
{ "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] }
{ "353" [ \ names-reply ] }
{ "JOIN" [ \ join ] }
{ "PART" [ \ part ] }
{ "PRIVMSG" [ \ privmsg ] }

17
extra/irc/ui/commandparser/commandparser.factor Executable file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
IN: irc.ui.commandparser
"irc.ui.commands" require
: command ( string string -- string command )
dup empty? [ drop "say" ] when
dup "irc.ui.commands" lookup
[ nip ]
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
: parse-message ( string -- )
"/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;

13
extra/irc/ui/commands/commands.factor Executable file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands
: say ( string -- )
[ client get profile>> nickname>> <own-message> print-irc ]
[ listener get write-message ] bi ;
: quote ( string -- )
drop ; ! THIS WILL CHANGE

9
extra/irc/ui/ircui-rc Executable file
View File

@ -0,0 +1,9 @@
! Default system ircui-rc file
! Copy into .ircui-rc in your home directory and then change username and such
! To find your home directory, type "home ." into a Factor listener
USING: irc.client irc.ui ;
"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
server-open

16
extra/irc/ui/load/load.factor Executable file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.files parser editors sequences ;
IN: irc.ui.load
: file-or ( path path -- path ) over exists? ? ;
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
: run-ircui ( -- ) ircui-rc run-file ;

106
extra/irc/ui/ui.factor
View File

@ -3,12 +3,17 @@
USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
io io.styles namespaces irc.client irc.messages ;
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids
io io.styles namespaces calendar calendar.format
irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load ;
IN: irc.ui
SYMBOL: listener
SYMBOL: client
TUPLE: ui-window client tabs ;
@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ;
: green { 0 0.5 0 1 } ;
: blue { 0 0 1 1 } ;
: prefix>nick ( prefix -- nick )
"!" split first ;
: dot-or-parens ( string -- string )
dup empty? [ drop "." ]
[ "(" prepend ")" append ] if ;
GENERIC: write-irc ( irc-message -- )
M: privmsg write-irc
"<" blue write-color
[ prefix>> prefix>nick write ] keep
">" blue write-color
" " write
[ prefix>> parse-name write ] keep
"> " blue write-color
trailing>> write ;
TUPLE: own-message message nick timestamp ;
: <own-message> ( message nick -- own-message )
now own-message boa ;
M: own-message write-irc
"<" blue write-color
[ nick>> bold font-style associate format ] keep
"> " blue write-color
message>> write ;
M: join write-irc
"* " green write-color
prefix>> prefix>nick write
prefix>> parse-name write
" has entered the channel." green write-color ;
M: part write-irc
"* " red write-color
[ prefix>> prefix>nick write ] keep
" has left the channel(" red write-color
trailing>> write
")" red write-color ;
[ prefix>> parse-name write ] keep
" has left the channel" red write-color
trailing>> dot-or-parens red write-color ;
M: quit write-irc
"* " red write-color
[ prefix>> prefix>nick write ] keep
" has left IRC(" red write-color
trailing>> write
")" red write-color ;
[ prefix>> parse-name write ] keep
" has left IRC" red write-color
trailing>> dot-or-parens red write-color ;
M: irc-end write-irc
drop "* You have left IRC" red write-color ;
@ -63,15 +77,12 @@ M: irc-message write-irc
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
: print-irc ( irc-message -- )
write-irc nl ;
[ timestamp>> timestamp>hms write " " write ]
[ write-irc nl ] bi ;
: send-message ( message listener client -- )
"<" blue write-color
profile>> nickname>> bold font-style associate format
">" blue write-color
" " write
over write nl
out-messages>> mailbox-put ;
: send-message ( message -- )
[ print-irc ]
[ listener get write-message ] bi ;
: display ( stream listener -- )
'[ , [ [ t ]
@ -84,35 +95,44 @@ M: irc-message write-irc
TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( pane listener client -- editor )
[ irc-editor new-editor
: <irc-editor> ( page pane listener -- client editor )
irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream
] dip client>> >>client ;
over client>> >>client ;
: editor-send ( irc-editor -- )
{ [ outstream>> ]
[ editor-string ]
[ listener>> ]
[ client>> ]
[ editor-string ]
[ "" swap set-editor-string ] } cleave
'[ , , , send-message ] with-output-stream ;
'[ , listener set , client set , parse-message ] with-output-stream ;
irc-editor "general" f {
{ T{ key-down f f "RET" } editor-send }
{ T{ key-down f f "ENTER" } editor-send }
} define-command-map
: irc-page ( name pane editor tabbed -- )
[ [ <scroller> @bottom frame, ! editor
<scroller> @center frame, ! pane
] make-frame swap ] dip add-page ;
TUPLE: irc-page < frame listener client ;
: <irc-page> ( listener client -- irc-page )
irc-page new-frame
swap client>> >>client swap [ >>listener ] keep
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
M: irc-page graft*
[ listener>> ] [ client>> ] bi
add-listener ;
M: irc-page ungraft*
[ listener>> ] [ client>> ] bi
remove-listener ;
: join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip
[ client>> add-listener ]
[ drop <irc-pane> dup ]
[ [ <irc-editor> ] keep ] 2tri
tabs>> irc-page ;
[ <irc-page> swap ] keep
tabs>> add-page ;
: irc-window ( ui-window -- )
[ tabs>> ]
@ -125,6 +145,10 @@ irc-editor "general" f {
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
"Server" associate <tabbed> >>tabs ] bi ;
: freenode-connect ( -- ui-window )
"irc.freenode.org" 8001 "factor-irc" f
<irc-profile> ui-connect [ irc-window ] keep ;
: server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
[ over join-channel ] each ;
: main-run ( -- ) run-ircui ;
MAIN: main-run

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

@ -158,7 +158,9 @@ DEFER: empty-model
: lsys-viewer ( -- )
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-dim
{ 400 400 } clone slate> set-slate-pdim
slate> <handler>
{
@ -194,13 +196,9 @@ DEFER: empty-model
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action ] }
! } [ make* ] map alist>hash <handler> >handler
} [ make* ] map >hashtable >>table
} [ make* ] map >hashtable <handler> >handler
slate> handler> set-gadget-delegate
handler> "L-system view" open-window
"L-system view" open-window
500 sleep

11
extra/math/primes/primes.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel lists.lazy math math.functions math.miller-rabin
math.order math.primes.list math.ranges sequences sorting ;
math.order math.primes.list math.ranges sequences sorting
binary-search ;
IN: math.primes
<PRIVATE
@ -13,14 +14,14 @@ PRIVATE>
: next-prime ( n -- p )
dup 999983 < [
primes-under-million [ [ <=> ] binsearch 1+ ] keep nth
primes-under-million [ natural-search drop 1+ ] keep nth
] [
next-odd find-prime-miller-rabin
] if ; foldable
: prime? ( n -- ? )
dup 1000000 < [
dup primes-under-million [ <=> ] binsearch* =
dup primes-under-million natural-search nip =
] [
miller-rabin
] if ; foldable
@ -37,7 +38,7 @@ PRIVATE>
{
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
[ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
[ primes-under-million 1000003 lprimes-from
rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
@ -45,6 +46,6 @@ PRIVATE>
: primes-between ( low high -- seq )
primes-upto
[ 1- next-prime ] dip
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
[ natural-search drop ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable

2
extra/multi-methods/tests/canonicalize.factor
View File

@ -49,7 +49,7 @@ kernel strings ;
{ { object ppc object } "b" }
{ { string object windows } "c" }
}
V{ cpu os }
{ cpu os }
] [
example-1 canonicalize-specializers
] unit-test

4
extra/peg/ebnf/ebnf-tests.factor
View File

@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
] unit-test
[
"USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
] must-fail
{ t } [
@ -519,4 +519,4 @@ Tok = Spaces (Number | Special )
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
] unit-test
] unit-test

2
extra/peg/ebnf/ebnf.factor
View File

@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [
swap symbol>> dup get parser? [
"Rule '" over append "' defined more than once" append throw
] [
set

17
extra/processing/gadget/gadget.factor
View File

@ -1,25 +1,14 @@
USING: kernel namespaces combinators
ui.gestures qualified accessors ui.gadgets.frame-buffer ;
ui.gestures accessors ui.gadgets.frame-buffer ;
IN: processing.gadget
QUALIFIED: ui.gadgets
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: processing-gadget button-down button-up key-down key-up ;
TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-gadget-delegate ( tuple gadget -- tuple )
over ui.gadgets:set-gadget-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <processing-gadget> ( -- gadget )
processing-gadget new
<frame-buffer> set-gadget-delegate ;
: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/processing/processing.factor Executable file → Normal file
View File

@ -374,7 +374,7 @@ SYMBOL: setup-called
500 sleep
<processing-gadget>
size-val get >>dim
size-val get >>pdim
dup "Processing" open-window
500 sleep

27
extra/self/slots/slots.factor Normal file
View File

@ -0,0 +1,27 @@
USING: kernel words lexer parser sequences accessors self ;
IN: self.slots
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-reader ( slot -- )
[ "->" append current-vocab create dup set-word ]
[ ">>" append search [ self> ] swap suffix ] bi
(( -- value )) define-declared ;
: define-self-slot-writer ( slot -- )
[ "->" prepend current-vocab create dup set-word ]
[ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
(( value -- )) define-declared ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-accessors ( class -- )
"slots" word-prop
[ name>> ] map
[ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing

1
extra/soundex/soundex-tests.factor
View File

@ -2,3 +2,4 @@ IN: soundex.tests
USING: soundex tools.test ;
[ "S162" ] [ "supercalifrag" soundex ] unit-test
[ "M000" ] [ "M" soundex ] unit-test

4
extra/soundex/soundex.factor
View File

@ -25,8 +25,8 @@ TR: soundex-tr
[ first>upper ]
[
soundex-tr
trim-first
remove-duplicates
[ "" ] [ trim-first ] if-empty
[ "" ] [ remove-duplicates ] if-empty
remove-zeroes
] bi
pad-4

2
extra/springies/ui/ui.factor
View File

@ -51,7 +51,7 @@ DEFER: maybe-loop
: springies-window* ( -- )
C[ display ] <slate> >slate
{ 800 600 } slate> set-slate-dim
{ 800 600 } slate> set-slate-pdim
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft

10
extra/tools/vocabs/browser/browser.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel combinators vocabs vocabs.loader
tools.vocabs io io.files io.styles help.markup help.stylesheet
sequences assocs help.topics namespaces prettyprint words
sorting definitions arrays summary sets ;
sorting definitions arrays summary sets generic ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
@ -104,9 +104,9 @@ C: <vocab-author> vocab-author
] unless drop ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
>r dup vocab-name swap words [ generic? not ] filter r> map
[ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
remove sift [ vocab ] map ; inline
remove sift ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
@ -115,13 +115,13 @@ C: <vocab-author> vocab-author
: describe-uses ( vocab -- )
vocab-uses dup empty? [
"Uses" $heading
dup $links
dup $vocab-links
] unless drop ;
: describe-usage ( vocab -- )
vocab-usage dup empty? [
"Used by" $heading
dup $links
dup $vocab-links
] unless drop ;
: $describe-vocab ( element -- )

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

@ -7,27 +7,24 @@ TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
: current-page ( book -- gadget )
[ control-value ] keep nth-gadget ;
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
M: book model-changed
M: book model-changed ( model book -- )
nip
dup hide-all
dup current-page show-gadget
relayout ;
: new-book ( pages model class -- book )
new-gadget
swap >>model
[ swap add-gadgets drop ] keep ; inline
new-gadget
swap >>model
swap add-gadgets ; inline
: <book> ( pages model -- book )
book new-book ;
: <book> ( pages model -- book ) book new-book ;
M: book pref-dim* gadget-children pref-dims max-dim ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout*
dup rect-dim swap gadget-children
[ set-layout-dim ] with each ;
M: book layout* ( book -- )
[ dim>> ] [ children>> ] bi [ set-layout-dim ] with each ;
M: book focusable-child* current-page ;
M: book focusable-child* ( book -- child/t ) current-page ;

12
extra/ui/gadgets/frame-buffer/frame-buffer.factor
View File

@ -7,7 +7,7 @@ IN: ui.gadgets.frame-buffer
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -18,13 +18,15 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <frame-buffer> ( -- frame-buffer )
frame-buffer construct-gadget
: new-frame-buffer ( class -- gadget )
new-gadget
[ ] >>action
{ 100 100 } >>dim
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-pixels ( fb -- fb )
@ -44,7 +46,7 @@ TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: frame-buffer pref-dim* dim>> ;
M: frame-buffer pref-dim* pdim>> ;
M: frame-buffer graft* graft>> call ;
M: frame-buffer ungraft* ungraft>> call ;

12
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -7,9 +7,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add* } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
@ -22,7 +20,7 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
: $ui-frame-constant ( element -- )
drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
{ $description "Symbolic constant for a common input to " { $link grid-add* } "." } print-element ;
HELP: @center $ui-frame-constant ;
HELP: @left $ui-frame-constant ;
@ -37,16 +35,12 @@ HELP: @bottom-right $ui-frame-constant ;
HELP: frame
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
$nl
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add* } " and " { $link grid-remove } "." } ;
HELP: <frame>
{ $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
{ grid frame } related-words
ABOUT: "ui-frame-layout"

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

@ -38,6 +38,3 @@ M: frame layout*
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
: frame, ( gadget i j -- )
gadget get -rot grid-add ;

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables kernel models math namespaces
sequences quotations math.vectors combinators sorting vectors
dlists dequeues models threads concurrency.flags
math.order math.geometry.rect ;
sequences quotations math.vectors combinators sorting
binary-search vectors dlists dequeues models threads
concurrency.flags math.order math.geometry.rect ;
IN: ui.gadgets
@ -70,12 +70,15 @@ GENERIC: children-on ( rect/point gadget -- seq )
M: gadget children-on nip children>> ;
: (fast-children-on) ( dim axis gadgets -- i )
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
: ((fast-children-on)) ( gadget dim axis -- <=> )
[ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i )
-rot [ ((fast-children-on)) ] 2curry search drop ;
: fast-children-on ( rect axis children -- from to )
[ >r >r rect-loc r> r> (fast-children-on) 0 or ]
[ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
[ [ rect-loc ] 2dip (fast-children-on) 0 or ]
[ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
3bi ;
: inside? ( bounds gadget -- ? )
@ -358,10 +361,6 @@ M: f request-focus-on 2drop ;
[ focus>> ] follow ;
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ (>>parent) ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

6
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -7,7 +7,7 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-add* }
{ $subsection grid-remove }
{ $subsection grid-child } ;
@ -18,7 +18,7 @@ $nl
$nl
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
$nl
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add* } " and " { $link grid-remove } "."
$nl
"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
@ -31,7 +31,7 @@ HELP: grid-child
{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
{ $errors "Throws an error if the indices are out of bounds." } ;
HELP: grid-add
HELP: grid-add*
{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location." }
{ $side-effects "grid" } ;

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

@ -20,14 +20,12 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- )
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid )
>r >r dupd swap r> r>
>r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
: grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add* ;
: pref-dim-grid ( grid -- dims )
grid>> [ [ pref-dim ] map ] map ;

8
extra/ui/gadgets/handler/handler.factor
View File

@ -1,11 +1,11 @@
USING: kernel assocs ui.gestures ;
USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
IN: ui.gadgets.handler
TUPLE: handler table ;
TUPLE: handler < wrapper table ;
C: <handler> handler
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture* ( gadget gesture delegate -- ? )
handler-table at dup [ call f ] [ 2drop t ] if ;
table>> at dup [ call f ] [ 2drop t ] if ;

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

@ -1,66 +1,55 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors math.geometry.rect ;
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors math.geometry.rect ;
IN: ui.gadgets.panes
TUPLE: pane < pack
output current prototype scrolls?
selection-color caret mark selecting? ;
output current prototype scrolls?
selection-color caret mark selecting? ;
: clear-selection ( pane -- )
f >>caret
f >>mark
drop ;
: clear-selection ( pane -- pane ) f >>caret f >>mark ;
: add-output ( current pane -- )
[ set-pane-output ] [ swap add-gadget drop ] 2bi ;
: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
: add-current ( current pane -- )
[ set-pane-current ] [ swap add-gadget drop ] 2bi ;
: prepare-line ( pane -- pane )
clear-selection
dup prototype>> clone add-current ;
: prepare-line ( pane -- )
[ clear-selection ]
[ [ pane-prototype clone ] keep add-current ] bi ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection
selected-children gadget-text ;
M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
: pane-clear ( pane -- )
[ clear-selection ]
[ pane-output clear-incremental ]
[ pane-current clear-gadget ]
tri ;
: pane-theme ( pane -- pane )
selection-color >>selection-color ; inline
clear-selection
[ pane-output clear-incremental ]
[ pane-current clear-gadget ]
bi ;
: new-pane ( class -- pane )
new-gadget
{ 0 1 } >>orientation
<shelf> >>prototype
<incremental> over add-output
dup prepare-line
pane-theme ;
<incremental> add-output
prepare-line
selection-color >>selection-color ;
: <pane> ( -- pane )
pane new-pane ;
: <pane> ( -- pane ) pane new-pane ;
GENERIC: draw-selection ( loc obj -- )
@ -102,25 +91,25 @@ C: <pane-stream> pane-stream
: smash-pane ( pane -- gadget ) pane-output smash-line ;
: pane-nl ( pane -- )
: pane-nl ( pane -- pane )
dup pane-current dup unparent smash-line
over pane-output add-incremental
prepare-line ;
: pane-write ( pane seq -- )
[ dup pane-nl ]
[ pane-nl ]
[ over pane-current stream-write ]
interleave drop ;
: pane-format ( style pane seq -- )
[ dup pane-nl ]
[ pane-nl ]
[ 2over pane-current stream-format ]
interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget
pane-stream-pane pane-current swap add-gadget drop ;
M: pane-stream write-gadget ( gadget pane-stream -- )
pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
@ -148,8 +137,8 @@ M: style-stream write-gadget
TUPLE: pane-control < pane quot ;
M: pane-control model-changed
swap model-value swap dup pane-control-quot with-pane ;
M: pane-control model-changed ( model pane-control -- )
[ value>> ] [ dup quot>> ] bi* with-pane ;
: <pane-control> ( model quot -- pane )
pane-control new-pane
@ -160,7 +149,7 @@ M: pane-control model-changed
>r pane-stream-pane r> keep scroll-pane ; inline
M: pane-stream stream-nl
[ pane-nl ] do-pane-stream ;
[ pane-nl drop ] do-pane-stream ;
M: pane-stream stream-write1
[ pane-current stream-write1 ] do-pane-stream ;
@ -337,15 +326,14 @@ M: paragraph stream-format
2drop
] if ;
: caret>mark ( pane -- )
dup pane-caret over set-pane-mark relayout-1 ;
: caret>mark ( pane -- pane )
dup caret>> >>mark
dup relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n )
M: pack sloppy-pick-up*
dup gadget-orientation
swap gadget-children
(fast-children-on) ;
M: pack sloppy-pick-up* ( loc gadget -- n )
[ orientation>> ] [ children>> ] bi (fast-children-on) ;
M: gadget sloppy-pick-up*
gadget-children [ inside? ] with find-last drop ;
@ -362,25 +350,25 @@ M: f sloppy-pick-up*
[ 3drop { } ]
if ;
: move-caret ( pane -- )
dup hand-rel
over sloppy-pick-up
over set-pane-caret
relayout-1 ;
: move-caret ( pane -- pane )
dup hand-rel
over sloppy-pick-up
over set-pane-caret
dup relayout-1 ;
: begin-selection ( pane -- )
dup move-caret f swap set-pane-mark ;
move-caret f swap set-pane-mark ;
: extend-selection ( pane -- )
hand-moved? [
dup selecting?>> [
dup move-caret
move-caret
] [
dup hand-clicked get child? [
t >>selecting?
dup hand-clicked set-global
dup move-caret
dup caret>mark
move-caret
caret>mark
] when
] if
dup dup pane-caret gadget-at-path scroll>gadget
@ -395,8 +383,8 @@ M: f sloppy-pick-up*
] if ;
: select-to-caret ( pane -- )
dup pane-mark [ dup caret>mark ] unless
dup move-caret
dup pane-mark [ caret>mark ] unless
move-caret
dup request-focus
com-copy-selection ;

123
extra/ui/gadgets/slate/slate.factor
View File

@ -1,122 +1,21 @@
USING: kernel namespaces opengl ui.render ui.gadgets ;
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
IN: ui.gadgets.slate
TUPLE: slate action dim graft ungraft
button-down
button-up
key-down
key-up ;
TUPLE: slate < gadget action pdim graft ungraft ;
: <slate> ( action -- slate )
slate construct-gadget
tuck set-slate-action
{ 100 100 } over set-slate-dim
[ ] over set-slate-graft
[ ] over set-slate-ungraft ;
slate new-gadget
swap >>action
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
M: slate pref-dim* ( slate -- dim ) slate-dim ;
M: slate pref-dim* ( slate -- dim ) pdim>> ;
M: slate draw-gadget* ( slate -- )
origin get swap slate-action with-translation ;
M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
M: slate graft* ( slate -- ) slate-graft call ;
M: slate graft* ( slate -- ) graft>> call ;
M: slate ungraft* ( slate -- ) ungraft>> call ;
M: slate ungraft* ( slate -- ) slate-ungraft call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-pressed-value
: key-pressed? ( -- ? ) key-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: mouse-pressed-value
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-value
: key ( -- key ) key-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: button-value
: button ( -- val ) button-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators ui.gestures accessors ;
! M: slate handle-gesture* ( gadget gesture delegate -- ? )
! drop nip
! {
! {
! [ dup key-down? ]
! [
! key-down-sym key-value set
! key-pressed-value on
! t
! ]
! }
! { [ dup key-up? ] [ drop key-pressed-value off t ] }
! {
! [ dup button-down? ]
! [
! button-down-# mouse-button-value set
! mouse-pressed-value on
! t
! ]
! }
! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
! { [ t ] [ drop t ] }
! }
! cond ;
M: slate handle-gesture* ( gadget gesture delegate -- ? )
rot drop swap ! delegate gesture
{
{
[ dup key-down? ]
[
key-down-sym key-value set
key-pressed-value on
key-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup key-up? ]
[
key-pressed-value off
drop
key-up>> dup [ call ] [ drop ] if
t
] }
{
[ dup button-down? ]
[
button-down-# button-value set
mouse-pressed-value on
button-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup button-up? ]
[
mouse-pressed-value off
drop
button-up>> dup [ call ] [ drop ] if
t
]
}
{ [ t ] [ 2drop t ] }
}
cond ;

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

@ -9,27 +9,21 @@ IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
: find-elevator ( gadget -- elevator/f )
[ elevator? ] find-parent ;
: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
TUPLE: slider < frame elevator thumb saved line ;
: find-slider ( gadget -- slider/f )
[ slider? ] find-parent ;
: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
: elevator-length ( slider -- n )
dup slider-elevator rect-dim
swap gadget-orientation v. ;
[ elevator>> dim>> ] [ orientation>> ] bi v. ;
: min-thumb-dim 15 ;
: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
: slider-page ( gadget -- n ) gadget-model range-page-value ;
: slider-max ( gadget -- n ) gadget-model range-max-value ;
: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
: slider-page ( gadget -- n ) gadget-model range-page-value ;
: slider-max ( gadget -- n ) gadget-model range-max-value ;
: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
: thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min
@ -45,7 +39,6 @@ TUPLE: slider < frame elevator thumb saved line ;
swap slider-max* 1 max / ;
: slider>screen ( m scale -- n ) slider-scale * ;
: screen>slider ( m scale -- n ) slider-scale / ;
M: slider model-changed nip slider-elevator relayout-1 ;
@ -76,11 +69,9 @@ thumb H{
t >>root?
thumb-theme ;
: slide-by ( amount slider -- )
gadget-model move-by ;
: slide-by ( amount slider -- ) gadget-model move-by ;
: slide-by-page ( amount slider -- )
gadget-model move-by-page ;
: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
: compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel
@ -100,13 +91,10 @@ elevator H{
{ T{ button-down } [ elevator-click ] }
} set-gestures
: elevator-theme ( elevator -- )
lowered-gradient swap set-gadget-interior ;
: <elevator> ( vector -- elevator )
elevator new-gadget
[ set-gadget-orientation ] keep
dup elevator-theme ;
elevator new-gadget
swap >>orientation
lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb )
over gadget-orientation n*v swap slider-thumb ;
@ -144,17 +132,10 @@ M: elevator layout*
dup elevator>> over thumb>> add-gadget
@center grid-add* ;
: <left-button> ( -- button )
{ 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button )
{ 0 1 } arrow-right 1 <slide-button> ;
: <up-button> ( -- button )
{ 1 0 } arrow-up -1 <slide-button> ;
: <down-button> ( -- button )
{ 1 0 } arrow-down 1 <slide-button> ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
: <slider> ( range orientation -- slider )
slider new-frame

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

@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ swap 1 track-add ]
[ 1 track-add* drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;

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

@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
: open-status-window ( gadget title -- )
f <model> [ <world> ] keep
<status-bar> over f track-add
<status-bar> f track-add*
open-world-window ;
: show-summary ( object gadget -- )

4
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add } ;
{ $subsection track-add* } ;
HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -17,7 +17,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
HELP: track-add
HELP: track-add*
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;

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

@ -41,14 +41,11 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]
[ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ]
tri
set-axis ;
: track-add ( gadget track constraint -- )
over track-sizes push swap add-gadget drop ;
: track-add* ( track gadget constraint -- track )
pick sizes>> push add-gadget ;

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

@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
{ 0 0 } >>window-loc
swap >>status
swap >>title
[ 1 track-add ] keep
swap 1 track-add*
dup request-focus ;
M: world layout*

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

@ -1,22 +1,18 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.gadgets kernel ;
IN: ui.gadgets.wrappers
TUPLE: wrapper < gadget ;
: new-wrapper ( child class -- wrapper )
new-gadget
[ swap add-gadget drop ] keep ; inline
: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
: <wrapper> ( child -- border )
wrapper new-wrapper ;
: <wrapper> ( child -- border ) wrapper new-wrapper ;
M: wrapper pref-dim*
gadget-child pref-dim ;
M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
M: wrapper layout*
M: wrapper layout* ( wrapper -- )
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
M: wrapper focusable-child*
gadget-child ;
M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;

8
extra/ui/tools/workspace/workspace.factor
View File

@ -60,10 +60,10 @@ M: gadget tool-scroller drop f ;
request-focus ;
: show-popup ( gadget workspace -- )
dup hide-popup
2dup set-workspace-popup
dupd f track-add
request-focus ;
dup hide-popup
over >>popup
over f track-add* drop
request-focus ;
: show-titled-popup ( workspace gadget title -- )
[ find-workspace hide-popup ] <closable-gadget>

4
extra/usa-cities/usa-cities.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv symbols summary
words accessors math.order sorting ;
words accessors math.order binary-search ;
IN: usa-cities
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
@ -50,4 +50,4 @@ MEMO: cities-named-in ( name state -- cities )
] with with filter ;
: find-zip-code ( code -- city )
cities [ first-zip>> <=> ] binsearch* ;
cities [ first-zip>> <=> ] with search nip ;