: drop-prefix ( seq1 seq2 -- seq1 seq2 )
2dup mismatch dup -1 = [ drop 2dup min-length ] when
tuck swap tail-slice >r swap tail-slice r> ;
+
+IN: strings
+
+: completion? ( partial completion quot -- ? )
+ #! Test if 'partial' is a completion of 'completion', by
+ #! comparing each "-"-delimited chunk using 'quot'. The
+ #! quotation is usually either [ subseq? ] or [ swap head? ].
+ >r [ "-" split ] 2apply 2dup [ length ] 2apply <=
+ [ r> 2map [ ] all? ] [ r> 3drop f ] if ; inline
\r
: <tutorial-button>\r
"Tutorial" <label>\r
- [ drop [ tutorial ] pane get pane-call ] <button> ;\r
+ [ drop [ tutorial ] pane get pane-call ] <bevel-button> ;\r
GL_LINE_LOOP (gl-poly) ;
: gl-set-clip ( loc dim -- )
- dup first2 ( 1+ ) >r >r
+ dup first2 1+ >r >r
over second swap second + height get swap - >r
first r> r> r> glScissor ;
SYMBOL: foreground ! Used for text and outline shapes.
SYMBOL: background ! Used for filled shapes.
-SYMBOL: rollover-bg
-SYMBOL: rollover
-SYMBOL: reverse-video
SYMBOL: font
SYMBOL: font-size
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
USING: generic hashtables io kernel lists math namespaces
-sequences styles words ;
+sequences strings styles words ;
: declaration. ( word prop -- )
tuck word-name word-prop [ pprint-word ] [ drop ] if ;
] with-pprint ;
: (apropos) ( substring -- seq )
- all-words [ word-name subseq? ] subset-with ;
+ all-words [ word-name [ subseq? ] completion? ] subset-with ;
: apropos ( substring -- )
#! List all words that contain a string.
: <book-button> ( polygon quot -- button )
\ find-book swons >r <polygon-gadget> dup icon-theme r>
- <button> ;
+ <bevel-button> ;
: <book-buttons> ( book -- gadget )
[
generic io kernel lists math namespaces sequences sequences
styles threads ;
+TUPLE: button rollover? pressed? ;
+
: button-down? ( n -- ? ) hand get hand-buttons member? ;
: mouse-over? ( gadget -- ? ) hand get hand-gadget child? ;
-: button-pressed? ( button -- ? )
- #! Return true if the mouse was clicked on the button, and
- #! is currently over the button.
- dup mouse-over? 1 button-down? and
- [ hand get hand-clicked child? ] [ drop f ] if ;
+: mouse-clicked? ( gadget -- ? ) hand get hand-clicked child? ;
: button-update ( button -- )
- dup dup mouse-over? rollover set-paint-prop
- dup dup button-pressed? reverse-video set-paint-prop
+ dup mouse-over? over set-button-rollover?
+ dup button-rollover? 1 button-down? and
+ over mouse-clicked? and over set-button-pressed?
relayout-1 ;
: button-clicked ( button -- )
#! If the mouse is released while still inside the button,
#! fire an action gesture.
- dup button-update dup mouse-over?
+ dup button-update dup button-rollover?
[ [ action ] swap handle-gesture ] when drop ;
: button-action ( action -- quot )
dup [ button-update ] [ mouse-leave ] set-action
[ button-update ] [ mouse-enter ] set-action ;
-TUPLE: button ;
-
C: button ( gadget quot -- button )
- rot <border> dup button-theme
- over set-gadget-delegate
+ rot <border> over set-gadget-delegate
[ swap button-gestures ] keep ;
+: <highlight-button> ( gadget quot -- button )
+ <button> @{ 0 0 0 }@ over set-border-size ;
+
: <roll-button> ( gadget quot -- button )
- >r dup roll-button-theme dup r> button-gestures ;
+ <highlight-button> dup roll-button-theme ;
-: <highlight-button> ( gadget quot -- button )
- dupd button-gestures ;
+: <bevel-button> ( gadget quot -- button )
+ <button> dup bevel-button-theme ;
: repeat-button-down ( button -- )
dup 100 add-timer button-clicked ;
: <repeat-button> ( gadget quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
- <button> dup repeat-actions ;
+ <bevel-button> dup repeat-actions ;
M: button tick ( ms object -- ) nip button-clicked ;
+
+TUPLE: button-paint plain rollover pressed ;
+
+: button-paint ( button paint -- button paint )
+ @{
+ @{ [ over button-pressed? ] [ button-paint-pressed ] }@
+ @{ [ over button-rollover? ] [ button-paint-rollover ] }@
+ @{ [ t ] [ button-paint-plain ] }@
+ }@ cond ;
+
+M: button-paint draw-interior ( button paint -- )
+ button-paint draw-interior ;
+
+M: button-paint draw-boundary ( button paint -- )
+ button-paint draw-boundary ;
M: editor label-text ( editor -- string )
editor-text ;
-M: editor draw-gadget* ( editor -- )
- dup delegate draw-gadget* draw-label ;
+M: editor draw-gadget* ( editor -- ) draw-label ;
: set-possibilities ( possibilities editor -- )
#! Set completion possibilities.
label-size ;
: draw-label ( label -- )
- dup fg gl-color dup gadget-font swap label-text draw-string ;
+ dup foreground paint-prop gl-color
+ dup gadget-font swap label-text draw-string ;
-M: label draw-gadget* ( label -- )
- dup delegate draw-gadget* draw-label ;
+M: label draw-gadget* ( label -- ) draw-label ;
M: label set-message ( string/f label -- )
set-label-text* ;
history-index get dup 1+ history-length >=
[ drop ] [ 1+ goto-history ] if ;
-: completion? ( partial completion -- ? )
- [ "-" split ] 2apply 2dup [ length ] 2apply <=
- [ [ swap head? ] 2map [ ] all? ] [ 2drop f ] if ;
-
: completions ( -- seq )
<< word-elt >> prev-elt@ 2dup = [
2drop f
] [
- line-text get subseq
- possibilities get [ completion? ] subset-with
+ line-text get subseq possibilities get
+ [ [ swap head? ] completion? ] subset-with
] if ;
: complete ( completion -- )
1/2 <x-splitter> ;
: <status-bar> ( -- gadget )
- "" <label> dup solid-interior
- dup t reverse-video set-paint-prop ;
+ "" <label> dup solid-interior dup reverse-video-theme ;
: listener-application ( -- )
t t <pane> dup pane global set-hash
styles vectors ;
IN: gadgets
+GENERIC: draw-gadget* ( gadget -- )
+
+M: gadget draw-gadget* ( gadget -- ) drop ;
+
+SYMBOL: interior
+SYMBOL: boundary
+
+GENERIC: draw-interior ( gadget interior -- )
+GENERIC: draw-boundary ( gadget boundary -- )
+
SYMBOL: clip
: visible-children ( gadget -- seq ) clip get swap children-on ;
-GENERIC: draw-gadget* ( gadget -- )
+DEFER: draw-gadget
+
+: (draw-gadget) ( gadget -- )
+ dup dup interior paint-prop* draw-interior
+ dup dup boundary paint-prop* draw-boundary
+ dup draw-gadget*
+ visible-children [ draw-gadget ] each ;
: do-clip ( gadget -- )
>absolute clip [ rect-intersect dup ] change
: draw-gadget ( gadget -- )
clip get over inside? [
[
- dup do-clip [
- dup draw-gadget*
- visible-children [ draw-gadget ] each
- ] with-translation
+ dup do-clip [ dup (draw-gadget) ] with-translation
] with-scope
- ] [ drop ] if ;
+ ] when drop ;
: paint-prop* ( gadget key -- value ) swap gadget-paint ?hash ;
: add-paint ( gadget hash -- )
dup [ >r init-paint r> hash-update ] [ 2drop ] if ;
-: fg ( gadget -- color )
- dup reverse-video paint-prop
- background foreground ? paint-prop ;
-
-: bg ( gadget -- color )
- dup reverse-video paint-prop [
- foreground
- ] [
- dup rollover paint-prop rollover-bg background ?
- ] if paint-prop ;
-
! Pen paint properties
-SYMBOL: interior
-SYMBOL: boundary
-
-GENERIC: draw-interior ( gadget interior -- )
-GENERIC: draw-boundary ( gadget boundary -- )
-
M: f draw-interior 2drop ;
M: f draw-boundary 2drop ;
TUPLE: solid ;
: rect>screen ( shape -- x1 y1 x2 y2 )
- >r origin get dup r> rect-dim v+
- [ first2 ] 2apply ( [ 1 - ] 2apply ) ;
+ >r origin get dup r> rect-dim v+ [ first2 ] 2apply ;
! Solid pen
M: solid draw-interior
- drop dup bg gl-color rect-dim gl-fill-rect ;
+ drop dup background paint-prop gl-color rect-dim gl-fill-rect ;
M: solid draw-boundary
- drop dup fg gl-color rect-dim ( @{ 1 1 0 }@ v- ) gl-rect ;
-
-! Rollover only
-TUPLE: rollover-only ;
-
-C: rollover-only << solid >> over set-delegate ;
-
-M: rollover-only draw-interior ( gadget interior -- )
- over rollover paint-prop
- [ delegate draw-interior ] [ 2drop ] if ;
-
-M: rollover-only draw-boundary ( gadget boundary -- )
- over rollover paint-prop
- [ delegate draw-boundary ] [ 2drop ] if ;
+ drop dup foreground paint-prop gl-color rect-dim gl-rect ;
! Gradient pen
TUPLE: gradient colors ;
over gadget-orientation swap gradient-colors rot rect-dim
gl-gradient ;
-M: gadget draw-gadget* ( gadget -- )
- dup
- dup interior paint-prop* draw-interior
- dup boundary paint-prop* draw-boundary ;
-
! Polygon pen
TUPLE: polygon points ;
M: polygon draw-boundary ( gadget polygon -- )
- swap fg gl-color polygon-points gl-poly ;
+ swap foreground paint-prop gl-color polygon-points gl-poly ;
M: polygon draw-interior ( gadget polygon -- )
- swap bg gl-color polygon-points gl-fill-poly ;
+ swap background paint-prop gl-color polygon-points gl-fill-poly ;
: arrow-up @{ @{ 3 0 0 }@ @{ 6 6 0 }@ @{ 0 6 0 }@ }@ ;
: arrow-right @{ @{ 0 0 0 }@ @{ 6 3 0 }@ @{ 0 6 0 }@ }@ ;
<menu> show-hand-menu ;
C: command-button ( gadget object -- button )
- [ set-command-button-object ] keep
+ [
+ set-command-button-object
+ [ command-menu ] <roll-button>
+ ] keep
[ set-gadget-delegate ] keep
- dup [ command-menu ] button-gestures
- dup roll-button-theme
dup menu-button-actions ;
M: command-button gadget-help ( button -- string )
- command-button-object
- dup word? [ synopsis ] [ summary ] if ;
+ command-button-object dup word? [ synopsis ] [ summary ] if ;
: init-commands ( gadget -- gadget )
dup presented paint-prop [ <command-button> ] when* ;
: <thumb> ( vector -- thumb )
<gadget> [ set-gadget-orientation ] keep
- t over set-gadget-root? dup button-theme dup thumb-actions ;
+ t over set-gadget-root?
+ dup thumb-theme
+ dup thumb-actions ;
: slide-by ( amount gadget -- )
#! The gadget can be any child of a slider.
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets-buttons
+DEFER: <button-paint>
+
IN: gadgets-theme
USING: arrays gadgets kernel sequences styles ;
: solid-boundary ( gadget -- )
<< solid >> boundary set-paint-prop ;
-: button-theme ( gadget -- )
+: plain-gradient
<< gradient f @{
@{ 240 240 240 }@
@{ 192 192 192 }@
@{ 192 192 192 }@
@{ 96 96 96 }@
- }@ >> interior set-paint-prop ;
+ }@ >> ;
+
+: rollover-gradient
+ << gradient f @{
+ @{ 255 255 255 }@
+ @{ 216 216 216 }@
+ @{ 216 216 216 }@
+ @{ 112 112 112 }@
+ }@ >> ;
+
+: pressed-gradient
+ << gradient f @{
+ @{ 112 112 112 }@
+ @{ 216 216 216 }@
+ @{ 216 216 216 }@
+ @{ 255 255 255 }@
+ }@ >> ;
+
+: bevel-button-theme ( gadget -- )
+ plain-gradient rollover-gradient pressed-gradient
+ <button-paint> interior set-paint-prop ;
+
+: thumb-theme ( thumb -- )
+ plain-gradient interior set-paint-prop ;
: editor-theme ( editor -- )
bold font-style set-paint-prop ;
: roll-button-theme ( button -- )
- dup <rollover-only> interior set-paint-prop
- <rollover-only> boundary set-paint-prop ;
+ dup << button-paint f f << solid >> << solid >> >> boundary set-paint-prop
+ dup << button-paint f f f << solid >> >> interior set-paint-prop
+ @{ 236 230 232 }@ background set-paint-prop ;
: caret-theme ( caret -- )
dup solid-interior
}@ >> interior set-paint-prop
light-gray background set-paint-prop ;
+: reverse-video-theme ( gadget -- )
+ dup black background set-paint-prop
+ white foreground set-paint-prop ;
+
: divider-theme ( divider -- )
- dup solid-interior t reverse-video set-paint-prop ;
+ dup solid-interior reverse-video-theme ;
: display-title-theme
dup @{ 216 232 255 }@ background set-paint-prop
: icon-theme ( gadget -- )
dup gray background set-paint-prop
- dup light-gray rollover-bg set-paint-prop
gray foreground set-paint-prop ;
: world-theme
{{
[[ background @{ 255 255 255 }@ ]]
- [[ rollover-bg @{ 236 230 232 }@ ]]
[[ foreground @{ 0 0 0 }@ ]]
- [[ reverse-video f ]]
[[ font "Monospaced" ]]
[[ font-size 12 ]]
[[ font-style plain ]]