diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 45bc5bf50a..627fd95384 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -220,7 +220,7 @@ M: assert error.
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output ;
+ ] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ;
diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
index 173187574b..cac7fd9a2f 100644
--- a/basis/globs/globs.factor
+++ b/basis/globs/globs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case
+USING: sequences kernel regexp.combinators strings unicode.case
peg.ebnf regexp arrays ;
IN: globs
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 57f64459c8..2281c295c3 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
[ check-descriptions ]
} cleave ;
+: check-class-description ( word element -- )
+ [ class? not ]
+ [ { $class-description } swap elements empty? not ] bi* and
+ [ "A word that is not a class has a $class-description" throw ] when ;
+
: all-word-help ( words -- seq )
[ word-help ] filter ;
@@ -153,7 +158,8 @@ M: help-error error.
dup '[
_ dup word-help
[ check-values ]
- [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
+ [ check-class-description ]
+ [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
] check-something
] [ drop ] if ;
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index d4f664d6ff..188cdd1cf8 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -13,7 +13,6 @@ PREDICATE: simple-element < array
SYMBOL: last-element
SYMBOL: span
SYMBOL: block
-SYMBOL: table
: last-span? ( -- ? ) last-element get span eq? ;
: last-block? ( -- ? ) last-element get block eq? ;
@@ -44,7 +43,7 @@ M: f print-element drop ;
[ print-element ] with-default-style ;
: ($block) ( quot -- )
- last-element get { f table } member? [ nl ] unless
+ last-element get [ nl ] when
span last-element set
call
block last-element set ; inline
@@ -218,7 +217,7 @@ ALIAS: $slot $snippet
table-content-style get [
swap [ last-element off call ] tabular-output
] with-style
- ] ($block) table last-element set ; inline
+ ] ($block) ; inline
: $list ( element -- )
list-style get [
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 88eb984488..cf16df7d82 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap )
load-bitmap-data process-bitmap-data
fill-image-slots ;
-M: bitmap-image normalize-scan-line-order
- dup dim>> '[
- _ first 4 * <sliced-groups> reverse concat
- ] change-bitmap ;
-
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap-image new
@@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- )
swap >>width
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
+ t >>upside-down?
] ;
: bgr>bitmap ( array height width -- bitmap )
diff --git a/basis/images/images.factor b/basis/images/images.factor
index 82576774f4..cb44825e62 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
{ R32G32B32A32 [ 16 ] }
} case ;
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
@@ -82,11 +82,16 @@ M: ARGB normalize-component-order*
M: ABGR normalize-component-order*
drop ARGB>RGBA 4 BGR>RGB ;
-GENERIC: normalize-scan-line-order ( image -- image )
-
-M: image normalize-scan-line-order ;
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
- normalize-scan-line-order ;
+ normalize-scan-line-order
+ RGBA >>component-order ;
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index a50ac0cad9..2ea1b08e20 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
- [ ifd-component-order ]
+ [ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;
diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor
index 05c4dc2a94..8cab5b5ad3 100644
--- a/basis/inspector/inspector.factor
+++ b/basis/inspector/inspector.factor
@@ -9,7 +9,7 @@ IN: inspector
SYMBOL: +number-rows+
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: print-summary ( obj -- ) [ summary ] keep write-object ;
<PRIVATE
@@ -40,7 +40,7 @@ M: mirror fix-slot-names
: (describe) ( obj assoc -- keys )
t pprint-string-cells? [
- [ summary. ] [
+ [ print-summary nl ] [
dup hashtable? [ sort-unparsed-keys ] when
[ fix-slot-names add-numbers simple-table. ] [ keys ] bi
] bi*
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 8e93dc9450..55dc6ca9a4 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -97,7 +97,7 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-output-stream* ;
+ [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 2ee0832269..78a9c03d20 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -84,7 +84,7 @@ SYMBOL: max-stack-items
bi
] with-row
] each
- ] tabular-output
+ ] tabular-output nl
] unless-empty ;
: trimmed-stack. ( seq -- )
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index 79af9be48b..48cdafb837 100644
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -11,14 +11,16 @@ IN: opengl.textures
TUPLE: texture loc dim texture-coords texture display-list disposed ;
-<PRIVATE
-
GENERIC: component-order>format ( component-order -- format type )
+M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
+M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+<PRIVATE
+
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 63d7bf217a..af56a4d2d0 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -165,7 +165,7 @@ SYMBOL: pprint-string-cells?
] each
] with-row
] each
- ] tabular-output ;
+ ] tabular-output nl ;
GENERIC: see ( defspec -- )
diff --git a/basis/regexp/classes/classes-tests.factor b/basis/regexp/classes/classes-tests.factor
index 520e23c749..2deb944b61 100644
--- a/basis/regexp/classes/classes-tests.factor
+++ b/basis/regexp/classes/classes-tests.factor
@@ -30,15 +30,15 @@ IN: regexp.classes.tests
[ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
[ f ] [ t <not-class> ] unit-test
[ t ] [ f <not-class> ] unit-test
-[ f ] [ 1 <not-class> 1 t replace-question ] unit-test
+[ f ] [ 1 <not-class> 1 t answer ] unit-test
! Making classes into nested conditionals
[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
-[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t answer ] unit-test
-[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f answer ] unit-test
+[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
+[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test
[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
SYMBOL: foo
@@ -46,13 +46,13 @@ SYMBOL: bar
[ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test
-[ t ] [ foo <primitive-class> dup t replace-question ] unit-test
-[ f ] [ foo <primitive-class> dup f replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t replace-question ] unit-test
-[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f replace-question ] unit-test
-[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f replace-question ] unit-test
-[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f replace-question ] unit-test
+[ t ] [ foo <primitive-class> dup t answer ] unit-test
+[ f ] [ foo <primitive-class> dup f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f answer ] unit-test
+[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f answer ] unit-test
diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor
index 8912082ec3..4ddd470189 100644
--- a/basis/regexp/classes/classes.factor
+++ b/basis/regexp/classes/classes.factor
@@ -163,20 +163,32 @@ M: integer combine-or
: try-combine ( elt1 elt2 quot -- combined/f ? )
3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
+DEFER: answer
+
+:: try-cancel ( elt1 elt2 empty -- combined/f ? )
+ [ elt1 elt2 empty answer dup elt1 = not ] try-combine ;
+
:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
f :> combined!
- seq [ elt quot try-combine swap combined! ] find drop
+ seq [ elt quot call swap combined! ] find drop
[ seq remove-nth combined prefix ]
[ seq elt prefix ] if* ; inline
+: combine-by ( seq quot -- new-seq )
+ { } swap '[ _ prefix-combining ] reduce ; inline
+
+:: seq>instance ( seq empty class -- instance )
+ seq length {
+ { 0 [ empty ] }
+ { 1 [ seq first ] }
+ [ drop class new seq >>seq ]
+ } case ; inline
+
:: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq )
seq class flatten
- { } [ quot prefix-combining ] reduce
- dup length {
- { 0 [ drop empty ] }
- { 1 [ first ] }
- [ drop class new swap >>seq ]
- } case ; inline
+ [ quot try-combine ] combine-by
+ ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4)
+ empty class seq>instance ; inline
: <and-class> ( seq -- class )
[ combine-and ] t and-class combine ;
@@ -218,36 +230,36 @@ UNION: class primitive-class not-class or-class and-class range ;
TUPLE: condition question yes no ;
C: <condition> condition
-GENERIC# replace-question 2 ( class from to -- new-class )
+GENERIC# answer 2 ( class from to -- new-class )
-M:: object replace-question ( class from to -- new-class )
+M:: object answer ( class from to -- new-class )
class from = to class ? ;
: replace-compound ( class from to -- seq )
- [ seq>> ] 2dip '[ _ _ replace-question ] map ;
+ [ seq>> ] 2dip '[ _ _ answer ] map ;
-M: and-class replace-question
+M: and-class answer
replace-compound <and-class> ;
-M: or-class replace-question
+M: or-class answer
replace-compound <or-class> ;
-M: not-class replace-question
- [ class>> ] 2dip replace-question <not-class> ;
+M: not-class answer
+ [ class>> ] 2dip answer <not-class> ;
-: answer ( table question answer -- new-table )
- '[ _ _ replace-question ] assoc-map
+: assoc-answer ( table question answer -- new-table )
+ '[ _ _ answer ] assoc-map
[ nip ] assoc-filter ;
-: answers ( table questions answer -- new-table )
- '[ _ answer ] each ;
+: assoc-answers ( table questions answer -- new-table )
+ '[ _ assoc-answer ] each ;
DEFER: make-condition
: (make-condition) ( table questions question -- condition )
[ 2nip ]
- [ swap [ t answer ] dip make-condition ]
- [ swap [ f answer ] dip make-condition ] 3tri
+ [ swap [ t assoc-answer ] dip make-condition ]
+ [ swap [ f assoc-answer ] dip make-condition ] 3tri
2dup = [ 2nip ] [ <condition> ] if ;
: make-condition ( table questions -- condition )
diff --git a/basis/regexp/combinators/combinators-tests.factor b/basis/regexp/combinators/combinators-tests.factor
index 0ba2831842..ddfd0dcaad 100644
--- a/basis/regexp/combinators/combinators-tests.factor
+++ b/basis/regexp/combinators/combinators-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ;
+USING: regexp.combinators tools.test regexp kernel sequences ;
IN: regexp.combinators.tests
: strings ( -- regexp )
@@ -16,7 +16,7 @@ USE: multiline
{ R' .*a' R' b.*' } <and> ;
[ t ] [ "bljhasflsda" conj matches? ] unit-test
-[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail?
+[ f ] [ "bsdfdfs" conj matches? ] unit-test
[ f ] [ "fsfa" conj matches? ] unit-test
[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor
index 4e615d15d7..0e0c0eaae6 100644
--- a/basis/regexp/compiler/compiler.factor
+++ b/basis/regexp/compiler/compiler.factor
@@ -1,19 +1,19 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.classes kernel sequences regexp.negation
-quotations regexp.minimize assocs fry math locals combinators
+quotations assocs fry math locals combinators
accessors words compiler.units kernel.private strings
-sequences.private arrays regexp.matchers call namespaces
+sequences.private arrays call namespaces
regexp.transition-tables combinators.short-circuit ;
IN: regexp.compiler
GENERIC: question>quot ( question -- quot )
-<PRIVATE
-
SYMBOL: shortest?
SYMBOL: backwards?
+<PRIVATE
+
M: t question>quot drop [ 2drop t ] ;
M: beginning-of-input question>quot
@@ -64,7 +64,7 @@ C: <box> box
: non-literals>dispatch ( literals non-literals -- quot )
[ swap ] assoc-map ! we want state => predicate, and get the opposite as input
- swap keys f answers
+ swap keys f assoc-answers
table>condition [ <box> ] condition-map condition>quot ;
: literals>cases ( literal-transitions -- case-body )
@@ -106,13 +106,15 @@ C: <box> box
transitions>quot ;
: states>code ( words dfa -- )
- '[
+ [ ! with-compilation-unit doesn't compile, so we need call( -- )
[
- dup _ word>quot
- (( last-match index string -- ? ))
- define-declared
- ] each
- ] with-compilation-unit ;
+ '[
+ dup _ word>quot
+ (( last-match index string -- ? ))
+ define-declared
+ ] each
+ ] with-compilation-unit
+ ] call( words dfa -- ) ;
: states>words ( dfa -- words dfa )
dup transitions>> keys [ gensym ] H{ } map>assoc
@@ -120,34 +122,23 @@ C: <box> box
[ values ]
bi swap ;
-: dfa>word ( dfa -- word )
+: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
-: check-string ( string -- string )
- ! Make this configurable
- dup string? [ "String required" throw ] unless ;
-
-: setup-regexp ( start-index string -- f start-index string )
- [ f ] [ >fixnum ] [ check-string ] tri* ; inline
-
PRIVATE>
-! The quotation returned is ( start-index string -- i/f )
+: simple-define-temp ( quot effect -- word )
+ [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
-: dfa>quotation ( dfa -- quot )
- dfa>word execution-quot '[ setup-regexp @ ] ;
+: dfa>word ( dfa -- quot )
+ dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+ (( start-index string regexp -- i/f )) simple-define-temp ;
-: dfa>shortest-quotation ( dfa -- quot )
- t shortest? [ dfa>quotation ] with-variable ;
+: dfa>shortest-word ( dfa -- word )
+ t shortest? [ dfa>word ] with-variable ;
-: dfa>reverse-quotation ( dfa -- quot )
- t backwards? [ dfa>quotation ] with-variable ;
+: dfa>reverse-word ( dfa -- word )
+ t backwards? [ dfa>word ] with-variable ;
-: dfa>reverse-shortest-quotation ( dfa -- quot )
- t backwards? [ dfa>shortest-quotation ] with-variable ;
-
-TUPLE: quot-matcher quot ;
-C: <quot-matcher> quot-matcher
-
-M: quot-matcher match-index-from
- quot>> call( index string -- i/f ) ;
+: dfa>reverse-shortest-word ( dfa -- word )
+ t backwards? [ dfa>shortest-word ] with-variable ;
diff --git a/basis/regexp/negation/negation.factor b/basis/regexp/negation/negation.factor
index 0633dca192..8b0a2f6edf 100644
--- a/basis/regexp/negation/negation.factor
+++ b/basis/regexp/negation/negation.factor
@@ -6,9 +6,6 @@ regexp.ast regexp.transition-tables regexp.minimize
regexp.dfa namespaces ;
IN: regexp.negation
-: ast>dfa ( parse-tree -- minimal-dfa )
- construct-nfa disambiguate construct-dfa minimize ;
-
CONSTANT: fail-state -1
: add-default-transition ( state's-transitions -- new-state's-transitions )
@@ -49,5 +46,8 @@ CONSTANT: fail-state -1
[ final-states>> keys first ]
[ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
+: ast>dfa ( parse-tree -- minimal-dfa )
+ construct-nfa disambiguate construct-dfa minimize ;
+
M: negation nfa-node ( node -- start end )
term>> ast>dfa negate-table adjoin-dfa ;
diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor
index d77abe877e..1d28e5e92f 100644
--- a/basis/regexp/regexp-docs.factor
+++ b/basis/regexp/regexp-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings help.markup help.syntax regexp.matchers math ;
+USING: kernel strings help.markup help.syntax math ;
IN: regexp
ABOUT: "regexp"
@@ -39,13 +39,14 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
-{ $subsection all-matches }
{ $subsection matches? }
+{ $subsection re-contains? }
+{ $subsection first-match }
+{ $subsection all-matches }
{ $subsection re-split1 }
{ $subsection re-split }
{ $subsection re-replace }
-{ $subsection count-matches }
-{ $subsection re-replace } ;
+{ $subsection count-matches } ;
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
@@ -63,25 +64,33 @@ HELP: regexp
{ $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
HELP: matches?
-{ $values { "string" string } { "matcher" regexp } { "?" "a boolean" } }
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
{ $description "Tests if the string as a whole matches the given regular expression." } ;
HELP: re-split1
-{ $values { "string" string } { "matcher" regexp } { "before" string } { "after/f" string } }
+{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } }
{ $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ;
HELP: all-matches
-{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
{ $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ;
HELP: count-matches
-{ $values { "string" string } { "matcher" regexp } { "n" integer } }
+{ $values { "string" string } { "regexp" regexp } { "n" integer } }
{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matches } "." } ;
HELP: re-split
-{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
+{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matches } "." } ;
HELP: re-replace
-{ $values { "string" string } { "matcher" regexp } { "replacement" string } { "result" string } }
+{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } }
{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matches } "." } ;
+
+HELP: first-match
+{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } }
+{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ;
+
+HELP: re-contains?
+{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
+{ $description "Determines whether the string has a substring which matches the regular expression given." } ;
diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor
index 0a448ed276..f05416ab94 100644
--- a/basis/regexp/regexp-tests.factor
+++ b/basis/regexp/regexp-tests.factor
@@ -1,13 +1,12 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp tools.test kernel sequences regexp.parser regexp.private
-eval strings multiline accessors regexp.matchers ;
+eval strings multiline accessors ;
IN: regexp-tests
\ <regexp> must-infer
-! the following don't compile because [ ] with-compilation-unit doesn't compile
-! \ compile-regexp must-infer
-! \ matches? must-infer
+\ compile-regexp must-infer
+\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
@@ -212,8 +211,8 @@ IN: regexp-tests
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
-[ 3 ] [ "aaacb" "a*" <regexp> match-index-head ] unit-test
-[ 2 ] [ "aaacb" "aa?" <regexp> match-index-head ] unit-test
+[ "aaa" ] [ "aaacb" "a*" <regexp> first-match >string ] unit-test
+[ "aa" ] [ "aaacb" "aa?" <regexp> first-match >string ] unit-test
[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
[ f ] [ "aax" R/ AAA/i matches? ] unit-test
@@ -240,11 +239,11 @@ IN: regexp-tests
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
-[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test
-[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test
+[ t ] [ "abc" R/ abc/r matches? ] unit-test
+[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test
-[ t ] [ 3 "xabc" R/ abc/ <reverse-matcher> match-index-from >boolean ] unit-test
-[ t ] [ 3 "xabc" R/ a[bB][cC]/ <reverse-matcher> match-index-from >boolean ] unit-test
+[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
+[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@@ -269,13 +268,13 @@ IN: regexp-tests
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
-[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
-[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
+[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
+[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
-[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
-[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
+[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
+[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
-[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> match-head >string ] unit-test
+[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@@ -301,18 +300,18 @@ IN: regexp-tests
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
-[ "" ] [ "ab" "a(?!b)" <regexp> match-head >string ] unit-test
-[ "a" ] [ "ac" "a(?!b)" <regexp> match-head >string ] unit-test
+[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
[ t ] [ "fxxbar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "foobar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
-[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> match-head >string ] unit-test
-[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> match-head >string ] unit-test
-[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> match-head >string ] unit-test
+[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
+[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> first-match >string ] unit-test
+[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> first-match >string ] unit-test
-[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-index-head ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-index-head ] unit-test
+[ 3 ] [ "foobar" "foo(?=bar)" <regexp> first-match length ] unit-test
+[ f ] [ "foobxr" "foo(?=bar)" <regexp> first-match ] unit-test
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
@@ -342,9 +341,19 @@ IN: regexp-tests
[ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test
+[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ f ] [ "πb" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "πc" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
+
! DFA is compiled when needed, or when literal
-[ f ] [ "foo" <regexp> dfa>> >boolean ] unit-test
-[ t ] [ R/ foo/ dfa>> >boolean ] unit-test
+[ regexp-initial-word ] [ "foo" <regexp> dfa>> ] unit-test
+[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test
[ t ] [ "a" R/ ^a/ matches? ] unit-test
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
@@ -415,8 +424,12 @@ IN: regexp-tests
[ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test
[ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test
-[ f ] [ "foobxr" "foo\\z" <regexp> match-index-head ] unit-test
-[ 3 ] [ "foo" "foo\\z" <regexp> match-index-head ] unit-test
+[ f ] [ "foobxr" "foo\\z" <regexp> first-match ] unit-test
+[ 3 ] [ "foo" "foo\\z" <regexp> first-match length ] unit-test
+
+[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test
+[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
+[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor
index f938ddf60a..90218e05bd 100644
--- a/basis/regexp/regexp.factor
+++ b/basis/regexp/regexp.factor
@@ -2,71 +2,166 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math sequences strings sets
assocs prettyprint.backend prettyprint.custom make lexer
-namespaces parser arrays fry locals regexp.minimize
-regexp.parser regexp.nfa regexp.dfa regexp.classes
-regexp.transition-tables splitting sorting regexp.ast
-regexp.negation regexp.matchers regexp.compiler ;
+namespaces parser arrays fry locals regexp.parser splitting
+sorting regexp.ast regexp.negation regexp.compiler words
+call call.private math.ranges ;
IN: regexp
TUPLE: regexp
{ raw read-only }
{ parse-tree read-only }
{ options read-only }
- dfa reverse-dfa ;
+ dfa next-match ;
-: make-regexp ( string ast -- regexp )
- f f <options> f f regexp boa ; foldable
- ! Foldable because, when the dfa slot is set,
- ! it'll be set to the same thing regardless of who sets it
+TUPLE: reverse-regexp < regexp ;
-: <optioned-regexp> ( string options -- regexp )
- [ dup parse-regexp ] [ string>options ] bi*
- f f regexp boa ;
+<PRIVATE
-: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
+: maybe-negated ( lookaround quot -- regexp-quot )
+ '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
-TUPLE: reverse-matcher regexp ;
-C: <reverse-matcher> reverse-matcher
-! Reverse matchers won't work properly with most combinators, for now
+M: lookahead question>quot ! Returns ( index string -- ? )
+ [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ;
+
+: <reversed-option> ( ast -- reversed )
+ "r" string>options <with-options> ;
+
+M: lookbehind question>quot ! Returns ( index string -- ? )
+ [
+ <reversed-option>
+ ast>dfa dfa>reverse-shortest-word
+ '[ [ 1- ] dip f _ execute ]
+ ] maybe-negated ;
+
+<PRIVATE
+
+: check-string ( string -- string )
+ ! Make this configurable
+ dup string? [ "String required" throw ] unless ;
+
+: match-index-from ( i string regexp -- index/f )
+ ! This word is unsafe. It assumes that i is a fixnum
+ ! and that string is a string.
+ dup dfa>> execute( index string regexp -- i/f ) ;
+
+GENERIC: end/start ( string regexp -- end start )
+M: regexp end/start drop length 0 ;
+M: reverse-regexp end/start drop length 1- -1 swap ;
+
+PRIVATE>
+
+: matches? ( string regexp -- ? )
+ [ end/start ] 2keep
+ [ check-string ] dip
+ match-index-from
+ [ swap = ] [ drop f ] if* ;
+
+<PRIVATE
+
+: match-slice ( i string quot -- slice/f )
+ [ 2dup ] dip call
+ [ swap <slice> ] [ 2drop f ] if* ; inline
+
+: match-from ( i string quot -- slice/f )
+ [ [ length [a,b) ] keep ] dip
+ '[ _ _ match-slice ] map-find drop ; inline
+
+: next-match ( i string quot -- i match/f )
+ match-from [ dup [ to>> ] when ] keep ; inline
+
+: do-next-match ( i string regexp -- i match/f )
+ dup next-match>> execute( i string regexp -- i match/f ) ;
+
+PRIVATE>
+
+: all-matches ( string regexp -- seq )
+ [ check-string ] dip
+ [ 0 [ dup ] ] 2dip '[ _ _ do-next-match ] produce
+ nip but-last ;
+
+: count-matches ( string regexp -- n )
+ all-matches length ;
+
+<PRIVATE
+
+:: split-slices ( string slices -- new-slices )
+ slices [ to>> ] map 0 prefix
+ slices [ from>> ] map string length suffix
+ [ string <slice> ] 2map ;
+
+PRIVATE>
+
+: first-match ( string regexp -- slice/f )
+ [ 0 ] [ check-string ] [ ] tri*
+ do-next-match nip ;
+
+: re-contains? ( string regexp -- ? )
+ first-match >boolean ;
+
+: re-split1 ( string regexp -- before after/f )
+ dupd first-match [ 1array split-slices first2 ] [ f ] if* ;
+
+: re-split ( string regexp -- seq )
+ dupd all-matches split-slices ;
+
+: re-replace ( string regexp replacement -- result )
+ [ re-split ] dip join ;
<PRIVATE
: get-ast ( regexp -- ast )
[ parse-tree>> ] [ options>> ] bi <with-options> ;
-: compile-regexp ( regexp -- regexp )
- dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ;
+GENERIC: compile-regexp ( regex -- regexp )
-: <reversed-option> ( ast -- reversed )
- "r" string>options <with-options> ;
+: regexp-initial-word ( i string regexp -- i/f )
+ compile-regexp match-index-from ;
-: maybe-negated ( lookaround quot -- regexp-quot )
- '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
-
-M: lookahead question>quot ! Returns ( index string -- ? )
- [ ast>dfa dfa>shortest-quotation ] maybe-negated ;
-
-M: lookbehind question>quot ! Returns ( index string -- ? )
- [
- <reversed-option>
- ast>dfa dfa>reverse-shortest-quotation
- [ [ 1- ] dip ] prepose
- ] maybe-negated ;
-
-: compile-reverse ( regexp -- regexp )
+: do-compile-regexp ( regexp -- regexp )
dup '[
- [
- _ get-ast <reversed-option>
- ast>dfa dfa>reverse-quotation
- ] unless*
- ] change-reverse-dfa ;
+ dup \ regexp-initial-word =
+ [ drop _ get-ast ast>dfa dfa>word ] when
+ ] change-dfa ;
-M: regexp match-index-from
- compile-regexp dfa>> <quot-matcher> match-index-from ;
+M: regexp compile-regexp ( regexp -- regexp )
+ do-compile-regexp ;
-M: reverse-matcher match-index-from
- regexp>> compile-reverse reverse-dfa>>
- <quot-matcher> match-index-from ;
+M: reverse-regexp compile-regexp ( regexp -- regexp )
+ t backwards? [ do-compile-regexp ] with-variable ;
+
+GENERIC: compile-next-match ( regexp -- regexp )
+
+: next-initial-word ( i string regexp -- i slice/f )
+ compile-next-match do-next-match ;
+
+M: regexp compile-next-match ( regexp -- regexp )
+ dup '[
+ dup \ next-initial-word = [
+ drop _ compile-regexp dfa>>
+ '[ _ '[ _ _ execute ] next-match ]
+ (( i string -- i match/f )) simple-define-temp
+ ] when
+ ] change-next-match ;
+
+! Write M: reverse-regexp compile-next-match
+
+PRIVATE>
+
+: new-regexp ( string ast options class -- regexp )
+ [ \ regexp-initial-word \ next-initial-word ] dip boa ; inline
+
+: make-regexp ( string ast -- regexp )
+ f f <options> regexp new-regexp ;
+
+: <optioned-regexp> ( string options -- regexp )
+ [ dup parse-regexp ] [ string>options ] bi*
+ dup on>> reversed-regexp swap member?
+ [ reverse-regexp new-regexp ]
+ [ regexp new-regexp ] if ;
+
+: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
+
+<PRIVATE
! The following two should do some caching
@@ -97,7 +192,7 @@ M: reverse-matcher match-index-from
: parsing-regexp ( accum end -- accum )
lexer get [ take-until ] [ parse-noblank-token ] bi
- <optioned-regexp> compile-regexp parsed ;
+ <optioned-regexp> compile-next-match parsed ;
PRIVATE>
@@ -120,3 +215,4 @@ M: regexp pprint*
[ options>> options>string % ] bi
] "" make
] keep present-text ;
+
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 78f357b1cb..9e867f4fbb 100755
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -155,7 +155,7 @@ M: object apply-object push-literal ;
"cannot-infer" word-prop rethrow ;
: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
+ [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
: infer-word ( word -- effect )
[
diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor
index 9b727b48de..3d9166aafa 100644
--- a/basis/tools/memory/memory.factor
+++ b/basis/tools/memory/memory.factor
@@ -63,11 +63,12 @@ PRIVATE>
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
- nl
+ nl nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
- ] tabular-output ;
+ ] tabular-output
+ nl ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
@@ -83,4 +84,4 @@ PRIVATE>
pick at pprint-cell
] with-row
] each 2drop
- ] tabular-output ;
+ ] tabular-output nl ;
diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor
index 19646e55c2..864a637096 100644
--- a/basis/tools/profiler/profiler.factor
+++ b/basis/tools/profiler/profiler.factor
@@ -46,9 +46,7 @@ IN: tools.profiler
profiler-usage counters ;
: counters. ( assoc -- )
- standard-table-style [
- sort-values simple-table.
- ] tabular-output ;
+ sort-values simple-table. ;
: profile. ( -- )
"Call counts for all words:" print
diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor
index fc4ba1f6b2..18dd8ce2b7 100644
--- a/basis/tools/threads/threads.factor
+++ b/basis/tools/threads/threads.factor
@@ -29,4 +29,4 @@ IN: tools.threads
threads >alist sort-keys values [
[ thread. ] with-row
] each
- ] tabular-output ;
+ ] tabular-output nl ;
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index 7896cabd2e..70588d5f21 100644
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -66,15 +66,18 @@ C: <vocab-author> vocab-author
: describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ;
+: files. ( seq -- )
+ snippet-style get [
+ code-style get [
+ [ nl ] [ [ string>> ] keep write-object ] interleave
+ ] with-nesting
+ ] with-style ;
+
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
- snippet-style get [
- code-style get [
- stack.
- ] with-nesting
- ] with-style
+ files.
] ($block)
] unless-empty ;
diff --git a/basis/ui/gadgets/glass/glass-docs.factor b/basis/ui/gadgets/glass/glass-docs.factor
new file mode 100644
index 0000000000..bd9028d414
--- /dev/null
+++ b/basis/ui/gadgets/glass/glass-docs.factor
@@ -0,0 +1,55 @@
+IN: ui.gadgets.glass
+USING: help.markup help.syntax ui.gadgets math.rectangles ;
+
+HELP: show-glass
+{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "."
+ $nl
+ "The child's position is calculated with a heuristic:"
+ { $list
+ "The child must fit inside the window"
+ { "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } }
+ { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+ }
+ "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
+
+HELP: hide-glass
+{ $values { "child" gadget } }
+{ $description "Hides a gadget displayed in a glass layer." } ;
+
+HELP: hide-glass-hook
+{ $values { "gadget" gadget } }
+{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ;
+
+HELP: pass-to-popup
+{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } }
+{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ;
+
+HELP: show-popup
+{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } }
+{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup."
+ $nl
+ "This word differs from " { $link show-glass } " in two respects:"
+ { $list
+ { "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" }
+ { "Pressing " { $snippet "ESC" } " with the popup visible will hide it" }
+ }
+} ;
+
+ARTICLE: "ui.gadgets.glass" "Glass layers"
+"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other."
+$nl
+"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "."
+$nl
+"Displaying a gadget in a glass layer:"
+{ $subsection show-glass }
+"Hiding a gadget in a glass layer:"
+{ $subsection hide-glass }
+"Callback generic invoked on the gadget when its glass layer is hidden:"
+{ $subsection hide-glass-hook }
+"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:"
+{ $subsection show-popup }
+{ $subsection pass-to-popup } ;
+
+ABOUT: "ui.gadgets.glass"
\ No newline at end of file
diff --git a/basis/ui/gadgets/glass/glass.factor b/basis/ui/gadgets/glass/glass.factor
index a8f438c85e..af169235b4 100644
--- a/basis/ui/gadgets/glass/glass.factor
+++ b/basis/ui/gadgets/glass/glass.factor
@@ -71,7 +71,7 @@ popup H{
{ T{ key-down f f "ESC" } [ hide-glass ] }
} set-gestures
-: pass-to-popup ( gesture interactor -- ? )
+: pass-to-popup ( gesture owner -- ? )
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )
diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor
index d7297217ed..ad0881a382 100644
--- a/basis/ui/gadgets/menus/menus-docs.factor
+++ b/basis/ui/gadgets/menus/menus-docs.factor
@@ -16,7 +16,7 @@ HELP: show-commands-menu
{ $notes "Useful for right-click context menus." } ;
ARTICLE: "ui.gadgets.menus" "Popup menus"
-"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "."
{ $subsection <commands-menu> }
{ $subsection show-menu }
{ $subsection show-commands-menu } ;
diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor
index 680b6fe57f..e486bffd38 100644
--- a/basis/ui/gadgets/panes/panes-tests.factor
+++ b/basis/ui/gadgets/panes/panes-tests.factor
@@ -19,7 +19,7 @@ IN: ui.gadgets.panes.tests
: test-gadget-text ( quot -- ? )
dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+ swap with-string-writer dup print = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
@@ -87,6 +87,28 @@ IN: ui.gadgets.panes.tests
] test-gadget-text
] unit-test
+[ t ] [
+ [
+ last-element off
+ \ = >link title-style get [
+ $navigation-table
+ ] with-nesting
+ "Hello world" print-content
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a\n" } } simple-table. ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a" } } simple-table. "x" write ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
+] unit-test
+
ARTICLE: "test-article-1" "This is a test article"
"Hello world, how are you today." ;
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index c52c361b86..bf166f993a 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -17,6 +17,12 @@ TUPLE: pane < track
output current input last-line prototype scrolls?
selection-color caret mark selecting? ;
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+<PRIVATE
+
: clear-selection ( pane -- pane )
f >>caret f >>mark ; inline
@@ -49,12 +55,6 @@ M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
-: pane-clear ( pane -- )
- clear-selection
- [ output>> clear-incremental ]
- [ current>> clear-gadget ]
- bi ;
-
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
@@ -70,17 +70,6 @@ M: pane gadget-selection ( pane -- string/f )
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
-: new-pane ( input class -- pane )
- [ vertical ] dip new-track
- swap >>input
- pane-theme
- init-prototype
- init-output
- init-current
- init-last-line ; inline
-
-: <pane> ( -- pane ) f pane new-pane ;
-
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
@@ -112,10 +101,6 @@ M: pane draw-gadget*
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
: smash-line ( current -- gadget )
dup children>> {
{ [ dup empty? ] [ 2drop "" <label> ] }
@@ -123,14 +108,18 @@ C: <pane-stream> pane-stream
[ drop ]
} cond ;
-: smash-pane ( pane -- gadget ) output>> smash-line ;
-
: pane-nl ( pane -- )
[
[ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
add-incremental
] [ next-line ] bi ;
+: ?pane-nl ( pane -- )
+ [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
+ [ pane-nl ] bi ;
+
+: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
+
: pane-write ( seq pane -- )
[ pane-nl ] [ current>> stream-write ]
bi-curry interleave ;
@@ -139,43 +128,6 @@ C: <pane-stream> pane-stream
[ nip pane-nl ] [ current>> stream-format ]
bi-curry bi-curry interleave ;
-GENERIC: write-gadget ( gadget stream -- )
-
-M: pane-stream write-gadget ( gadget pane-stream -- )
- pane>> current>> swap add-gadget drop ;
-
-M: style-stream write-gadget
- stream>> write-gadget ;
-
-: print-gadget ( gadget stream -- )
- [ write-gadget ] [ nip stream-nl ] 2bi ;
-
-: gadget. ( gadget -- )
- output-stream get print-gadget ;
-
-: ?nl ( stream -- )
- dup pane>> current>> children>> empty?
- [ dup stream-nl ] unless drop ;
-
-: with-pane ( pane quot -- )
- over scroll>top
- over pane-clear [ <pane-stream> ] dip
- over [ with-output-stream* ] dip ?nl ; inline
-
-: make-pane ( quot -- gadget )
- <pane> [ swap with-pane ] keep smash-pane ; inline
-
-TUPLE: pane-control < pane quot ;
-
-M: pane-control model-changed ( model pane-control -- )
- [ value>> ] [ dup quot>> ] bi*
- '[ _ call( value -- ) ] with-pane ;
-
-: <pane-control> ( model quot -- pane )
- f pane-control new-pane
- swap >>quot
- swap >>model ;
-
: do-pane-stream ( pane-stream quot -- )
[ pane>> ] dip keep scroll-pane ; inline
@@ -198,7 +150,59 @@ M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
swap <style-stream> <ignore-close-stream> ;
+PRIVATE>
+
+: new-pane ( input class -- pane )
+ [ vertical ] dip new-track
+ swap >>input
+ pane-theme
+ init-prototype
+ init-output
+ init-current
+ init-last-line ; inline
+
+: <pane> ( -- pane ) f pane new-pane ;
+
+GENERIC: write-gadget ( gadget stream -- )
+
+M: pane-stream write-gadget ( gadget pane-stream -- )
+ pane>> current>> swap add-gadget drop ;
+
+M: style-stream write-gadget
+ stream>> write-gadget ;
+
+: print-gadget ( gadget stream -- )
+ [ write-gadget ] [ nip stream-nl ] 2bi ;
+
+: gadget. ( gadget -- )
+ output-stream get print-gadget ;
+
+: pane-clear ( pane -- )
+ clear-selection
+ [ output>> clear-incremental ]
+ [ current>> clear-gadget ]
+ bi ;
+
+: with-pane ( pane quot -- )
+ [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
+ with-output-stream* ; inline
+
+: make-pane ( quot -- gadget )
+ [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
+
+TUPLE: pane-control < pane quot ;
+
+M: pane-control model-changed ( model pane-control -- )
+ [ value>> ] [ dup quot>> ] bi*
+ '[ _ call( value -- ) ] with-pane ;
+
+: <pane-control> ( model quot -- pane )
+ f pane-control new-pane
+ swap >>quot
+ swap >>model ;
+
! Character styles
+<PRIVATE
MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
@@ -279,10 +283,7 @@ TUPLE: nested-pane-stream < pane-stream style parent ;
inline
: unnest-pane-stream ( stream -- child parent )
- dup ?nl
- dup style>>
- over pane>> smash-pane style-pane
- swap parent>> ;
+ [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
TUPLE: pane-block-stream < nested-pane-stream ;
@@ -309,7 +310,7 @@ M: pane-stream make-block-stream
TUPLE: pane-cell-stream < nested-pane-stream ;
-M: pane-cell-stream dispose ?nl ;
+M: pane-cell-stream dispose drop ;
M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
@@ -318,7 +319,7 @@ M: pane-stream stream-write-table
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
- ] dip print-gadget ;
+ ] dip write-gadget ;
! Stream utilities
M: pack dispose drop ;
@@ -433,6 +434,8 @@ M: f sloppy-pick-up*
: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
+PRIVATE>
+
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor
index f5a6409fca..57c69c2a66 100644
--- a/basis/ui/gadgets/status-bar/status-bar-docs.factor
+++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor
@@ -3,7 +3,7 @@ ui.gadgets ui.gadgets.worlds ui ;
IN: ui.gadgets.status-bar
HELP: show-status
-{ $values { "string" string } { "gadget" gadget } }
+{ $values { "string/f" string } { "gadget" gadget } }
{ $description "Displays a status message in the gadget's world." }
{ $notes "The status message will only be visible if the window was opened with " { $link open-status-window } ", and not " { $link open-window } "." } ;
diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor
index a137ae022b..485015b898 100644
--- a/basis/ui/pens/gradient/gradient.factor
+++ b/basis/ui/pens/gradient/gradient.factor
@@ -41,4 +41,6 @@ M: gradient draw-interior
[ last-vertices>> gl-vertex-pointer ]
[ last-colors>> gl-color-pointer ]
[ colors>> draw-gradient ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
+
+M: gradient pen-background 2drop transparent ;
\ No newline at end of file
diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor
index 32d400463e..950035e773 100644
--- a/basis/ui/pens/solid/solid.factor
+++ b/basis/ui/pens/solid/solid.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors opengl ui.pens ui.pens.caching ;
+USING: kernel accessors opengl math colors ui.pens ui.pens.caching ;
IN: ui.pens.solid
TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
@@ -29,4 +29,4 @@ M: solid draw-boundary
(gl-rect) ;
M: solid pen-background
- nip color>> ;
\ No newline at end of file
+ nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;
\ No newline at end of file
diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor
index 17ffc9ee18..35fa5e3c17 100644
--- a/basis/ui/tools/inspector/inspector.factor
+++ b/basis/ui/tools/inspector/inspector.factor
@@ -33,19 +33,19 @@ M: inspector-renderer column-titles
[
[
[ "Class:" write ] with-cell
- [ class . ] with-cell
+ [ class pprint ] with-cell
] with-row
]
[
[
[ "Object:" write ] with-cell
- [ short. ] with-cell
+ [ pprint-short ] with-cell
] with-row
]
[
[
[ "Summary:" write ] with-cell
- [ summary. ] with-cell
+ [ print-summary ] with-cell
] with-row
] tri
] tabular-output
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index ebf2db79bf..4429f058f1 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -175,7 +175,7 @@ TUPLE: listener-gadget < tool input output scroller ;
[ listener-gadget? ] find-parent ;
: listener-streams ( listener -- input output )
- [ input>> ] [ output>> ] bi <pane-stream> ;
+ [ input>> ] [ output>> <pane-stream> ] bi ;
: init-listener ( listener -- listener )
<interactor>
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index d08dea299e..f2b6154745 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -171,6 +171,7 @@ ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
{ $subsection "ui-frame-layout" }
{ $subsection "ui-book-layout" }
"Advanced topics:"
+{ $subsection "ui.gadgets.glass" }
{ $subsection "ui-null-layout" }
{ $subsection "ui-incremental-layout" }
{ $subsection "ui-layout-impl" }
diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor
index 740cf7db13..f0ee13dd38 100644
--- a/basis/validators/validators.factor
+++ b/basis/validators/validators.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
-math.parser math.ranges assocs regexp regexp.matchers unicode.categories arrays
+math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog unicode.case ;
IN: validators
diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor
index de1f4254ea..f584756f33 100755
--- a/basis/xmode/marker/marker.factor
+++ b/basis/xmode/marker/marker.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: xmode.marker
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
-regexp splitting ascii unicode.case regexp.matchers
-ascii combinators.short-circuit accessors ;
+regexp splitting unicode.case ascii
+combinators.short-circuit accessors ;
+IN: xmode.marker
! Next two words copied from parser-combinators
! Just like head?, but they optionally ignore case
@@ -84,7 +84,7 @@ M: string-matcher text-matches?
] keep string>> length and ;
M: regexp text-matches?
- [ >string ] dip match-head ;
+ [ >string ] dip re-contains? ;
: rule-start-matches? ( rule -- match-count/f )
dup start>> tuck swap can-match-here? [
diff --git a/extra/benchmark/regex-dna/regex-dna.factor b/extra/benchmark/regex-dna/regex-dna.factor
index 29cb0b7357..5c11be357f 100644
--- a/extra/benchmark/regex-dna/regex-dna.factor
+++ b/extra/benchmark/regex-dna/regex-dna.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors regexp.matchers prettyprint io io.encodings.ascii
+USING: accessors prettyprint io io.encodings.ascii
io.files kernel sequences assocs namespaces regexp ;
IN: benchmark.regex-dna
diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
index 1f62441028..64696759bb 100644
--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@@ -1,30 +1,31 @@
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images.bitmap images.viewer
+opengl.gl sequences math.vectors ui images images.viewer
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )
- dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
+ dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
: gl-screenshot ( gadget -- byte-array )
[
- GL_BACK glReadBuffer
- GL_PACK_ALIGNMENT 4 glPixelStorei
- 0 0
- ] dip
- [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+ [
+ GL_BACK glReadBuffer
+ GL_PACK_ALIGNMENT 4 glPixelStorei
+ 0 0
+ ] dip
+ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
+ ]
[ screenshot-array ] bi
[ glReadPixels ] keep ;
: screenshot ( window -- bitmap )
- [ gl-screenshot ]
- [ dim>> first2 ] bi
- bgr>bitmap ;
-
-: save-screenshot ( window path -- )
- [ screenshot ] dip save-bitmap ;
+ [ <image> ] dip
+ [ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
+ RGBA >>component-order
+ t >>upside-down?
+ normalize-image ;
: screenshot. ( window -- )
[ screenshot <image-gadget> ] [ title>> ] bi open-window ;
diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor
index b920b60430..4eaa984953 100644
--- a/extra/images/viewer/viewer.factor
+++ b/extra/images/viewer/viewer.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.loader io.pathnames kernel
-namespaces opengl opengl.gl sequences strings ui ui.gadgets
+USING: accessors images images.loader io.pathnames kernel namespaces
+opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: images.viewer
@@ -12,8 +12,8 @@ M: image-gadget pref-dim*
: draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
- [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
- [ bitmap>> ] bi glDrawPixels ;
+ [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+ glDrawPixels ;
M: image-gadget draw-gadget* ( gadget -- )
image>> draw-image ;
diff --git a/extra/otug-talk/2bi.png b/extra/otug-talk/2bi.png
deleted file mode 100644
index 8f431f87ce..0000000000
Binary files a/extra/otug-talk/2bi.png and /dev/null differ
diff --git a/extra/otug-talk/2bi.tiff b/extra/otug-talk/2bi.tiff
new file mode 100644
index 0000000000..16c0777254
Binary files /dev/null and b/extra/otug-talk/2bi.tiff differ
diff --git a/extra/otug-talk/2bi_at.png b/extra/otug-talk/2bi_at.png
deleted file mode 100644
index 55d42c2a4c..0000000000
Binary files a/extra/otug-talk/2bi_at.png and /dev/null differ
diff --git a/extra/otug-talk/2bi_at.tiff b/extra/otug-talk/2bi_at.tiff
new file mode 100644
index 0000000000..e41ab98eeb
Binary files /dev/null and b/extra/otug-talk/2bi_at.tiff differ
diff --git a/extra/otug-talk/2bi_star.png b/extra/otug-talk/2bi_star.png
deleted file mode 100644
index 0fff37624b..0000000000
Binary files a/extra/otug-talk/2bi_star.png and /dev/null differ
diff --git a/extra/otug-talk/2bi_star.tiff b/extra/otug-talk/2bi_star.tiff
new file mode 100644
index 0000000000..f457ce5481
Binary files /dev/null and b/extra/otug-talk/2bi_star.tiff differ
diff --git a/extra/otug-talk/bi.png b/extra/otug-talk/bi.png
deleted file mode 100644
index 2470c9fab1..0000000000
Binary files a/extra/otug-talk/bi.png and /dev/null differ
diff --git a/extra/otug-talk/bi.tiff b/extra/otug-talk/bi.tiff
new file mode 100644
index 0000000000..ad0ce97cc0
Binary files /dev/null and b/extra/otug-talk/bi.tiff differ
diff --git a/extra/otug-talk/bi_at.png b/extra/otug-talk/bi_at.png
deleted file mode 100644
index 282f2f118d..0000000000
Binary files a/extra/otug-talk/bi_at.png and /dev/null differ
diff --git a/extra/otug-talk/bi_at.tiff b/extra/otug-talk/bi_at.tiff
new file mode 100644
index 0000000000..07d25bcd01
Binary files /dev/null and b/extra/otug-talk/bi_at.tiff differ
diff --git a/extra/otug-talk/bi_star.png b/extra/otug-talk/bi_star.png
deleted file mode 100644
index e94e3710cf..0000000000
Binary files a/extra/otug-talk/bi_star.png and /dev/null differ
diff --git a/extra/otug-talk/bi_star.tiff b/extra/otug-talk/bi_star.tiff
new file mode 100644
index 0000000000..17f3350b51
Binary files /dev/null and b/extra/otug-talk/bi_star.tiff differ
diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor
index 16ee2b740b..2ce307ce20 100644
--- a/extra/otug-talk/otug-talk.factor
+++ b/extra/otug-talk/otug-talk.factor
@@ -1,41 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
-locals kernel.private tools.vocabs.browser assocs quotations
- tools.vocabs tools.annotations tools.crossref
-help.topics math.functions compiler.tree.optimizer
-compiler.cfg.optimizer fry
-ui.gadgets.panes tetris tetris.game combinators generalizations
-multiline sequences.private ;
+USING: slides help.markup math arrays hashtables namespaces sequences
+kernel sequences parser memoize io.encodings.binary locals
+kernel.private tools.vocabs.browser assocs quotations tools.vocabs
+tools.annotations tools.crossref help.topics math.functions
+compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
+tetris tetris.game combinators generalizations multiline
+sequences.private ;
IN: otug-talk
-USING: cairo cairo.ffi cairo.gadgets accessors
-io.backend ui.gadgets ;
-
-TUPLE: png-gadget < cairo-gadget surface ;
-
-: <png-gadget> ( file -- gadget )
- png-gadget new-gadget
- swap normalize-path
- cairo_image_surface_create_from_png >>surface ; inline
-
-M: png-gadget pref-dim* ( gadget -- )
- surface>>
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height ]
- bi 2array ;
-
-M: png-gadget render-cairo* ( gadget -- )
- cr swap surface>> 0 0 cairo_set_source_surface
- cr cairo_paint ;
-
-M: png-gadget ungraft* ( gadget -- )
- surface>> cairo_surface_destroy ;
-
-: $bitmap ( element -- )
- [ first <png-gadget> gadget. ] ($block) ;
-
: $tetris ( element -- )
drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
@@ -105,11 +78,11 @@ CONSTANT: otug-slides
}
{ $slide "Data flow combinators - cleave family"
{ { $link bi } ", " { $link tri } ", " { $link cleave } }
- { $bitmap "resource:extra/otug-talk/bi.png" }
+ { $image "resource:extra/otug-talk/bi.tiff" }
}
{ $slide "Data flow combinators - cleave family"
{ { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
- { $bitmap "resource:extra/otug-talk/2bi.png" }
+ { $image "resource:extra/otug-talk/2bi.tiff" }
}
{ $slide "Data flow combinators"
"First, let's define a data type:"
@@ -128,19 +101,19 @@ CONSTANT: otug-slides
}
{ $slide "Data flow combinators - spread family"
{ { $link bi* } ", " { $link tri* } ", " { $link spread } }
- { $bitmap "resource:extra/otug-talk/bi_star.png" }
+ { $image "resource:extra/otug-talk/bi_star.tiff" }
}
{ $slide "Data flow combinators - spread family"
{ { $link 2bi* } }
- { $bitmap "resource:extra/otug-talk/2bi_star.png" }
+ { $image "resource:extra/otug-talk/2bi_star.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
- { $bitmap "resource:extra/otug-talk/bi_at.png" }
+ { $image "resource:extra/otug-talk/bi_at.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link 2bi@ } }
- { $bitmap "resource:extra/otug-talk/2bi_at.png" }
+ { $image "resource:extra/otug-talk/2bi_at.tiff" }
}
{ $slide "Shuffle words"
"When data flow combinators are not enough"
diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor
index 6a5b7ab816..752d0b3ffa 100755
--- a/extra/slides/slides.factor
+++ b/extra/slides/slides.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
parser accessors colors ;
IN: slides
@@ -98,6 +98,7 @@ TUPLE: slides < book ;
parse-definition strip-tease [ parsed ] each ; parsing
\ slides H{
+ { T{ button-down } [ request-focus ] }
{ T{ key-down f f "DOWN" } [ next-page ] }
{ T{ key-down f f "UP" } [ prev-page ] }
} set-gestures
diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor
index 70300779b5..f8c901ff56 100644
--- a/extra/tetris/gl/gl.factor
+++ b/extra/tetris/gl/gl.factor
@@ -35,7 +35,7 @@ IN: tetris.gl
: scale-board ( width height board -- )
[ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
-: (draw-tetris) ( width height tetris -- )
+: draw-tetris ( width height tetris -- )
#! width and height are in pixels
GL_MODELVIEW [
{
@@ -44,7 +44,4 @@ IN: tetris.gl
[ next-piece draw-next-piece ]
[ current-piece draw-piece ]
} cleave
- ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
- origin get [ (draw-tetris) ] with-translation ;
+ ] do-matrix ;
\ No newline at end of file