Merge git://factorcode.org/git/factor
Slava Pestov
commit
0320068a95
|
|
@ -85,4 +85,6 @@ IN: bootstrap.stage2
|
|||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
] [ error-hook get call "listener" run ] recover
|
||||
] [
|
||||
error-hook get call "listener" vocab-main execute
|
||||
] recover
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.parser models sequences
|
||||
ui ui.gadgets ui.gadgets.controls ui.gadgets.frames
|
||||
ui ui.gadgets ui.gadgets.frames
|
||||
ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
|
||||
;
|
||||
IN: color-picker
|
||||
|
|
@ -11,9 +11,14 @@ IN: color-picker
|
|||
: <color-slider> ( model -- gadget )
|
||||
<x-slider> 1 over set-slider-line ;
|
||||
|
||||
TUPLE: color-preview ;
|
||||
|
||||
: <color-preview> ( model -- gadget )
|
||||
<gadget> { 100 100 } over set-rect-dim
|
||||
[ set-gadget-interior ] <control> ;
|
||||
<gadget> color-preview construct-control
|
||||
{ 100 100 } over set-rect-dim ;
|
||||
|
||||
M: color-preview model-changed
|
||||
dup control-value over set-gadget-interior relayout-1 ;
|
||||
|
||||
: <color-model> ( model -- model )
|
||||
[ [ 256 /f ] map 1 add <solid> ] <filter> ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ HELP: close-later
|
|||
|
||||
HELP: with-destructors
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link (destruct) } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
|
||||
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
|
||||
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
|
||||
{ $examples
|
||||
{ $code "[ 10 malloc free-always ] with-destructors" }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ USING: alien alien.c-types arrays assocs combinators
|
|||
continuations destructors io io.backend io.nonblocking
|
||||
io.windows libc kernel math namespaces sequences threads
|
||||
tuples.lib windows windows.errors windows.kernel32 strings
|
||||
splitting io.files windows.winsock ;
|
||||
splitting io.files qualified ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
: unicode-prefix ( -- seq )
|
||||
|
|
@ -62,14 +63,16 @@ C: <io-callback> io-callback
|
|||
: set-port-overlapped ( overlapped port -- )
|
||||
port-handle set-win32-file-overlapped ;
|
||||
|
||||
: completion-port ( handle existing -- handle )
|
||||
: <completion-port> ( handle existing -- handle )
|
||||
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
||||
|
||||
: master-completion-port ( -- handle )
|
||||
INVALID_HANDLE_VALUE f completion-port ;
|
||||
SYMBOL: master-completion-port
|
||||
|
||||
: <master-completion-port> ( -- handle )
|
||||
INVALID_HANDLE_VALUE f <completion-port> ;
|
||||
|
||||
M: windows-nt-io add-completion ( handle -- )
|
||||
\ master-completion-port get-global completion-port drop ;
|
||||
master-completion-port get-global <completion-port> drop ;
|
||||
|
||||
TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ;
|
||||
|
||||
|
|
@ -98,8 +101,8 @@ TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompl
|
|||
C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
||||
|
||||
: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret )
|
||||
>r \ master-completion-port get-global 0 <int>
|
||||
0 <int> 0 <int> r> <GetQueuedCompletionStatusParams> [
|
||||
>r master-completion-port get-global 0 <int> 0 <int> 0 <int>
|
||||
r> <GetQueuedCompletionStatusParams> [
|
||||
GetQueuedCompletionStatusParams >tuple*<
|
||||
GetQueuedCompletionStatus
|
||||
] keep swap ;
|
||||
|
|
@ -146,7 +149,7 @@ M: windows-nt-io init-io ( -- )
|
|||
#! Should only be called on startup. Calling this at any
|
||||
#! other time can have unintended consequences.
|
||||
global [
|
||||
master-completion-port \ master-completion-port set
|
||||
<master-completion-port> master-completion-port set
|
||||
H{ } clone io-hash set
|
||||
init-winsock
|
||||
windows.winsock:init-winsock
|
||||
] bind ;
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ $nl
|
|||
": <funny-slider> <x-slider> 100 over set-slider-max ;"
|
||||
"<funny-slider> <funny-slider> 2array"
|
||||
"dup make-pile gadget."
|
||||
"dup [ control-model ] map <compose> [ unparse ] <filter>"
|
||||
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
|
||||
"<label-control> gadget."
|
||||
}
|
||||
} ;
|
||||
|
|
@ -146,7 +146,7 @@ HELP: delay
|
|||
": <funny-slider>"
|
||||
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
||||
"<funny-slider> dup gadget."
|
||||
"control-model 500 <delay> [ number>string ] <filter>"
|
||||
"gadget-model 500 <delay> [ number>string ] <filter>"
|
||||
"<label-control> gadget."
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays hashtables help.markup help.stylesheet io
|
||||
io.styles kernel math models namespaces sequences ui ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.controls ui.gadgets.panes
|
||||
ui.gadgets.books ui.gadgets.panes
|
||||
ui.gestures ui.render ;
|
||||
IN: slides
|
||||
|
||||
|
|
@ -75,7 +75,7 @@ TUPLE: slides ;
|
|||
|
||||
: change-page ( book n -- )
|
||||
over control-value + over gadget-children length rem
|
||||
swap control-model set-model ;
|
||||
swap gadget-model set-model ;
|
||||
|
||||
: next-page ( book -- ) 1 change-page ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
USING: ui.gadgets.books ui.gadgets.controls help.markup
|
||||
USING: ui.gadgets.books help.markup
|
||||
help.syntax ui.gadgets models ;
|
||||
|
||||
HELP: book
|
||||
{ $class-description "A book is a " { $link control } " containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
|
||||
{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
|
||||
$nl
|
||||
"Books are created by calling " { $link <book> } "." } ;
|
||||
|
||||
HELP: <book>
|
||||
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
|
||||
{ $description "Creates a " { $link book } { $link control } ", which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
|
||||
{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences models ui.gadgets ui.gadgets.controls ;
|
||||
USING: kernel sequences models ui.gadgets ;
|
||||
IN: ui.gadgets.books
|
||||
|
||||
TUPLE: book ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets tools.test namespaces sequences kernel ;
|
||||
ui.gadgets tools.test namespaces sequences kernel models ;
|
||||
|
||||
TUPLE: foo-gadget ;
|
||||
|
||||
|
|
@ -17,3 +17,20 @@ T{ foo-gadget } <toolbar> "t" set
|
|||
|
||||
[ 2 ] [ "t" get gadget-children length ] unit-test
|
||||
[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test
|
||||
|
||||
[ ] [
|
||||
2 <model> {
|
||||
{ 0 "atheist" }
|
||||
{ 1 "christian" }
|
||||
{ 2 "muslim" }
|
||||
{ 3 "jewish" }
|
||||
} <radio-buttons> "religion" set
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
"religion" get gadget-child radio-control-value
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
"religion" get gadget-child control-value
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render kernel math models namespaces sequences strings
|
||||
quotations assocs combinators classes colors tuples opengl
|
||||
|
|
@ -131,13 +131,18 @@ M: checkmark-paint draw-interior
|
|||
{ 5 5 } over set-pack-gap
|
||||
1/2 swap set-pack-align ;
|
||||
|
||||
TUPLE: checkbox ;
|
||||
|
||||
: <checkbox> ( model label -- checkbox )
|
||||
<checkmark>
|
||||
label-on-right
|
||||
over [ toggle-model drop ] curry <button>
|
||||
[ set-button-selected? ] <control>
|
||||
checkbox construct-control
|
||||
dup checkbox-theme ;
|
||||
|
||||
M: checkbox model-changed
|
||||
dup control-value over set-button-selected? relayout-1 ;
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
|
@ -165,17 +170,27 @@ M: radio-paint draw-boundary
|
|||
dup radio-knob-theme
|
||||
{ 16 16 } over set-gadget-dim ;
|
||||
|
||||
: <radio-control> ( model value gadget quot -- control )
|
||||
>r dupd [ set-control-value ] curry* r> call
|
||||
[ >r = r> set-button-selected? ] curry* <control> ; inline
|
||||
TUPLE: radio-control value ;
|
||||
|
||||
: <radio-controls> ( model assoc quot -- gadget )
|
||||
swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline
|
||||
: <radio-control> ( value model gadget quot -- control )
|
||||
>r pick [ swap set-control-value ] curry r> call
|
||||
radio-control construct-control
|
||||
tuck set-radio-control-value ; inline
|
||||
|
||||
M: radio-control model-changed
|
||||
dup control-value
|
||||
over radio-control-value =
|
||||
over set-button-selected?
|
||||
relayout-1 ;
|
||||
|
||||
: <radio-controls> ( model assoc quot -- )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
|
||||
|
||||
: radio-button-theme
|
||||
{ 5 5 } over set-pack-gap 1/2 swap set-pack-align ;
|
||||
|
||||
: <radio-button> ( model value label -- gadget )
|
||||
: <radio-button> ( value model label -- gadget )
|
||||
<radio-knob> label-on-right
|
||||
[ <button> ] <radio-control>
|
||||
dup radio-button-theme ;
|
||||
|
|
@ -187,7 +202,7 @@ M: radio-paint draw-boundary
|
|||
[ [ <radio-button> ] <radio-controls> ] make-filled-pile
|
||||
dup radio-buttons-theme ;
|
||||
|
||||
: <toggle-button> ( model value label -- gadget )
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
[ <bevel-button> ] <radio-control> ;
|
||||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
USING: ui.gadgets help.markup help.syntax models kernel classes
|
||||
tuples ;
|
||||
IN: ui.gadgets.controls
|
||||
|
||||
HELP: control
|
||||
{ $class-description "A control is a " { $link gadget } " linked to a " { $link model } " stored in the " { $link control-model } " slot. Changes to the model are reflected in the appearance and behavior of the control, and the control may in turn change the value of the model in response to user input."
|
||||
$nl
|
||||
"Controls are created by calling " { $link <control> } " and " { $link construct-control } "."
|
||||
$nl
|
||||
"Objects may delegate to " { $link control } " instances, in which case the " { $link control-self } " slot must be set to the frontmost object in the delegation chain. This ensures that the correct object receives notification of model changes." } ;
|
||||
|
||||
HELP: <control>
|
||||
{ $values { "model" model } { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( value control -- )" } } }
|
||||
{ $description "Creates a new control linked to the given model. The gadget parameter becomes the control's delegate. The quotation is called when the model value changes," }
|
||||
{ $examples
|
||||
"The following example creates a gadget whose fill color is determined by the value of a model:"
|
||||
{ $code
|
||||
"USING: ui.gadgets ui.gadgets.panes models ;"
|
||||
": set-fill-color >r <solid> r> set-gadget-interior ;"
|
||||
"{ 1.0 0.0 0.5 1.0 } <model>"
|
||||
"<gadget> [ set-fill-color ] <control>"
|
||||
"{ 100 100 } over set-rect-dim"
|
||||
"gadget."
|
||||
}
|
||||
"The " { $vocab-link "color-picker" } " module extends this example into an elaborate color choose."
|
||||
} ;
|
||||
|
||||
{ <control> construct-control control-value set-control-value } related-words
|
||||
|
||||
HELP: control-value
|
||||
{ $values { "control" control } { "value" object } }
|
||||
{ $description "Outputs the value of the control's model." } ;
|
||||
|
||||
HELP: set-control-value
|
||||
{ $values { "value" object } { "control" control } }
|
||||
{ $description "Sets the value of the control's model." } ;
|
||||
|
||||
ARTICLE: "ui-control-impl" "Implementing controls"
|
||||
"A control is a gadget which is linked to an underlying " { $link model } "."
|
||||
{ $subsection control }
|
||||
"There are two ways to implement a new control. First, an existing gadget can be wrapped in a control:"
|
||||
{ $subsection <control> }
|
||||
"Second, a new tuple class can be defined, whose instances delegate to controls:"
|
||||
{ $subsection construct-control }
|
||||
"Some utility words useful in control implementations:"
|
||||
{ $subsection control-model }
|
||||
{ $subsection control-value }
|
||||
{ $subsection set-control-value }
|
||||
{ $see-also "models" } ;
|
||||
|
||||
ABOUT: "ui-control-impl"
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel models ui.gadgets ;
|
||||
IN: ui.gadgets.controls
|
||||
|
||||
TUPLE: control self model quot ;
|
||||
|
||||
: (construct-control)
|
||||
construct dup dup set-control-self ; inline
|
||||
|
||||
: <control> ( model gadget quot -- gadget )
|
||||
{
|
||||
set-control-model set-gadget-delegate set-control-quot
|
||||
} control (construct-control) ;
|
||||
|
||||
: control-value ( control -- value )
|
||||
control-model model-value ;
|
||||
|
||||
: set-control-value ( value control -- )
|
||||
control-model set-model ;
|
||||
|
||||
M: control graft*
|
||||
control-self dup dup control-model add-connection
|
||||
model-changed ;
|
||||
|
||||
M: control ungraft*
|
||||
control-self dup control-model remove-connection ;
|
||||
|
||||
M: control model-changed
|
||||
control-self
|
||||
[ control-value ] keep
|
||||
[ dup control-quot call ] keep
|
||||
relayout ;
|
||||
|
||||
: construct-control ( model underlying class -- tuple )
|
||||
>r [ 2drop ] <control> { set-gadget-delegate } r>
|
||||
(construct-control) ; inline
|
||||
|
|
@ -1 +0,0 @@
|
|||
Controls display a view of an underlying model
|
||||
|
|
@ -1,10 +1,9 @@
|
|||
USING: documents help.markup help.syntax ui.gadgets
|
||||
ui.gadgets.scrollers ui.gadgets.controls
|
||||
models strings ui.commands ;
|
||||
ui.gadgets.scrollers models strings ui.commands ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
HELP: editor
|
||||
{ $class-description "An editor is a " { $link control } " for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
|
||||
{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
|
||||
$nl
|
||||
"Editors have the following slots:"
|
||||
{ $list
|
||||
|
|
|
|||
|
|
@ -2,13 +2,14 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays documents ui.clipboards ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.controls
|
||||
ui.gadgets.scrollers ui.gadgets.theme
|
||||
ui.render ui.gestures io kernel math models namespaces opengl
|
||||
opengl.gl sequences strings io.styles math.vectors sorting
|
||||
colors combinators ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor
|
||||
self
|
||||
font color caret-color selection-color
|
||||
caret mark
|
||||
focused? ;
|
||||
|
|
@ -31,6 +32,7 @@ TUPLE: loc-monitor editor ;
|
|||
|
||||
: <editor> ( -- editor )
|
||||
<document> <gadget> editor construct-control
|
||||
dup dup set-editor-self
|
||||
dup init-editor-locs
|
||||
dup editor-theme ;
|
||||
|
||||
|
|
@ -38,42 +40,42 @@ TUPLE: loc-monitor editor ;
|
|||
gray <solid> swap set-gadget-boundary ;
|
||||
|
||||
: construct-editor ( class -- tuple )
|
||||
>r <editor> { set-gadget-delegate } r>
|
||||
(construct-control) ; inline
|
||||
>r <editor> { set-gadget-delegate } r> construct
|
||||
dup dup set-editor-self ; inline
|
||||
|
||||
TUPLE: source-editor ;
|
||||
|
||||
: <source-editor> source-editor construct-editor ;
|
||||
|
||||
: activate-editor-model ( editor model -- )
|
||||
dup activate-model swap control-model add-loc ;
|
||||
dup activate-model swap gadget-model add-loc ;
|
||||
|
||||
: deactivate-editor-model ( editor model -- )
|
||||
dup deactivate-model swap control-model remove-loc ;
|
||||
dup deactivate-model swap gadget-model remove-loc ;
|
||||
|
||||
M: editor graft*
|
||||
dup dup editor-caret activate-editor-model
|
||||
dup dup editor-mark activate-editor-model
|
||||
dup control-self swap control-model add-connection ;
|
||||
dup
|
||||
dup editor-caret activate-editor-model
|
||||
dup editor-mark activate-editor-model ;
|
||||
|
||||
M: editor ungraft*
|
||||
dup dup editor-caret deactivate-editor-model
|
||||
dup dup editor-mark deactivate-editor-model
|
||||
dup control-self swap control-model remove-connection ;
|
||||
dup
|
||||
dup editor-caret deactivate-editor-model
|
||||
dup editor-mark deactivate-editor-model ;
|
||||
|
||||
M: editor model-changed
|
||||
control-self dup control-model
|
||||
dup gadget-model
|
||||
over editor-caret [ over validate-loc ] (change-model)
|
||||
over editor-mark [ over validate-loc ] (change-model)
|
||||
drop relayout ;
|
||||
drop editor-self relayout ;
|
||||
|
||||
: editor-caret* ( editor -- loc ) editor-caret model-value ;
|
||||
|
||||
: editor-mark* ( editor -- loc ) editor-mark model-value ;
|
||||
|
||||
: change-caret ( editor quot -- )
|
||||
over >r >r dup editor-caret* swap control-model r> call r>
|
||||
[ control-model validate-loc ] keep
|
||||
over >r >r dup editor-caret* swap gadget-model r> call r>
|
||||
[ gadget-model validate-loc ] keep
|
||||
editor-caret set-model ; inline
|
||||
|
||||
: mark>caret ( editor -- )
|
||||
|
|
@ -90,7 +92,7 @@ M: editor model-changed
|
|||
editor-font* "" string-height ;
|
||||
|
||||
: y>line ( y editor -- line# )
|
||||
[ line-height / >fixnum ] keep control-model validate-line ;
|
||||
[ line-height / >fixnum ] keep gadget-model validate-line ;
|
||||
|
||||
: point>loc ( point editor -- loc )
|
||||
[
|
||||
|
|
@ -133,7 +135,7 @@ M: editor model-changed
|
|||
] when drop ;
|
||||
|
||||
M: loc-monitor model-changed
|
||||
loc-monitor-editor control-self
|
||||
loc-monitor-editor editor-self
|
||||
dup relayout-1 scroll>caret ;
|
||||
|
||||
: draw-caret ( -- )
|
||||
|
|
@ -167,7 +169,7 @@ M: loc-monitor model-changed
|
|||
swap
|
||||
dup first-visible-line \ first-visible-line set
|
||||
dup last-visible-line \ last-visible-line set
|
||||
dup control-model document set
|
||||
dup gadget-model document set
|
||||
editor set
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
|
@ -221,19 +223,19 @@ M: editor gadget-selection?
|
|||
selection-start/end = not ;
|
||||
|
||||
M: editor gadget-selection
|
||||
[ selection-start/end ] keep control-model doc-range ;
|
||||
[ selection-start/end ] keep gadget-model doc-range ;
|
||||
|
||||
: remove-selection ( editor -- )
|
||||
[ selection-start/end ] keep control-model remove-doc-range ;
|
||||
[ selection-start/end ] keep gadget-model remove-doc-range ;
|
||||
|
||||
M: editor user-input*
|
||||
[ selection-start/end ] keep control-model set-doc-range t ;
|
||||
[ selection-start/end ] keep gadget-model set-doc-range t ;
|
||||
|
||||
: editor-string ( editor -- string )
|
||||
control-model doc-string ;
|
||||
gadget-model doc-string ;
|
||||
|
||||
: set-editor-string ( string editor -- )
|
||||
control-model set-doc-string ;
|
||||
gadget-model set-doc-string ;
|
||||
|
||||
M: editor gadget-text* editor-string % ;
|
||||
|
||||
|
|
@ -250,8 +252,8 @@ M: editor gadget-text* editor-string % ;
|
|||
over gadget-selection? [
|
||||
drop nip remove-selection
|
||||
] [
|
||||
over >r >r dup editor-caret* swap control-model
|
||||
r> call r> control-model remove-doc-range
|
||||
over >r >r dup editor-caret* swap gadget-model
|
||||
r> call r> gadget-model remove-doc-range
|
||||
] if ; inline
|
||||
|
||||
: editor-delete ( editor elt -- )
|
||||
|
|
@ -277,7 +279,7 @@ M: editor gadget-text* editor-string % ;
|
|||
|
||||
: select-elt ( editor elt -- )
|
||||
over >r
|
||||
>r dup editor-caret* swap control-model r> prev/next-elt
|
||||
>r dup editor-caret* swap gadget-model r> prev/next-elt
|
||||
r> editor-select ;
|
||||
|
||||
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
|
||||
|
|
@ -423,7 +425,7 @@ editor "selection" f {
|
|||
M: editor stream-write1 >r 1string r> stream-write ;
|
||||
|
||||
M: editor stream-write
|
||||
control-self dup end-of-document user-input ;
|
||||
editor-self dup end-of-document user-input ;
|
||||
|
||||
M: editor stream-close drop ;
|
||||
|
||||
|
|
@ -445,10 +447,10 @@ TUPLE: field model editor ;
|
|||
M: field graft*
|
||||
dup field-model model-value
|
||||
over field-editor set-editor-string
|
||||
dup field-editor control-model add-connection ;
|
||||
dup field-editor gadget-model add-connection ;
|
||||
|
||||
M: field ungraft*
|
||||
dup field-editor control-model remove-connection ;
|
||||
dup field-editor gadget-model remove-connection ;
|
||||
|
||||
M: field model-changed
|
||||
dup field-editor editor-string
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables kernel models math namespaces sequences
|
||||
timers quotations math.vectors combinators sorting vectors
|
||||
dlists ;
|
||||
dlists models ;
|
||||
IN: ui.gadgets
|
||||
|
||||
TUPLE: rect loc dim ;
|
||||
|
|
@ -43,12 +43,15 @@ M: array rect-dim drop { 0 0 } ;
|
|||
TUPLE: gadget
|
||||
pref-dim parent children orientation state focus
|
||||
visible? root? clipped? grafted?
|
||||
interior boundary ;
|
||||
interior boundary
|
||||
model ;
|
||||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* drop gadget hashcode* ;
|
||||
|
||||
M: gadget model-changed drop ;
|
||||
|
||||
: gadget-child ( gadget -- child ) gadget-children first ;
|
||||
|
||||
: nth-gadget ( n gadget -- child ) gadget-children nth ;
|
||||
|
|
@ -63,7 +66,20 @@ M: gadget hashcode* drop gadget hashcode* ;
|
|||
} gadget construct ;
|
||||
|
||||
: construct-gadget ( class -- tuple )
|
||||
>r <gadget> { set-delegate } r> construct ; inline
|
||||
>r <gadget> r> construct-delegate ; inline
|
||||
|
||||
: activate-control ( gadget -- )
|
||||
dup gadget-model dup [ 2dup add-connection ] when drop
|
||||
model-changed ;
|
||||
|
||||
: deactivate-control ( gadget -- )
|
||||
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
|
||||
|
||||
: control-value ( control -- value )
|
||||
gadget-model model-value ;
|
||||
|
||||
: set-control-value ( value control -- )
|
||||
gadget-model set-model ;
|
||||
|
||||
: relative-loc ( fromgadget togadget -- loc )
|
||||
2dup eq? [
|
||||
|
|
@ -119,6 +135,10 @@ M: gadget children-on nip gadget-children ;
|
|||
dup pick [ set-gadget-parent ] curry* each-child
|
||||
] when set-delegate ;
|
||||
|
||||
: construct-control ( model gadget class -- control )
|
||||
>r tuck set-gadget-model
|
||||
{ set-gadget-delegate } r> construct ; inline
|
||||
|
||||
! Selection protocol
|
||||
GENERIC: gadget-selection? ( gadget -- ? )
|
||||
|
||||
|
|
@ -228,6 +248,7 @@ M: gadget graft* drop ;
|
|||
: graft ( gadget -- )
|
||||
t over set-gadget-grafted?
|
||||
dup graft*
|
||||
dup activate-control
|
||||
[ graft ] each-child ;
|
||||
|
||||
GENERIC: ungraft* ( gadget -- )
|
||||
|
|
@ -237,6 +258,7 @@ M: gadget ungraft* drop ;
|
|||
: ungraft ( gadget -- )
|
||||
dup gadget-grafted? [
|
||||
dup [ ungraft ] each-child
|
||||
dup deactivate-control
|
||||
dup ungraft*
|
||||
f over set-gadget-grafted?
|
||||
] when drop ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: ui.gadgets help.markup help.syntax strings models
|
||||
ui.gadgets.panes ui.gadgets.controls ;
|
||||
ui.gadgets.panes ;
|
||||
IN: ui.gadgets.labelled
|
||||
|
||||
HELP: labelled-gadget
|
||||
|
|
@ -19,7 +19,7 @@ HELP: <closable-gadget>
|
|||
|
||||
HELP: <labelled-pane>
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
|
||||
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
|
||||
|
||||
{ <labelled-pane> <pane-control> } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
USING: ui.gadgets.controls help.markup
|
||||
help.syntax strings ui.gadgets models ;
|
||||
USING: help.markup help.syntax strings ui.gadgets models ;
|
||||
IN: ui.gadgets.labels
|
||||
|
||||
HELP: label
|
||||
|
|
@ -19,7 +18,7 @@ HELP: set-label-string
|
|||
|
||||
HELP: <label-control>
|
||||
{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Creates a " { $link control } " which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
|
||||
{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
|
||||
|
||||
{ label-string set-label-string } related-words
|
||||
{ <label> <label-control> } related-words
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables io kernel math namespaces
|
||||
opengl sequences io.streams.lines strings splitting
|
||||
ui.gadgets ui.gadgets.controls ui.gadgets.tracks
|
||||
ui.gadgets.theme ui.render colors ;
|
||||
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
|
||||
models ;
|
||||
IN: ui.gadgets.labels
|
||||
|
||||
! A label gadget draws a string.
|
||||
|
|
@ -37,8 +37,13 @@ M: label draw-gadget*
|
|||
|
||||
M: label gadget-text* label-string % ;
|
||||
|
||||
TUPLE: label-control ;
|
||||
|
||||
M: label-control model-changed
|
||||
dup control-value over set-label-text relayout ;
|
||||
|
||||
: <label-control> ( model -- gadget )
|
||||
"" <label> [ set-label-string ] <control> ;
|
||||
"" <label> label-control construct-control ;
|
||||
|
||||
: text-theme ( gadget -- )
|
||||
black over set-label-color
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: ui.commands help.markup help.syntax
|
||||
ui.gadgets ui.gadgets.presentations ui.gadgets.controls
|
||||
ui.operations kernel models classes ;
|
||||
USING: ui.commands help.markup help.syntax ui.gadgets
|
||||
ui.gadgets.presentations ui.operations kernel models classes ;
|
||||
IN: ui.gadgets.lists
|
||||
|
||||
HELP: +secondary+
|
||||
|
|
@ -8,7 +7,7 @@ HELP: +secondary+
|
|||
|
||||
HELP: list
|
||||
{ $class-description
|
||||
"A list " { $link control } " is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
|
||||
"A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
|
||||
$nl
|
||||
"Lists are created by calling " { $link <list> } "."
|
||||
{ $command-map list "keyboard-navigation" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.commands ui.gestures ui.render ui.gadgets
|
||||
ui.gadgets.controls ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
kernel sequences models opengl math namespaces
|
||||
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
|
||||
math.vectors tuples ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: ui.gadgets.controls ui.gadgets models
|
||||
help.markup help.syntax io kernel quotations ;
|
||||
USING: ui.gadgets models help.markup help.syntax io kernel
|
||||
quotations ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
HELP: pane
|
||||
|
|
@ -44,7 +44,7 @@ HELP: <scrolling-pane>
|
|||
|
||||
HELP: <pane-control>
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
|
||||
{ $description "Creates a new " { $link control } " delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
|
||||
{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
|
||||
|
||||
HELP: pane-stream
|
||||
{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2005, 2007 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.controls ui.gadgets.scrollers
|
||||
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
|
||||
io.streams.duplex sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines tuples ;
|
||||
ui.gadgets.grid-lines tuples models ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane output current prototype scrolls?
|
||||
|
|
@ -137,8 +137,14 @@ M: duplex-stream write-gadget
|
|||
: <scrolling-pane> ( -- pane )
|
||||
<pane> t over set-pane-scrolls? ;
|
||||
|
||||
TUPLE: pane-control quot ;
|
||||
|
||||
M: pane-control model-changed
|
||||
dup control-value swap dup pane-control-quot with-pane ;
|
||||
|
||||
: <pane-control> ( model quot -- pane )
|
||||
[ with-pane ] curry <pane> swap <control> ;
|
||||
>r <pane> pane-control construct-control r>
|
||||
over set-pane-control-quot ;
|
||||
|
||||
: do-pane-stream ( pane-stream quot -- )
|
||||
>r pane-stream-pane r> keep scroll-pane ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
IN: temporary
|
||||
USING: ui.gadgets ui.gadgets.scrollers ui.gadgets.controls
|
||||
namespaces tools.test kernel models ui.gadgets.viewports math
|
||||
math.vectors arrays sequences ;
|
||||
USING: ui.gadgets ui.gadgets.scrollers
|
||||
namespaces tools.test kernel models ui.gadgets.viewports
|
||||
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
|
||||
ui.gadgets.sliders math math.vectors arrays sequences ;
|
||||
|
||||
[ ] [
|
||||
<gadget> "g" set
|
||||
|
|
@ -22,7 +23,7 @@ math.vectors arrays sequences ;
|
|||
<viewport> "v" set
|
||||
] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "v" get control-model range-value ] unit-test
|
||||
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
|
||||
|
||||
|
|
@ -43,15 +44,15 @@ math.vectors arrays sequences ;
|
|||
|
||||
[ ] [ { 0 0 } "s" get scroll ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ "s" get control-model range-min-value ] unit-test
|
||||
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
|
||||
|
||||
[ { 106 106 } ] [ "s" get control-model range-max-value ] unit-test
|
||||
[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
|
||||
|
||||
[ ] [ { 10 20 } "s" get scroll ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "s" get control-model range-value ] unit-test
|
||||
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "s" get scroller-viewport control-model range-value ] unit-test
|
||||
[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
|
||||
|
||||
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
|
||||
|
||||
|
|
@ -74,3 +75,12 @@ dup layout
|
|||
"s" get scroller-value
|
||||
] map [ { 3 0 } = ] all?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
|
||||
|
||||
[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
|
||||
[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
|
||||
[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
|
||||
[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
|
||||
[ t ] [ "s" get @right grid-child slider? ] unit-test
|
||||
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gadgets ui.gadgets.controls
|
||||
USING: arrays ui.gadgets
|
||||
ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
|
||||
ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
|
||||
namespaces sequences models combinators math.vectors ;
|
||||
|
|
@ -29,15 +29,15 @@ scroller H{
|
|||
} set-gestures
|
||||
|
||||
: viewport, ( -- )
|
||||
g control-model <viewport>
|
||||
g gadget-model <viewport>
|
||||
g-> set-scroller-viewport @center frame, ;
|
||||
|
||||
: <scroller-model> ( -- model )
|
||||
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
||||
|
||||
: x-model g control-model model-dependencies first ;
|
||||
: x-model g gadget-model model-dependencies first ;
|
||||
|
||||
: y-model g control-model model-dependencies second ;
|
||||
: y-model g gadget-model model-dependencies second ;
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
<scroller-model> <frame> scroller construct-control [
|
||||
|
|
@ -70,11 +70,18 @@ scroller H{
|
|||
] keep dup scroller-value rot v+ swap scroll ;
|
||||
|
||||
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
||||
scroller-viewport gadget-child 2dup swap child?
|
||||
[ relative-loc offset-rect ] [ 3drop f ] if ;
|
||||
scroller-viewport gadget-child relative-loc offset-rect ;
|
||||
|
||||
: find-scroller* ( gadget -- scroller )
|
||||
dup find-scroller dup [
|
||||
2dup scroller-viewport gadget-child
|
||||
swap child? [ nip ] [ 2drop f ] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: scroll>rect ( rect gadget -- )
|
||||
dup find-scroller dup [
|
||||
dup find-scroller* dup [
|
||||
[ relative-scroll-rect ] keep
|
||||
[ set-scroller-follows ] keep
|
||||
relayout
|
||||
|
|
@ -88,7 +95,7 @@ scroller H{
|
|||
(scroll>rect) ;
|
||||
|
||||
: scroll>gadget ( gadget -- )
|
||||
dup find-scroller dup [
|
||||
dup find-scroller* dup [
|
||||
[ set-scroller-follows ] keep
|
||||
relayout
|
||||
] [
|
||||
|
|
@ -99,7 +106,7 @@ scroller H{
|
|||
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
|
||||
|
||||
: scroll>bottom ( gadget -- )
|
||||
find-scroller [
|
||||
find-scroller* [
|
||||
t over set-scroller-follows relayout-1
|
||||
] when* ;
|
||||
|
||||
|
|
@ -108,10 +115,10 @@ scroller H{
|
|||
|
||||
: update-scroller ( scroller follows -- )
|
||||
{
|
||||
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
|
||||
{ [ dup rect? ] [ swap (scroll>rect) ] }
|
||||
{ [ dup ] [ swap (scroll>gadget) ] }
|
||||
{ [ t ] [ drop dup scroller-value swap scroll ] }
|
||||
{ [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] }
|
||||
{ [ dup rect? ] [ swap (scroll>rect) "B" drop ] }
|
||||
{ [ dup ] [ swap (scroll>gadget) "C" drop ] }
|
||||
{ [ t ] [ drop dup scroller-value swap scroll "D" drop ] }
|
||||
} cond ;
|
||||
|
||||
M: scroller layout*
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
USING: ui.gadgets.controls help.markup help.syntax ui.gadgets
|
||||
models ;
|
||||
USING: help.markup help.syntax ui.gadgets models ;
|
||||
IN: ui.gadgets.sliders
|
||||
|
||||
HELP: elevator
|
||||
|
|
@ -10,7 +9,7 @@ HELP: find-elevator
|
|||
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
|
||||
|
||||
HELP: slider
|
||||
{ $class-description "A slider is a " { $link control } " for graphically manipulating a " { $link "models-range" } "."
|
||||
{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
|
||||
$nl
|
||||
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
|
||||
|
||||
|
|
@ -57,6 +56,6 @@ ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
|
|||
{ $subsection slide-by }
|
||||
{ $subsection slide-by-line }
|
||||
{ $subsection slide-by-page }
|
||||
"Since sliders are controls the value can be get and set by calling " { $link control-model } "." ;
|
||||
"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
|
||||
|
||||
ABOUT: "ui.gadgets.sliders"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.controls ui.gadgets.frames ui.gadgets.grids
|
||||
ui.gadgets.frames ui.gadgets.grids
|
||||
ui.gadgets.theme ui.render kernel math namespaces sequences
|
||||
vectors models math.vectors math.functions quotations colors ;
|
||||
IN: ui.gadgets.sliders
|
||||
|
|
@ -22,13 +22,13 @@ TUPLE: slider elevator thumb saved line ;
|
|||
|
||||
: min-thumb-dim 15 ;
|
||||
|
||||
: slider-value control-model range-value >fixnum ;
|
||||
: slider-value gadget-model range-value >fixnum ;
|
||||
|
||||
: slider-page control-model range-page-value ;
|
||||
: slider-page gadget-model range-page-value ;
|
||||
|
||||
: slider-max control-model range-max-value ;
|
||||
: slider-max gadget-model range-max-value ;
|
||||
|
||||
: slider-max* control-model range-max-value* ;
|
||||
: slider-max* gadget-model range-max-value* ;
|
||||
|
||||
: thumb-dim ( slider -- h )
|
||||
dup slider-page over slider-max 1 max / 1 min
|
||||
|
|
@ -57,7 +57,7 @@ TUPLE: thumb ;
|
|||
: do-drag ( thumb -- )
|
||||
find-slider drag-loc over gadget-orientation v.
|
||||
over screen>slider swap [ slider-saved + ] keep
|
||||
control-model set-range-value ;
|
||||
gadget-model set-range-value ;
|
||||
|
||||
thumb H{
|
||||
{ T{ button-down } [ begin-drag ] }
|
||||
|
|
@ -75,10 +75,10 @@ thumb H{
|
|||
[ set-gadget-orientation ] keep ;
|
||||
|
||||
: slide-by ( amount slider -- )
|
||||
control-model move-by ;
|
||||
gadget-model move-by ;
|
||||
|
||||
: slide-by-page ( amount slider -- )
|
||||
control-model move-by-page ;
|
||||
gadget-model move-by-page ;
|
||||
|
||||
: compute-direction ( elevator -- -1/1 )
|
||||
dup find-slider swap hand-click-rel
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: namespaces ui.gadgets ui.gestures ui.commands kernel
|
||||
ui.gadgets.scrollers parser prettyprint ui.gadgets.buttons
|
||||
sequences arrays ui.gadgets.borders ui.gadgets.tracks
|
||||
ui.gadgets.editors ui.gadgets.controls io math
|
||||
ui.gadgets.editors io math
|
||||
definitions math.vectors assocs refs ;
|
||||
IN: ui.gadgets.slots
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: ui.gadgets.viewports ui.gadgets.controls help.markup
|
||||
USING: ui.gadgets.viewports help.markup
|
||||
help.syntax ui.gadgets models ;
|
||||
|
||||
HELP: viewport
|
||||
{ $class-description "A viewport is a " { $link control } " which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
|
||||
{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
|
||||
|
||||
HELP: <viewport>
|
||||
{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: ui.gadgets.viewports
|
||||
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.controls
|
||||
USING: arrays ui.gadgets ui.gadgets.borders
|
||||
kernel math namespaces sequences models math.vectors ;
|
||||
|
||||
: viewport-gap { 3 3 } ; inline
|
||||
|
|
@ -30,7 +30,7 @@ M: viewport focusable-child*
|
|||
M: viewport pref-dim* viewport-dim ;
|
||||
|
||||
: scroller-value ( scroller -- loc )
|
||||
control-model range-value [ >fixnum ] map ;
|
||||
gadget-model range-value [ >fixnum ] map ;
|
||||
|
||||
M: viewport model-changed
|
||||
dup relayout-1
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.gadgets colors kernel ui.render namespaces
|
||||
ui.gadgets.controls models sequences ui.gadgets.buttons
|
||||
models sequences ui.gadgets.buttons
|
||||
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||
|
|
@ -52,7 +52,7 @@ TUPLE: deploy-gadget vocab settings ;
|
|||
reflection-settings
|
||||
advanced-settings
|
||||
] make-pile dup deploy-settings-theme
|
||||
namespace <mapping> swap [ 2drop ] <control>
|
||||
namespace <mapping> over set-gadget-model
|
||||
] bind ;
|
||||
|
||||
: find-deploy-gadget
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
|
|||
ui.tools.workspace hashtables io io.styles kernel math
|
||||
math.vectors models namespaces parser prettyprint quotations
|
||||
sequences strings threads listener tuples ui.commands
|
||||
ui.gadgets ui.gadgets.controls ui.gadgets.editors
|
||||
ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures ;
|
||||
IN: ui.tools.interactor
|
||||
|
||||
|
|
@ -19,7 +19,7 @@ help ;
|
|||
|
||||
: word-at-loc ( loc interactor -- word )
|
||||
over [
|
||||
[ control-model T{ one-word-elt } elt-string ] keep
|
||||
[ gadget-model T{ one-word-elt } elt-string ] keep
|
||||
interactor-use assoc-stack
|
||||
] [
|
||||
2drop f
|
||||
|
|
@ -46,7 +46,7 @@ M: caret-help model-changed
|
|||
<source-editor>
|
||||
{ set-interactor-output set-gadget-delegate }
|
||||
interactor construct
|
||||
dup dup set-control-self
|
||||
dup dup set-editor-self
|
||||
dup init-interactor-history
|
||||
dup init-caret-help ;
|
||||
|
||||
|
|
@ -79,7 +79,7 @@ M: interactor ungraft*
|
|||
[ editor-string ] keep
|
||||
[ interactor-input. ] 2keep
|
||||
[ add-interactor-history ] keep
|
||||
dup control-model clear-doc
|
||||
dup gadget-model clear-doc
|
||||
interactor-continue ;
|
||||
|
||||
: interactor-eval ( interactor -- )
|
||||
|
|
@ -123,7 +123,7 @@ M: interactor stream-read-partial
|
|||
|
||||
: go-to-error ( interactor error -- )
|
||||
dup parse-error-line 1- swap parse-error-col 2array
|
||||
over [ control-model validate-loc ] keep
|
||||
over [ gadget-model validate-loc ] keep
|
||||
editor-caret set-model
|
||||
mark>caret ;
|
||||
|
||||
|
|
@ -156,7 +156,7 @@ M: interactor parse-interactive
|
|||
M: interactor pref-dim*
|
||||
0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
|
||||
|
||||
: clear-input control-model clear-doc ;
|
||||
: clear-input gadget-model clear-doc ;
|
||||
|
||||
interactor "interactor" f {
|
||||
{ T{ key-down f f "RET" } evaluate-input }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: continuations documents ui.tools.interactor
|
||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||
timers tools.test ui.commands ui.gadgets.controls
|
||||
ui.gadgets.editors ui.gadgets.panes vocabs words ;
|
||||
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.panes vocabs words ;
|
||||
IN: temporary
|
||||
|
||||
timers [ init-timers ] unless
|
||||
|
|
@ -30,6 +30,6 @@ H{ } "i" get set-interactor-vars
|
|||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"i" get control-model doc-end
|
||||
"i" get gadget-model doc-end
|
||||
"i" get editor-caret* =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs ui.tools.search help.topics io.files io.styles
|
||||
kernel namespaces sequences source-files threads timers
|
||||
tools.test ui.gadgets ui.gadgets.controls ui.gestures vocabs
|
||||
tools.test ui.gadgets ui.gestures vocabs
|
||||
vocabs.loader words ;
|
||||
IN: temporary
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: assocs ui.tools.interactor ui.tools.listener
|
|||
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||
models namespaces prettyprint quotations sequences sorting
|
||||
source-files strings tools.completion tools.crossref tuples
|
||||
ui.commands ui.gadgets ui.gadgets.controls ui.gadgets.editors
|
||||
ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gestures ui.operations vocabs words vocabs.loader
|
||||
tools.browser ;
|
||||
|
|
@ -44,7 +44,7 @@ search-field H{
|
|||
} set-gestures
|
||||
|
||||
: <search-model> ( producer -- model )
|
||||
>r g live-search-field control-model 200 <delay>
|
||||
>r g live-search-field gadget-model 200 <delay>
|
||||
[ "\n" join ] r> append <filter> ;
|
||||
|
||||
: <search-list> ( seq limited? presenter -- gadget )
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
USING: ui.tools ui.tools.interactor ui.tools.listener
|
||||
ui.tools.search ui.tools.workspace kernel models namespaces
|
||||
sequences timers tools.test ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.controls ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.scrollers vocabs ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
[ f ] [
|
||||
0 <model> <gadget> [ 2drop ] <control> gadget set
|
||||
0 <model> <gadget> [ set-gadget-model ] keep gadget set
|
||||
<workspace-tabs> gadget-children empty?
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ ui.tools.operations ui.tools.browser ui.tools.inspector
|
|||
ui.tools.listener ui.tools.profiler ui.tools.walker
|
||||
ui.tools.operations inspector io kernel math models namespaces
|
||||
prettyprint quotations sequences ui ui.commands ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
|
||||
ui.gadgets.books ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
|
||||
vocabs.loader tools.test ui.gadgets.buttons
|
||||
|
|
@ -22,13 +22,13 @@ IN: ui.tools
|
|||
} ;
|
||||
|
||||
: <workspace-tabs> ( -- tabs )
|
||||
g control-model
|
||||
g gadget-model
|
||||
"tool-switching" workspace command-map
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( -- gadget )
|
||||
workspace-tabs [ execute ] map g control-model <book> ;
|
||||
workspace-tabs [ execute ] map g gadget-model <book> ;
|
||||
|
||||
: <workspace> ( -- workspace )
|
||||
0 <model> { 0 1 } <track> workspace construct-control [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations kernel models namespaces prettyprint ui
|
||||
ui.commands ui.gadgets ui.gadgets.controls ui.gadgets.labelled
|
||||
ui.commands ui.gadgets ui.gadgets.labelled
|
||||
ui.gadgets.tracks ui.gestures ;
|
||||
IN: ui.tools.traceback
|
||||
|
||||
|
|
@ -25,10 +25,10 @@ M: traceback-gadget pref-dim* drop { 300 400 } ;
|
|||
{ 0 1 } <track> traceback-gadget construct-control [
|
||||
[
|
||||
[
|
||||
g control-model <datastack-display> 1/2 track,
|
||||
g control-model <retainstack-display> 1/2 track,
|
||||
g gadget-model <datastack-display> 1/2 track,
|
||||
g gadget-model <retainstack-display> 1/2 track,
|
||||
] { 1 0 } make-track 1/3 track,
|
||||
g control-model <callstack-display> 2/3 track,
|
||||
g gadget-model <callstack-display> 2/3 track,
|
||||
] with-gadget
|
||||
] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes continuations help help.topics kernel models
|
||||
sequences ui ui.backend ui.tools.debugger ui.gadgets
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
|
||||
ui.gadgets.books ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
|
||||
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations
|
||||
ui.gadgets.status-bar ui.commands ui.gestures assocs arrays
|
||||
|
|
@ -28,7 +28,7 @@ M: gadget tool-scroller drop f ;
|
|||
workspace-book gadget-children [ class eq? ] curry* find ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ find-tool swap ] keep workspace-book control-model
|
||||
[ find-tool swap ] keep workspace-book gadget-model
|
||||
set-model ;
|
||||
|
||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue