UI inheritance conversion step 1: eliminate all usages of set-gadget-delegate except build-* and some contributed vocabs
Slava Pestov
parent
f90ac9a691
commit
78c3b25f60
|
|
@ -11,10 +11,10 @@ IN: color-picker
|
|||
: <color-slider> ( model -- gadget )
|
||||
<x-slider> 1 over set-slider-line ;
|
||||
|
||||
TUPLE: color-preview ;
|
||||
TUPLE: color-preview < gadget ;
|
||||
|
||||
: <color-preview> ( model -- gadget )
|
||||
<gadget> color-preview construct-control
|
||||
color-preview new-gadget
|
||||
{ 100 100 } over set-rect-dim ;
|
||||
|
||||
M: color-preview model-changed
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! 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.render
|
||||
|
|
@ -70,12 +72,10 @@ IN: slides
|
|||
$divider
|
||||
$list ;
|
||||
|
||||
TUPLE: slides ;
|
||||
TUPLE: slides < book ;
|
||||
|
||||
: <slides> ( slides -- gadget )
|
||||
[ <page> ] map 0 <model> <book>
|
||||
slides construct-gadget
|
||||
[ set-gadget-delegate ] keep ;
|
||||
[ <page> ] map 0 <model> slides new-book ;
|
||||
|
||||
: change-page ( book n -- )
|
||||
over control-value + over gadget-children length rem
|
||||
|
|
@ -103,5 +103,3 @@ TUPLE: slides ;
|
|||
|
||||
: slides-window ( slides -- )
|
||||
[ <slides> "Slides" open-window ] with-ui ;
|
||||
|
||||
MAIN: slides-window
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math arrays cocoa cocoa.application command-line
|
||||
kernel memory namespaces cocoa.messages cocoa.runtime
|
||||
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
|
||||
cocoa.classes cocoa.application sequences system ui ui.backend
|
||||
ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
|
||||
core-foundation threads ;
|
||||
USING: accessors math arrays cocoa cocoa.application
|
||||
command-line kernel memory namespaces cocoa.messages
|
||||
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
||||
cocoa.windows cocoa.classes cocoa.application sequences system
|
||||
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||
ui.cocoa.views core-foundation threads ;
|
||||
IN: ui.cocoa
|
||||
|
||||
TUPLE: handle view window ;
|
||||
|
|
@ -38,7 +38,7 @@ M: pasteboard set-clipboard-contents
|
|||
<clipboard> selection set-global ;
|
||||
|
||||
: world>NSRect ( world -- NSRect )
|
||||
dup world-loc first2 rot rect-dim first2 <NSRect> ;
|
||||
dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
|
||||
|
||||
: gadget-window ( world -- )
|
||||
[
|
||||
|
|
@ -68,7 +68,7 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
|
|||
world-handle handle-view -> isInFullScreenMode zero? not ;
|
||||
|
||||
: auto-position ( world -- )
|
||||
dup world-loc { 0 0 } = [
|
||||
dup window-loc>> { 0 0 } = [
|
||||
world-handle handle-window -> center
|
||||
] [
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages
|
||||
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
|
||||
cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets
|
||||
ui.gadgets.worlds ui.gestures core-foundation threads combinators ;
|
||||
USING: accessors alien alien.c-types arrays assocs cocoa kernel
|
||||
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
|
||||
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
|
||||
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
|
||||
core-foundation threads combinators ;
|
||||
IN: ui.cocoa.views
|
||||
|
||||
: send-mouse-moved ( view event -- )
|
||||
|
|
@ -377,7 +378,7 @@ CLASS: {
|
|||
[
|
||||
2nip -> object
|
||||
dup window-content-rect NSRect-x-y 2array
|
||||
swap -> contentView window set-world-loc
|
||||
swap -> contentView window (>>window-loc)
|
||||
]
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences models ui.gadgets ;
|
||||
USING: accessors kernel sequences models ui.gadgets ;
|
||||
IN: ui.gadgets.books
|
||||
|
||||
TUPLE: book ;
|
||||
TUPLE: book < gadget ;
|
||||
|
||||
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
|
||||
|
||||
|
|
@ -16,8 +16,13 @@ M: book model-changed
|
|||
dup current-page show-gadget
|
||||
relayout ;
|
||||
|
||||
: new-book ( pages model class -- book )
|
||||
new-gadget
|
||||
swap >>model
|
||||
[ add-gadgets ] keep ; inline
|
||||
|
||||
: <book> ( pages model -- book )
|
||||
<gadget> book construct-control [ add-gadgets ] keep ;
|
||||
book new-book ;
|
||||
|
||||
M: book pref-dim* gadget-children pref-dims max-dim ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gadgets generic hashtables kernel math
|
||||
USING: accessors arrays ui.gadgets kernel math
|
||||
namespaces vectors sequences math.vectors ;
|
||||
IN: ui.gadgets.borders
|
||||
|
||||
TUPLE: border size fill ;
|
||||
TUPLE: border < gadget size fill ;
|
||||
|
||||
: <border> ( child gap -- border )
|
||||
dup 2array { 0 0 } border boa
|
||||
<gadget> over set-delegate
|
||||
tuck add-gadget ;
|
||||
border new-gadget
|
||||
swap dup 2array >>size
|
||||
{ 0 0 } >>fill
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
M: border pref-dim*
|
||||
[ border-size 2 v*n ] keep
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ TUPLE: foo-gadget ;
|
|||
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
|
||||
[ "Foo A" ] [ "t" get gadget-child gadget-child gadget-child label-string ] unit-test
|
||||
|
||||
[ ] [
|
||||
2 <model> {
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme
|
||||
USING: accessors arrays kernel math models namespaces sequences
|
||||
strings quotations assocs combinators classes colors
|
||||
classes.tuple opengl math.vectors
|
||||
ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.theme ui.gadgets.wrappers
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render kernel math models namespaces sequences strings
|
||||
quotations assocs combinators classes colors classes.tuple
|
||||
opengl math.vectors ;
|
||||
ui.render ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button pressed? selected? quot ;
|
||||
TUPLE: button < wrapper pressed? selected? quot ;
|
||||
|
||||
: buttons-down? ( -- ? )
|
||||
hand-buttons get-global empty? not ;
|
||||
|
|
@ -39,10 +40,13 @@ button H{
|
|||
{ T{ mouse-enter } [ button-update ] }
|
||||
} set-gestures
|
||||
|
||||
: <button> ( gadget quot -- button )
|
||||
button new
|
||||
: new-button ( label quot class -- button )
|
||||
new-gadget
|
||||
swap >>quot
|
||||
[ set-gadget-delegate ] keep ;
|
||||
[ >r >label r> add-gadget ] keep ; inline
|
||||
|
||||
: <button> ( gadget quot -- button )
|
||||
button new-button ;
|
||||
|
||||
TUPLE: button-paint plain rollover pressed selected ;
|
||||
|
||||
|
|
@ -69,7 +73,7 @@ M: button-paint draw-boundary
|
|||
f black <solid> dup f <button-paint> >>boundary ; inline
|
||||
|
||||
: <roll-button> ( label quot -- button )
|
||||
>r >label r> <button> roll-button-theme ;
|
||||
<button> roll-button-theme ;
|
||||
|
||||
: <bevel-button-paint> ( -- paint )
|
||||
plain-gradient
|
||||
|
|
@ -82,11 +86,13 @@ M: button-paint draw-boundary
|
|||
<bevel-button-paint> >>interior
|
||||
faint-boundary ; inline
|
||||
|
||||
: <bevel-button> ( label quot -- button )
|
||||
>r >label 5 <border> r>
|
||||
<button> bevel-button-theme ;
|
||||
: >bevel-label ( label -- gadget )
|
||||
>label 5 <border> ;
|
||||
|
||||
TUPLE: repeat-button ;
|
||||
: <bevel-button> ( label quot -- button )
|
||||
>r >bevel-label r> <button> bevel-button-theme ;
|
||||
|
||||
TUPLE: repeat-button < button ;
|
||||
|
||||
repeat-button H{
|
||||
{ T{ drag } [ button-clicked ] }
|
||||
|
|
@ -95,8 +101,7 @@ repeat-button H{
|
|||
: <repeat-button> ( label quot -- button )
|
||||
#! Button that calls the quotation every 100ms as long as
|
||||
#! the mouse is held down.
|
||||
repeat-button new
|
||||
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
|
||||
>r >bevel-label r> repeat-button new-button bevel-button-theme ;
|
||||
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
|
|
@ -128,20 +133,18 @@ M: checkmark-paint draw-interior
|
|||
: toggle-model ( model -- )
|
||||
[ not ] change-model ;
|
||||
|
||||
: checkbox-theme ( gadget -- )
|
||||
: checkbox-theme ( gadget -- gadget )
|
||||
f >>interior
|
||||
{ 5 5 } >>gap
|
||||
1/2 >>align
|
||||
drop ;
|
||||
1/2 >>align ; inline
|
||||
|
||||
TUPLE: checkbox ;
|
||||
TUPLE: checkbox < button ;
|
||||
|
||||
: <checkbox> ( model label -- checkbox )
|
||||
<checkmark>
|
||||
label-on-right
|
||||
over [ toggle-model drop ] curry <button>
|
||||
checkbox construct-control
|
||||
dup checkbox-theme ;
|
||||
<checkmark> label-on-right checkbox-theme
|
||||
[ model>> toggle-model ]
|
||||
checkbox new-button
|
||||
swap >>model ;
|
||||
|
||||
M: checkbox model-changed
|
||||
swap model-value over set-button-selected? relayout-1 ;
|
||||
|
|
@ -173,12 +176,13 @@ M: radio-paint draw-boundary
|
|||
dup radio-knob-theme
|
||||
{ 16 16 } over set-gadget-dim ;
|
||||
|
||||
TUPLE: radio-control value ;
|
||||
TUPLE: radio-control < button value ;
|
||||
|
||||
: <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
|
||||
: <radio-control> ( value model label -- control )
|
||||
[ [ value>> ] keep set-control-value ]
|
||||
radio-control new-button
|
||||
swap >>model
|
||||
swap >>value ; inline
|
||||
|
||||
M: radio-control model-changed
|
||||
swap model-value
|
||||
|
|
@ -190,15 +194,12 @@ M: radio-control model-changed
|
|||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
|
||||
|
||||
: radio-button-theme ( gadget -- )
|
||||
: radio-button-theme ( gadget -- gadget )
|
||||
{ 5 5 } >>gap
|
||||
1/2 >>align
|
||||
drop ;
|
||||
1/2 >>align ; inline
|
||||
|
||||
: <radio-button> ( value model label -- gadget )
|
||||
<radio-knob> label-on-right
|
||||
[ <button> ] <radio-control>
|
||||
dup radio-button-theme ;
|
||||
<radio-knob> label-on-right radio-button-theme <radio-control> ;
|
||||
|
||||
: radio-buttons-theme ( gadget -- )
|
||||
{ 5 5 } >>gap drop ;
|
||||
|
|
@ -208,7 +209,7 @@ M: radio-control model-changed
|
|||
dup radio-buttons-theme ;
|
||||
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
[ <bevel-button> ] <radio-control> ;
|
||||
>bevel-label <radio-control> bevel-button-theme ;
|
||||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
[ [ <toggle-button> ] <radio-controls> ] make-shelf ;
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@ ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
|
|||
classes.tuple colors ;
|
||||
IN: ui.gadgets.canvas
|
||||
|
||||
TUPLE: canvas dlist ;
|
||||
TUPLE: canvas < gadget dlist ;
|
||||
|
||||
: <canvas> ( -- canvas )
|
||||
canvas construct-gadget
|
||||
canvas new-gadget
|
||||
black solid-interior ;
|
||||
|
||||
: delete-canvas-dlist ( canvas -- )
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! 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.render ui.gestures io
|
||||
kernel math models namespaces opengl opengl.gl sequences strings
|
||||
io.styles math.vectors sorting colors combinators assocs
|
||||
math.order ;
|
||||
USING: accessors arrays documents io kernel math models
|
||||
namespaces opengl opengl.gl sequences strings io.styles
|
||||
math.vectors sorting colors combinators assocs math.order
|
||||
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor
|
||||
TUPLE: editor < gadget
|
||||
self
|
||||
font color caret-color selection-color
|
||||
caret mark
|
||||
|
|
@ -16,28 +16,25 @@ focused? ;
|
|||
|
||||
: <loc> ( -- loc ) { 0 0 } <model> ;
|
||||
|
||||
: init-editor-locs ( editor -- )
|
||||
<loc> over set-editor-caret
|
||||
<loc> swap set-editor-mark ;
|
||||
: init-editor-locs ( editor -- editor )
|
||||
<loc> >>caret
|
||||
<loc> >>mark ; inline
|
||||
|
||||
: editor-theme ( editor -- )
|
||||
black over set-editor-color
|
||||
red over set-editor-caret-color
|
||||
selection-color over set-editor-selection-color
|
||||
monospace-font swap set-editor-font ;
|
||||
: editor-theme ( editor -- editor )
|
||||
black >>color
|
||||
red >>caret-color
|
||||
selection-color >>selection-color
|
||||
monospace-font >>font ; inline
|
||||
|
||||
: new-editor ( class -- editor )
|
||||
new-gadget
|
||||
<document> >>model
|
||||
init-editor-locs
|
||||
editor-theme
|
||||
dup dup set-editor-self ; inline
|
||||
|
||||
: <editor> ( -- editor )
|
||||
<document> <gadget> editor construct-control
|
||||
dup dup set-editor-self
|
||||
dup init-editor-locs
|
||||
dup editor-theme ;
|
||||
|
||||
: field-theme ( gadget -- )
|
||||
gray <solid> swap set-gadget-boundary ;
|
||||
|
||||
: construct-editor ( object class -- tuple )
|
||||
>r { set-gadget-delegate } r> construct
|
||||
dup dup set-editor-self ; inline
|
||||
editor new-editor ;
|
||||
|
||||
: activate-editor-model ( editor model -- )
|
||||
2dup add-connection
|
||||
|
|
@ -474,10 +471,10 @@ editor "selection" f {
|
|||
} define-command-map
|
||||
|
||||
! Multi-line editors
|
||||
TUPLE: multiline-editor ;
|
||||
TUPLE: multiline-editor < editor ;
|
||||
|
||||
: <multiline-editor> ( -- editor )
|
||||
<editor> multiline-editor construct-editor ;
|
||||
multiline-editor new-editor ;
|
||||
|
||||
multiline-editor "general" f {
|
||||
{ T{ key-down f f "RET" } insert-newline }
|
||||
|
|
@ -485,33 +482,34 @@ multiline-editor "general" f {
|
|||
{ T{ key-down f f "ENTER" } insert-newline }
|
||||
} define-command-map
|
||||
|
||||
TUPLE: source-editor ;
|
||||
TUPLE: source-editor < editor ;
|
||||
|
||||
: <source-editor> ( -- editor )
|
||||
<multiline-editor> source-editor construct-editor ;
|
||||
source-editor new-editor ;
|
||||
|
||||
! Fields are like editors except they edit an external model
|
||||
TUPLE: field model editor ;
|
||||
! Fields wrap an editor and edit an external model
|
||||
TUPLE: field < wrapper field-model editor ;
|
||||
|
||||
: field-theme ( gadget -- gadget )
|
||||
gray <solid> >>boundary ; inline
|
||||
|
||||
: <field-border> ( gadget -- border )
|
||||
2 <border>
|
||||
{ 1 0 } over set-border-fill
|
||||
dup field-theme ;
|
||||
{ 1 0 } >>fill
|
||||
field-theme ;
|
||||
|
||||
: <field> ( model -- gadget )
|
||||
<editor> dup <field-border>
|
||||
{ set-field-model set-field-editor set-gadget-delegate }
|
||||
field construct ;
|
||||
<editor> dup <field-border> field new-wrapper
|
||||
swap >>editor
|
||||
swap >>field-model ;
|
||||
|
||||
M: field graft*
|
||||
dup field-model model-value
|
||||
over field-editor set-editor-string
|
||||
dup field-editor gadget-model add-connection ;
|
||||
[ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
|
||||
[ dup editor>> model>> add-connection ]
|
||||
bi ;
|
||||
|
||||
M: field ungraft*
|
||||
dup field-editor gadget-model remove-connection ;
|
||||
dup editor>> model>> remove-connection ;
|
||||
|
||||
M: field model-changed
|
||||
nip
|
||||
dup field-editor editor-string
|
||||
swap field-model set-model ;
|
||||
nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: ui.gadgets.frames
|
|||
|
||||
! A frame arranges gadgets in a 3x3 grid, where the center
|
||||
! gadgets gets left-over space.
|
||||
TUPLE: frame ;
|
||||
TUPLE: frame < grid ;
|
||||
|
||||
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
|
||||
|
||||
|
|
@ -21,9 +21,11 @@ TUPLE: frame ;
|
|||
: @bottom-left 0 2 ;
|
||||
: @bottom-right 2 2 ;
|
||||
|
||||
: new-frame ( class -- frame )
|
||||
<frame-grid> swap new-grid ; inline
|
||||
|
||||
: <frame> ( -- frame )
|
||||
frame new
|
||||
<frame-grid> <grid> over set-gadget-delegate ;
|
||||
frame new-frame ;
|
||||
|
||||
: (fill-center) ( vec n -- )
|
||||
over first pick third v+ [v-] 1 rot set-nth ;
|
||||
|
|
|
|||
|
|
@ -65,8 +65,6 @@ HELP: <gadget>
|
|||
{ $values { "gadget" "a new " { $link gadget } } }
|
||||
{ $description "Creates a new gadget." } ;
|
||||
|
||||
{ <gadget> set-gadget-delegate } related-words
|
||||
|
||||
HELP: relative-loc
|
||||
{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
|
||||
{ $description
|
||||
|
|
@ -99,11 +97,6 @@ HELP: each-child
|
|||
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
|
||||
{ $description "Applies the quotation to each child of the gadget." } ;
|
||||
|
||||
HELP: set-gadget-delegate
|
||||
{ $values { "gadget" gadget } { "tuple" tuple } }
|
||||
{ $description "Sets the delegate of " { $snippet "tuple" } " to " { $snippet "gadget" } ". This is like " { $link set-delegate } ", except that to ensure correct behavior, the parent of each child of " { $snippet "gadget" } " is changed to " { $snippet "tuple" } "." }
|
||||
{ $notes "This word should be used instead of " { $link set-delegate } " when setting a tuple's delegate to a gadget." } ;
|
||||
|
||||
HELP: gadget-selection?
|
||||
{ $values { "gadget" gadget } { "?" "a boolean" } }
|
||||
{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
|
||||
|
|
@ -261,33 +254,7 @@ HELP: g->
|
|||
{ $values { "x" object } { "gadget" gadget } }
|
||||
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ;
|
||||
|
||||
HELP: construct-control
|
||||
{ $values { "model" model } { "gadget" gadget } { "class" class } { "control" gadget } }
|
||||
{ $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 ;"
|
||||
""
|
||||
"TUPLE: color-gadget ;"
|
||||
""
|
||||
"M: color-gadget model-changed"
|
||||
" >r model-value r> set-fill-color ;"
|
||||
""
|
||||
": <color-gadget> ( model -- gadget )"
|
||||
" <gadget>"
|
||||
" { 100 100 } over set-rect-dim"
|
||||
" color-gadget"
|
||||
" construct-control ;"
|
||||
""
|
||||
"{ 1.0 0.0 0.5 1.0 } <model> <color-gadget>"
|
||||
"gadget."
|
||||
}
|
||||
"The " { $vocab-link "color-picker" } " module extends this example into a more elaborate color chooser."
|
||||
} ;
|
||||
|
||||
{ construct-control control-value set-control-value gadget-model } related-words
|
||||
{ control-value set-control-value gadget-model } related-words
|
||||
|
||||
HELP: control-value
|
||||
{ $values { "control" gadget } { "value" object } }
|
||||
|
|
@ -298,10 +265,8 @@ HELP: set-control-value
|
|||
{ $description "Sets the value of the control's model." } ;
|
||||
|
||||
ARTICLE: "ui-control-impl" "Implementing controls"
|
||||
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a model instance."
|
||||
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
|
||||
$nl
|
||||
"To implement a new control, simply use this word in your constructor:"
|
||||
{ $subsection construct-control }
|
||||
"Some utility words useful in control implementations:"
|
||||
{ $subsection gadget-model }
|
||||
{ $subsection control-value }
|
||||
|
|
|
|||
|
|
@ -36,13 +36,6 @@ prettyprint io.streams.string ;
|
|||
intersects?
|
||||
] unit-test
|
||||
|
||||
TUPLE: fooey ;
|
||||
|
||||
C: <fooey> fooey
|
||||
|
||||
[ ] [ <gadget> <fooey> set-gadget-delegate ] unit-test
|
||||
[ ] [ f <fooey> set-gadget-delegate ] unit-test
|
||||
|
||||
[ { 300 300 } ]
|
||||
[
|
||||
! c contains b contains a
|
||||
|
|
@ -113,7 +106,7 @@ C: <fooey> fooey
|
|||
|
||||
TUPLE: mock-gadget graft-called ungraft-called ;
|
||||
|
||||
: <mock-gadget>
|
||||
: <mock-gadget> ( -- gadget )
|
||||
0 0 mock-gadget boa <gadget> over set-delegate ;
|
||||
|
||||
M: mock-gadget graft*
|
||||
|
|
|
|||
|
|
@ -9,7 +9,9 @@ SYMBOL: ui-notify-flag
|
|||
|
||||
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
||||
|
||||
TUPLE: rect loc dim ;
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ;
|
||||
|
||||
C: <rect> rect
|
||||
|
||||
|
|
@ -44,12 +46,14 @@ M: array rect-dim drop { 0 0 } ;
|
|||
: rect-union ( rect1 rect2 -- newrect )
|
||||
(rect-union) <extent-rect> ;
|
||||
|
||||
TUPLE: gadget < identity-tuple
|
||||
TUPLE: gadget < rect
|
||||
pref-dim parent children orientation focus
|
||||
visible? root? clipped? layout-state graft-state graft-node
|
||||
interior boundary
|
||||
model ;
|
||||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* drop gadget hashcode* ;
|
||||
|
||||
M: gadget model-changed 2drop ;
|
||||
|
|
@ -58,15 +62,14 @@ M: gadget model-changed 2drop ;
|
|||
|
||||
: nth-gadget ( n gadget -- child ) gadget-children nth ;
|
||||
|
||||
: <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
|
||||
: new-gadget ( class -- gadget )
|
||||
new
|
||||
{ 0 1 } >>orientation
|
||||
t >>visible?
|
||||
{ f f } >>graft-state ; inline
|
||||
|
||||
: <gadget> ( -- gadget )
|
||||
<zero-rect> { 0 1 } t { f f } {
|
||||
set-delegate
|
||||
set-gadget-orientation
|
||||
set-gadget-visible?
|
||||
set-gadget-graft-state
|
||||
} gadget construct ;
|
||||
gadget new-gadget ;
|
||||
|
||||
: construct-gadget ( class -- tuple )
|
||||
>r <gadget> r> construct-delegate ; inline
|
||||
|
|
@ -142,10 +145,6 @@ M: gadget children-on nip gadget-children ;
|
|||
dup pick [ set-gadget-parent ] with 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 -- ? )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,31 +1,33 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math namespaces sequences words io
|
||||
io.streams.string math.vectors ui.gadgets columns ;
|
||||
io.streams.string math.vectors ui.gadgets columns accessors ;
|
||||
IN: ui.gadgets.grids
|
||||
|
||||
TUPLE: grid children gap fill? ;
|
||||
TUPLE: grid < gadget
|
||||
grid
|
||||
{ gap initial: { 0 0 } }
|
||||
{ fill? initial: t } ;
|
||||
|
||||
: set-grid-children* ( children grid -- )
|
||||
[ set-grid-children ] 2keep >r concat r> add-gadgets ;
|
||||
: new-grid ( children class -- grid )
|
||||
new-gadget
|
||||
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
|
||||
inline
|
||||
|
||||
: <grid> ( children -- grid )
|
||||
grid construct-gadget
|
||||
[ set-grid-children* ] keep
|
||||
{ 0 0 } over set-grid-gap
|
||||
t over set-grid-fill? ;
|
||||
grid new-grid ;
|
||||
|
||||
: grid-child ( grid i j -- gadget ) rot grid-children nth nth ;
|
||||
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
|
||||
|
||||
: grid-add ( gadget grid i j -- )
|
||||
>r >r 2dup add-gadget r> r>
|
||||
3dup grid-child unparent rot grid-children nth set-nth ;
|
||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||
|
||||
: grid-remove ( grid i j -- )
|
||||
>r >r >r <gadget> r> r> r> grid-add ;
|
||||
|
||||
: pref-dim-grid ( grid -- dims )
|
||||
grid-children [ [ pref-dim ] map ] map ;
|
||||
grid>> [ [ pref-dim ] map ] map ;
|
||||
|
||||
: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
|
||||
|
||||
|
|
@ -49,7 +51,7 @@ M: grid pref-dim*
|
|||
gap-sum >r gap-sum r> (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
-rot grid-children
|
||||
-rot grid>>
|
||||
[ [ pick call ] 2each ] 2each
|
||||
drop ; inline
|
||||
|
||||
|
|
@ -65,7 +67,7 @@ M: grid pref-dim*
|
|||
pick grid-fill? [
|
||||
pair-up swap [ set-layout-dim ] do-grid
|
||||
] [
|
||||
2drop grid-children [ [ prefer ] each ] each
|
||||
2drop grid>> [ [ prefer ] each ] each
|
||||
] if ;
|
||||
|
||||
: grid-layout ( grid horiz vert -- )
|
||||
|
|
@ -77,12 +79,12 @@ M: grid children-on ( rect gadget -- seq )
|
|||
dup gadget-children empty? [
|
||||
2drop f
|
||||
] [
|
||||
{ 0 1 } swap grid-children
|
||||
{ 0 1 } swap grid>>
|
||||
[ 0 <column> fast-children-on ] keep
|
||||
<slice> concat
|
||||
] if ;
|
||||
|
||||
M: grid gadget-text*
|
||||
grid-children
|
||||
grid>>
|
||||
[ [ gadget-text ] map ] map format-table
|
||||
[ CHAR: \n , ] [ % ] interleave ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io kernel math namespaces math.vectors ui.gadgets ;
|
||||
USING: io kernel math namespaces math.vectors ui.gadgets
|
||||
ui.gadgets.packs accessors ;
|
||||
IN: ui.gadgets.incremental
|
||||
|
||||
! Incremental layout allows adding lines to panes to be O(1).
|
||||
|
|
@ -14,16 +15,16 @@ IN: ui.gadgets.incremental
|
|||
! New gadgets are added at
|
||||
! incremental-cursor gadget-orientation v*
|
||||
|
||||
TUPLE: incremental cursor ;
|
||||
TUPLE: incremental < pack cursor ;
|
||||
|
||||
: <incremental> ( pack -- incremental )
|
||||
dup pref-dim
|
||||
{ set-gadget-delegate set-incremental-cursor }
|
||||
incremental construct ;
|
||||
: <incremental> ( -- incremental )
|
||||
incremental new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
{ 0 0 } >>cursor ;
|
||||
|
||||
M: incremental pref-dim*
|
||||
dup gadget-layout-state [
|
||||
dup delegate pref-dim over set-incremental-cursor
|
||||
dup call-next-method over set-incremental-cursor
|
||||
] when incremental-cursor ;
|
||||
|
||||
: next-cursor ( gadget incremental -- cursor )
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled
|
||||
ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces
|
||||
kernel tools.test ui.gadgets.buttons sequences ;
|
||||
IN: ui.gadgets.labelled.tests
|
||||
|
||||
TUPLE: testing ;
|
||||
|
||||
|
||||
[ ] [
|
||||
T{ testing } [ "Hey" <label> ] "Testing"
|
||||
build-closable-gadget "g" set
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "g" get testing? ] unit-test
|
||||
|
||||
[ t ] [ "g" get delegate closable-gadget? ] unit-test
|
||||
|
||||
[ t ] [ "g" get closable-gadget-content label? ] unit-test
|
||||
|
||||
[ ] [
|
||||
<pile> "p" set
|
||||
"g" get "p" get add-gadget
|
||||
"g" get @top grid-child @left grid-child
|
||||
dup button-quot call
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "g" get "p" get gadget-children memq? ] unit-test
|
||||
|
|
@ -57,8 +57,3 @@ TUPLE: closable-gadget content ;
|
|||
] build-frame ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
||||
: build-closable-gadget ( tuple quot title -- tuple )
|
||||
pick >r >r with-gadget
|
||||
r> [ find-closable-gadget unparent ] <closable-gadget> r>
|
||||
[ set-gadget-delegate ] keep ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables io kernel math namespaces
|
||||
opengl sequences strings splitting
|
||||
|
|
@ -7,7 +7,7 @@ models ;
|
|||
IN: ui.gadgets.labels
|
||||
|
||||
! A label gadget draws a string.
|
||||
TUPLE: label text font color ;
|
||||
TUPLE: label < gadget text font color ;
|
||||
|
||||
: label-string ( label -- string )
|
||||
text>> dup string? [ "\n" join ] unless ; inline
|
||||
|
|
@ -23,10 +23,13 @@ TUPLE: label text font color ;
|
|||
sans-serif-font >>font
|
||||
black >>color ; inline
|
||||
|
||||
: <label> ( string -- label )
|
||||
label construct-gadget
|
||||
: new-label ( string class -- label )
|
||||
new-gadget
|
||||
[ set-label-string ] keep
|
||||
label-theme ;
|
||||
label-theme ; inline
|
||||
|
||||
: <label> ( string -- label )
|
||||
label new-label ;
|
||||
|
||||
M: label pref-dim*
|
||||
[ font>> open-font ] [ text>> ] bi text-dim ;
|
||||
|
|
@ -37,13 +40,14 @@ M: label draw-gadget*
|
|||
|
||||
M: label gadget-text* label-string % ;
|
||||
|
||||
TUPLE: label-control ;
|
||||
TUPLE: label-control < label ;
|
||||
|
||||
M: label-control model-changed
|
||||
swap model-value over set-label-string relayout ;
|
||||
|
||||
: <label-control> ( model -- gadget )
|
||||
"" <label> label-control construct-control ;
|
||||
"" label-control new-label
|
||||
swap >>model ;
|
||||
|
||||
: text-theme ( gadget -- gadget )
|
||||
black >>color
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ui.commands ui.gestures ui.render ui.gadgets
|
||||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
|
|
@ -7,17 +7,20 @@ ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
|
|||
math.vectors classes.tuple ;
|
||||
IN: ui.gadgets.lists
|
||||
|
||||
TUPLE: list index presenter color hook ;
|
||||
TUPLE: list < pack index presenter color hook ;
|
||||
|
||||
: list-theme ( list -- )
|
||||
{ 0.8 0.8 1.0 1.0 } swap set-list-color ;
|
||||
: list-theme ( list -- list )
|
||||
{ 0.8 0.8 1.0 1.0 } >>color ; inline
|
||||
|
||||
: <list> ( hook presenter model -- gadget )
|
||||
<filled-pile> list construct-control
|
||||
[ set-list-presenter ] keep
|
||||
[ set-list-hook ] keep
|
||||
0 over set-list-index
|
||||
dup list-theme ;
|
||||
list new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
1 >>fill
|
||||
0 >>index
|
||||
swap >>model
|
||||
swap >>presenter
|
||||
swap >>hook
|
||||
list-theme ;
|
||||
|
||||
: calc-bounded-index ( n list -- m )
|
||||
control-value length 1- min 0 max ;
|
||||
|
|
@ -30,9 +33,9 @@ TUPLE: list index presenter color hook ;
|
|||
hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
|
||||
|
||||
: <list-presentation> ( hook elt presenter -- gadget )
|
||||
keep <presentation>
|
||||
swap >>hook
|
||||
text-theme ; inline
|
||||
keep >r >label text-theme r>
|
||||
<presentation>
|
||||
swap >>hook ; inline
|
||||
|
||||
: <list-items> ( list -- seq )
|
||||
[ list-presentation-hook ]
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: ui.gadgets.menus
|
|||
: menu-loc ( world menu -- loc )
|
||||
>r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
|
||||
|
||||
TUPLE: menu-glass ;
|
||||
TUPLE: menu-glass < gadget ;
|
||||
|
||||
: <menu-glass> ( menu world -- glass )
|
||||
menu-glass construct-gadget
|
||||
menu-glass new-gadget
|
||||
>r over menu-loc over set-rect-loc r>
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences ui.gadgets kernel math math.functions
|
||||
math.vectors namespaces math.order ;
|
||||
math.vectors namespaces math.order accessors ;
|
||||
IN: ui.gadgets.packs
|
||||
|
||||
TUPLE: pack align fill gap ;
|
||||
TUPLE: pack < gadget
|
||||
{ align initial: 0 }
|
||||
{ fill initial: 0 }
|
||||
{ gap initial: { 0 0 } } ;
|
||||
|
||||
: packed-dim-2 ( gadget sizes -- list )
|
||||
[ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
|
||||
|
|
@ -32,13 +35,8 @@ TUPLE: pack align fill gap ;
|
|||
>r packed-locs r> [ set-rect-loc ] 2each ;
|
||||
|
||||
: <pack> ( orientation -- pack )
|
||||
0 0 { 0 0 } <gadget> {
|
||||
set-gadget-orientation
|
||||
set-pack-align
|
||||
set-pack-fill
|
||||
set-pack-gap
|
||||
set-delegate
|
||||
} pack construct ;
|
||||
pack new-gadget
|
||||
swap >>orientation ;
|
||||
|
||||
: <pile> ( -- pack ) { 0 1 } <pack> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@ ui.gadgets.grid-lines classes.tuple models continuations
|
|||
destructors accessors ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane output current prototype scrolls?
|
||||
TUPLE: pane < pack
|
||||
output current prototype scrolls?
|
||||
selection-color caret mark selecting? ;
|
||||
|
||||
: clear-selection ( pane -- )
|
||||
|
|
@ -47,16 +48,19 @@ M: pane gadget-selection
|
|||
[ pane-current clear-gadget ]
|
||||
tri ;
|
||||
|
||||
: pane-theme ( pane -- )
|
||||
selection-color >>selection-color drop ;
|
||||
: pane-theme ( pane -- pane )
|
||||
selection-color >>selection-color ; inline
|
||||
|
||||
: new-pane ( class -- pane )
|
||||
new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
<shelf> >>prototype
|
||||
<incremental> over add-output
|
||||
dup prepare-line
|
||||
pane-theme ;
|
||||
|
||||
: <pane> ( -- pane )
|
||||
pane new
|
||||
<pile> over set-delegate
|
||||
<shelf> >>prototype
|
||||
<pile> <incremental> over add-output
|
||||
dup prepare-line
|
||||
dup pane-theme ;
|
||||
pane new-pane ;
|
||||
|
||||
GENERIC: draw-selection ( loc obj -- )
|
||||
|
||||
|
|
@ -142,14 +146,15 @@ M: style-stream write-gadget
|
|||
: <scrolling-pane> ( -- pane )
|
||||
<pane> t over set-pane-scrolls? ;
|
||||
|
||||
TUPLE: pane-control quot ;
|
||||
TUPLE: pane-control < pane quot ;
|
||||
|
||||
M: pane-control model-changed
|
||||
swap model-value swap dup pane-control-quot with-pane ;
|
||||
|
||||
: <pane-control> ( model quot -- pane )
|
||||
>r <pane> pane-control construct-control r>
|
||||
over set-pane-control-quot ;
|
||||
pane-control new-pane
|
||||
swap >>quot
|
||||
swap >>model ;
|
||||
|
||||
: do-pane-stream ( pane-stream quot -- )
|
||||
>r pane-stream-pane r> keep scroll-pane ; inline
|
||||
|
|
|
|||
|
|
@ -13,10 +13,10 @@ TUPLE: word-break-gadget ;
|
|||
M: word-break-gadget draw-gadget* drop ;
|
||||
|
||||
! A gadget that arranges its children in a word-wrap style.
|
||||
TUPLE: paragraph margin ;
|
||||
TUPLE: paragraph < gadget margin ;
|
||||
|
||||
: <paragraph> ( margin -- gadget )
|
||||
paragraph construct-gadget
|
||||
paragraph new-gadget
|
||||
{ 1 0 } over set-gadget-orientation
|
||||
[ set-paragraph-margin ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions ui.gadgets ui.gadgets.borders
|
||||
USING: arrays accessors definitions ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus
|
||||
ui.gadgets.worlds hashtables io kernel prettyprint sequences
|
||||
strings io.styles words help math models namespaces quotations
|
||||
ui.commands ui.operations ui.gestures ;
|
||||
IN: ui.gadgets.presentations
|
||||
|
||||
TUPLE: presentation object hook ;
|
||||
TUPLE: presentation < button object hook ;
|
||||
|
||||
: invoke-presentation ( presentation command -- )
|
||||
over dup presentation-hook call
|
||||
|
|
@ -25,15 +25,14 @@ TUPLE: presentation object hook ;
|
|||
dup presentation-object over show-summary button-update ;
|
||||
|
||||
: <presentation> ( label object -- button )
|
||||
presentation new
|
||||
[ drop ] over set-presentation-hook
|
||||
[ set-presentation-object ] keep
|
||||
swap [ invoke-primary ] <roll-button>
|
||||
over set-gadget-delegate ;
|
||||
swap [ invoke-primary ] presentation new-button
|
||||
swap >>object
|
||||
[ drop ] >>hook
|
||||
roll-button-theme ;
|
||||
|
||||
M: presentation ungraft*
|
||||
dup hand-gadget get-global child? [ dup hide-status ] when
|
||||
delegate ungraft* ;
|
||||
call-next-method ;
|
||||
|
||||
: <operations-menu> ( presentation -- menu )
|
||||
dup dup presentation-hook curry
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ models models.range models.compose
|
|||
combinators math.vectors classes.tuple ;
|
||||
IN: ui.gadgets.scrollers
|
||||
|
||||
TUPLE: scroller viewport x y follows ;
|
||||
TUPLE: scroller < frame viewport x y follows ;
|
||||
|
||||
: find-scroller ( gadget -- scroller/f )
|
||||
[ [ scroller? ] is? ] find-parent ;
|
||||
|
|
@ -40,14 +40,21 @@ scroller H{
|
|||
|
||||
: y-model ( -- model ) g gadget-model model-dependencies second ;
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
<scroller-model> <frame> scroller construct-control [
|
||||
: new-scroller ( gadget class -- scroller )
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
[
|
||||
[
|
||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||
viewport,
|
||||
] with-gadget
|
||||
] keep t >>root? faint-boundary ;
|
||||
] keep ;
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
scroller new-scroller ;
|
||||
|
||||
: scroll ( value scroller -- )
|
||||
[
|
||||
|
|
@ -123,7 +130,7 @@ scroller H{
|
|||
} cond ;
|
||||
|
||||
M: scroller layout*
|
||||
dup delegate layout*
|
||||
dup call-next-method
|
||||
dup scroller-follows
|
||||
[ update-scroller ] 2keep
|
||||
swap set-scroller-follows ;
|
||||
|
|
@ -134,12 +141,10 @@ M: scroller focusable-child*
|
|||
M: scroller model-changed
|
||||
nip f swap set-scroller-follows ;
|
||||
|
||||
TUPLE: limited-scroller dim ;
|
||||
TUPLE: limited-scroller < scroller fixed-dim ;
|
||||
|
||||
: <limited-scroller> ( gadget -- scroller )
|
||||
<scroller>
|
||||
limited-scroller new
|
||||
[ set-gadget-delegate ] keep ;
|
||||
: <limited-scroller> ( gadget dim -- scroller )
|
||||
>r limited-scroller new-scroller r> >>fixed-dim ;
|
||||
|
||||
M: limited-scroller pref-dim*
|
||||
dim>> ;
|
||||
fixed-dim>> ;
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@ vectors models models.range math.vectors math.functions
|
|||
quotations colors ;
|
||||
IN: ui.gadgets.sliders
|
||||
|
||||
TUPLE: elevator direction ;
|
||||
TUPLE: elevator < gadget direction ;
|
||||
|
||||
: find-elevator ( gadget -- elevator/f )
|
||||
[ elevator? ] find-parent ;
|
||||
|
||||
TUPLE: slider elevator thumb saved line ;
|
||||
TUPLE: slider < frame elevator thumb saved line ;
|
||||
|
||||
: find-slider ( gadget -- slider/f )
|
||||
[ slider? ] find-parent ;
|
||||
|
|
@ -50,7 +50,7 @@ TUPLE: slider elevator thumb saved line ;
|
|||
|
||||
M: slider model-changed nip slider-elevator relayout-1 ;
|
||||
|
||||
TUPLE: thumb ;
|
||||
TUPLE: thumb < gadget ;
|
||||
|
||||
: begin-drag ( thumb -- )
|
||||
find-slider dup slider-value swap set-slider-saved ;
|
||||
|
|
@ -71,7 +71,7 @@ thumb H{
|
|||
faint-boundary ; inline
|
||||
|
||||
: <thumb> ( vector -- thumb )
|
||||
thumb construct-gadget
|
||||
thumb new-gadget
|
||||
swap >>orientation
|
||||
t >>root?
|
||||
thumb-theme ;
|
||||
|
|
@ -104,7 +104,7 @@ elevator H{
|
|||
lowered-gradient swap set-gadget-interior ;
|
||||
|
||||
: <elevator> ( vector -- elevator )
|
||||
elevator construct-gadget
|
||||
elevator new-gadget
|
||||
[ set-gadget-orientation ] keep
|
||||
dup elevator-theme ;
|
||||
|
||||
|
|
@ -170,9 +170,10 @@ M: elevator layout*
|
|||
] with-gadget ;
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
swap <frame> slider construct-control
|
||||
[ set-gadget-orientation ] keep
|
||||
32 over set-slider-line ;
|
||||
slider new-frame
|
||||
swap >>orientation
|
||||
swap >>model
|
||||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider> dup build-x-slider ;
|
||||
|
|
@ -181,6 +182,6 @@ M: elevator layout*
|
|||
{ 0 1 } <slider> dup build-y-slider ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup delegate pref-dim*
|
||||
dup call-next-method
|
||||
swap gadget-orientation [ 40 v*n ] keep
|
||||
set-axis ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 io math
|
||||
definitions math.vectors assocs refs ;
|
||||
USING: accessors namespaces kernel parser prettyprint
|
||||
sequences arrays io math definitions math.vectors assocs refs
|
||||
ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
|
||||
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
|
||||
ui.gadgets.editors ;
|
||||
IN: ui.gadgets.slots
|
||||
|
||||
TUPLE: update-object ;
|
||||
|
|
@ -88,7 +88,7 @@ slot-editor "toolbar" f {
|
|||
{ T{ key-down f f "ESC" } close }
|
||||
} define-command-map
|
||||
|
||||
TUPLE: editable-slot printer ref ;
|
||||
TUPLE: editable-slot < track printer ref ;
|
||||
|
||||
: <edit-button> ( -- gadget )
|
||||
"..."
|
||||
|
|
@ -118,8 +118,7 @@ TUPLE: editable-slot printer ref ;
|
|||
} set-gestures
|
||||
|
||||
: <editable-slot> ( gadget ref -- editable-slot )
|
||||
editable-slot new
|
||||
{ 1 0 } <track> over set-gadget-delegate
|
||||
[ drop <gadget> ] over set-editable-slot-printer
|
||||
[ set-editable-slot-ref ] keep
|
||||
{ 1 0 } editable-slot new-track
|
||||
swap >>ref
|
||||
[ drop <gadget> ] >>printer
|
||||
[ display-slot ] keep ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models models.delay models.filter
|
||||
sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets ui kernel calendar ;
|
||||
ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
|
||||
IN: ui.gadgets.status-bar
|
||||
|
||||
: <status-bar> ( model -- gadget )
|
||||
|
|
@ -11,7 +11,9 @@ IN: ui.gadgets.status-bar
|
|||
t >>root? ;
|
||||
|
||||
: open-status-window ( gadget title -- )
|
||||
>r [
|
||||
1 track,
|
||||
f <model> dup <status-bar> f track,
|
||||
] { 0 1 } make-track r> rot <world> open-world-window ;
|
||||
f <model> [ <world> ] keep
|
||||
<status-bar> over f track-add
|
||||
open-world-window ;
|
||||
|
||||
: show-summary ( object gadget -- )
|
||||
>r [ summary ] [ "" ] if* r> show-status ;
|
||||
|
|
|
|||
|
|
@ -1,19 +1,23 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.gadgets ui.gadgets.packs io kernel math namespaces
|
||||
sequences words math.vectors ;
|
||||
USING: accessors io kernel math namespaces
|
||||
sequences words math.vectors ui.gadgets ui.gadgets.packs ;
|
||||
IN: ui.gadgets.tracks
|
||||
|
||||
TUPLE: track sizes ;
|
||||
TUPLE: track < pack sizes ;
|
||||
|
||||
: normalized-sizes ( track -- seq )
|
||||
track-sizes
|
||||
[ sift sum ] keep [ dup [ over / ] when ] map nip ;
|
||||
|
||||
: new-track ( orientation -- track )
|
||||
new-gadget
|
||||
swap >>orientation
|
||||
V{ } clone >>sizes
|
||||
1 >>fill ; inline
|
||||
|
||||
: <track> ( orientation -- track )
|
||||
<pack> V{ } clone
|
||||
{ set-delegate set-track-sizes } track construct
|
||||
1 over set-pack-fill ;
|
||||
track new-track ;
|
||||
|
||||
: alloted-dim ( track -- dim )
|
||||
dup gadget-children swap track-sizes { 0 0 }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: ui.gadgets.viewports
|
||||
USING: arrays ui.gadgets ui.gadgets.borders
|
||||
USING: accessors arrays ui.gadgets ui.gadgets.borders
|
||||
kernel math namespaces sequences models math.vectors ;
|
||||
|
||||
: viewport-gap { 3 3 } ; inline
|
||||
|
||||
TUPLE: viewport ;
|
||||
TUPLE: viewport < gadget ;
|
||||
|
||||
: find-viewport ( gadget -- viewport )
|
||||
[ viewport? ] find-parent ;
|
||||
|
|
@ -15,8 +15,9 @@ TUPLE: viewport ;
|
|||
gadget-child pref-dim viewport-gap 2 v*n v+ ;
|
||||
|
||||
: <viewport> ( content model -- viewport )
|
||||
<gadget> viewport construct-control
|
||||
t over set-gadget-clipped?
|
||||
viewport new-gadget
|
||||
swap >>model
|
||||
t >>clipped?
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
M: viewport layout*
|
||||
|
|
|
|||
|
|
@ -29,15 +29,15 @@ HELP: focus-path
|
|||
HELP: world
|
||||
{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds delegate to " { $link gadget } " instances and have the following slots:"
|
||||
{ $list
|
||||
{ { $link world-active? } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
|
||||
{ { $link world-glass } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
|
||||
{ { $link world-title } " - a string to be displayed in the title bar of the native window containing the world." }
|
||||
{ { $link world-status } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
|
||||
{ { $link world-focus } " - the current owner of the keyboard focus in the world." }
|
||||
{ { $link world-focused? } " - a boolean indicating if the native window containing the world has keyboard focus." }
|
||||
{ { $link world-fonts } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
|
||||
{ { $link world-handle } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
|
||||
{ { $link world-loc } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
|
||||
{ { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
|
||||
{ { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
|
||||
{ { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
|
||||
{ { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
|
||||
{ { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
|
||||
{ { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
|
||||
{ { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
|
||||
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
|
||||
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ namespaces models kernel ;
|
|||
<gadget> "g1" set
|
||||
|
||||
: <test-world> ( gadget -- world )
|
||||
[ gadget, ] make-pile "Hi" f <world> ;
|
||||
"Hi" f <world> ;
|
||||
|
||||
[ ] [
|
||||
"g1" get <test-world> "w" set
|
||||
|
|
@ -46,15 +46,15 @@ namespaces models kernel ;
|
|||
|
||||
[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
|
||||
|
||||
TUPLE: focusing ;
|
||||
TUPLE: focusing < gadget ;
|
||||
|
||||
: <focusing>
|
||||
focusing construct-gadget ;
|
||||
focusing new-gadget ;
|
||||
|
||||
TUPLE: focus-test ;
|
||||
TUPLE: focus-test < gadget ;
|
||||
|
||||
: <focus-test>
|
||||
focus-test construct-gadget
|
||||
focus-test new-gadget
|
||||
<focusing> over add-gadget ;
|
||||
|
||||
M: focus-test focusable-child* gadget-child ;
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs continuations kernel math models
|
||||
USING: accessors arrays assocs continuations kernel math models
|
||||
namespaces opengl sequences io combinators math.vectors
|
||||
ui.gadgets ui.gestures ui.render ui.backend summary
|
||||
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
||||
debugger ;
|
||||
IN: ui.gadgets.worlds
|
||||
|
||||
TUPLE: world < identity-tuple
|
||||
TUPLE: world < track
|
||||
active? focused?
|
||||
glass
|
||||
title status
|
||||
fonts handle
|
||||
loc ;
|
||||
window-loc ;
|
||||
|
||||
: find-world ( gadget -- world ) [ world? ] find-parent ;
|
||||
|
||||
|
|
@ -20,9 +20,6 @@ M: f world-status ;
|
|||
: show-status ( string/f gadget -- )
|
||||
find-world world-status [ set-model ] [ drop ] if* ;
|
||||
|
||||
: show-summary ( object gadget -- )
|
||||
>r [ summary ] [ "" ] if* r> show-status ;
|
||||
|
||||
: hide-status ( gadget -- ) f swap show-status ;
|
||||
|
||||
: (request-focus) ( child world ? -- )
|
||||
|
|
@ -36,21 +33,18 @@ M: world request-focus-on ( child gadget -- )
|
|||
[ 2drop ] [ dup world-focused? (request-focus) ] if ;
|
||||
|
||||
: <world> ( gadget title status -- world )
|
||||
t H{ } clone { 0 0 } {
|
||||
set-gadget-delegate
|
||||
set-world-title
|
||||
set-world-status
|
||||
set-world-active?
|
||||
set-world-fonts
|
||||
set-world-loc
|
||||
} world construct
|
||||
t over set-gadget-root?
|
||||
{ 0 1 } world new-track
|
||||
t >>root?
|
||||
t >>active?
|
||||
H{ } clone >>fonts
|
||||
{ 0 0 } >>window-loc
|
||||
swap >>status
|
||||
swap >>title
|
||||
[ 1 track-add ] keep
|
||||
dup request-focus ;
|
||||
|
||||
M: world hashcode* drop world hashcode* ;
|
||||
|
||||
M: world layout*
|
||||
dup delegate layout*
|
||||
dup call-next-method
|
||||
dup world-glass [
|
||||
>r dup rect-dim r> set-layout-dim
|
||||
] when* drop ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ui.gadgets kernel ;
|
||||
IN: ui.gadgets.wrappers
|
||||
|
||||
TUPLE: wrapper < gadget ;
|
||||
|
||||
: new-wrapper ( child class -- wrapper )
|
||||
new-gadget
|
||||
[ add-gadget ] keep ; inline
|
||||
|
||||
: <wrapper> ( child -- border )
|
||||
wrapper new-wrapper ;
|
||||
|
||||
M: wrapper pref-dim*
|
||||
gadget-child pref-dim ;
|
||||
|
||||
M: wrapper layout*
|
||||
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
|
||||
|
||||
M: wrapper focusable-child*
|
||||
gadget-child ;
|
||||
|
|
@ -11,7 +11,7 @@ IN: ui.gestures
|
|||
GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
|
||||
|
||||
: default-gesture-handler ( gadget gesture delegate -- ? )
|
||||
class "gestures" word-prop at dup
|
||||
class superclasses [ "gestures" word-prop ] map assoc-stack dup
|
||||
[ call f ] [ 2drop t ] if ;
|
||||
|
||||
M: object handle-gesture* default-gesture-handler ;
|
||||
|
|
|
|||
|
|
@ -17,11 +17,9 @@ HELP: gadget
|
|||
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
|
||||
{ { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
|
||||
}
|
||||
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
|
||||
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
|
||||
{ $notes
|
||||
"Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." }
|
||||
{ $warning
|
||||
"When setting a tuple's delegate to be a gadget, " { $link set-gadget-delegate } " should be used instead of " { $link set-delegate } "." } ;
|
||||
"Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
|
||||
|
||||
HELP: clip
|
||||
{ $var-description "The current clipping rectangle." } ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@ IN: ui.tools.interactor
|
|||
|
||||
! If waiting is t, we're waiting for user input, and invoking
|
||||
! evaluate-input resumes the thread.
|
||||
TUPLE: interactor output history flag mailbox thread waiting help ;
|
||||
TUPLE: interactor < source-editor
|
||||
output history flag mailbox thread waiting help ;
|
||||
|
||||
: register-self ( interactor -- )
|
||||
<mailbox> >>mailbox
|
||||
|
|
@ -39,18 +40,17 @@ TUPLE: interactor output history flag mailbox thread waiting help ;
|
|||
editor-caret 1/3 seconds <delay> ;
|
||||
|
||||
: <interactor> ( output -- gadget )
|
||||
<source-editor>
|
||||
interactor construct-editor
|
||||
interactor new-editor
|
||||
V{ } clone >>history
|
||||
<flag> >>flag
|
||||
dup <help-model> >>help
|
||||
swap >>output ;
|
||||
|
||||
M: interactor graft*
|
||||
[ delegate graft* ] [ dup help>> add-connection ] bi ;
|
||||
[ call-next-method ] [ dup help>> add-connection ] bi ;
|
||||
|
||||
M: interactor ungraft*
|
||||
[ dup help>> remove-connection ] [ delegate ungraft ] bi ;
|
||||
[ dup help>> remove-connection ] [ call-next-method ] bi ;
|
||||
|
||||
: word-at-loc ( loc interactor -- word )
|
||||
over [
|
||||
|
|
@ -64,7 +64,7 @@ M: interactor model-changed
|
|||
2dup help>> eq? [
|
||||
swap model-value over word-at-loc swap show-summary
|
||||
] [
|
||||
delegate model-changed
|
||||
call-next-method
|
||||
] if ;
|
||||
|
||||
: write-input ( string input -- )
|
||||
|
|
@ -180,7 +180,7 @@ M: interactor stream-read-quot
|
|||
} cond ;
|
||||
|
||||
M: interactor pref-dim*
|
||||
[ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
|
||||
[ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
|
||||
vmax ;
|
||||
|
||||
interactor "interactor" f {
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: listener-gadget input output stack ;
|
|||
|
||||
: listener-input, ( -- )
|
||||
g <listener-input> g-> set-listener-gadget-input
|
||||
<limited-scroller> { 0 100 } >>dim
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget> f track, ;
|
||||
|
||||
: welcome. ( -- )
|
||||
|
|
|
|||
|
|
@ -34,10 +34,10 @@ M: live-search handle-gesture* ( gadget gesture delegate -- ? )
|
|||
: find-search-list ( gadget -- list )
|
||||
find-live-search live-search-list ;
|
||||
|
||||
TUPLE: search-field ;
|
||||
TUPLE: search-field < editor ;
|
||||
|
||||
: <search-field> ( -- gadget )
|
||||
<editor> search-field construct-editor ;
|
||||
search-field new-editor ;
|
||||
|
||||
search-field H{
|
||||
{ T{ key-down f f "UP" } [ find-search-list select-previous ] }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs debugger ui.tools.workspace
|
||||
USING: accessors arrays assocs debugger ui.tools.workspace
|
||||
ui.tools.operations ui.tools.traceback ui.tools.browser
|
||||
ui.tools.inspector ui.tools.listener ui.tools.profiler
|
||||
ui.tools.operations inspector io kernel math models namespaces
|
||||
|
|
@ -27,7 +27,9 @@ IN: ui.tools
|
|||
] { } make g gadget-model <book> ;
|
||||
|
||||
: <workspace> ( -- workspace )
|
||||
0 <model> { 0 1 } <track> workspace construct-control [
|
||||
{ 0 1 } workspace new-track
|
||||
0 <model> >>model
|
||||
[
|
||||
[
|
||||
<listener-gadget> g set-workspace-listener
|
||||
<workspace-book> g set-workspace-book
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations kernel models namespaces prettyprint ui
|
||||
ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
USING: accessors continuations kernel models namespaces
|
||||
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
|
||||
ui.gadgets.status-bar ui.gadgets.scrollers
|
||||
ui.gestures sequences hashtables inspector ;
|
||||
ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
|
||||
hashtables inspector ;
|
||||
IN: ui.tools.traceback
|
||||
|
||||
: <callstack-display> ( model -- gadget )
|
||||
|
|
@ -19,12 +19,14 @@ IN: ui.tools.traceback
|
|||
[ [ continuation-retain stack. ] when* ]
|
||||
t "Retain stack" <labelled-pane> ;
|
||||
|
||||
TUPLE: traceback-gadget ;
|
||||
TUPLE: traceback-gadget < track ;
|
||||
|
||||
M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||
|
||||
: <traceback-gadget> ( model -- gadget )
|
||||
{ 0 1 } <track> traceback-gadget construct-control [
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
[
|
||||
[
|
||||
[
|
||||
g gadget-model <datastack-display> 1/2 track,
|
||||
|
|
@ -39,14 +41,8 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
[ [ continuation-name namestack. ] when* ]
|
||||
<pane-control> ;
|
||||
|
||||
TUPLE: variables-gadget ;
|
||||
|
||||
: <variables-gadget> ( model -- gadget )
|
||||
<namestack-display> <scroller>
|
||||
variables-gadget new
|
||||
[ set-gadget-delegate ] keep ;
|
||||
|
||||
M: variables-gadget pref-dim* drop { 400 400 } ;
|
||||
<namestack-display> { 400 400 } <limited-scroller> ;
|
||||
|
||||
: variables ( traceback -- )
|
||||
gadget-model <variables-gadget>
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
|
|||
ui.commands ui.gestures assocs arrays namespaces accessors ;
|
||||
IN: ui.tools.workspace
|
||||
|
||||
TUPLE: workspace book listener popup ;
|
||||
TUPLE: workspace < track book listener popup ;
|
||||
|
||||
: find-workspace ( gadget -- workspace )
|
||||
[ workspace? ] find-parent ;
|
||||
|
|
@ -52,7 +52,7 @@ M: gadget tool-scroller drop f ;
|
|||
: help-window ( topic -- )
|
||||
[
|
||||
<pane> [ [ help ] with-pane ] keep
|
||||
<limited-scroller> { 550 700 } >>dim
|
||||
{ 550 700 } <limited-scroller>
|
||||
] keep
|
||||
article-title open-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -359,10 +359,8 @@ ARTICLE: "new-gadgets" "Implementing new gadgets"
|
|||
$nl
|
||||
"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
|
||||
{ $subsection <gadget> }
|
||||
"You can construct a new tuple which delegates to a bare gadget:"
|
||||
{ $subsection construct-gadget }
|
||||
"You can also delegate a tuple to an existing gadget:"
|
||||
{ $subsection set-gadget-delegate }
|
||||
"New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
|
||||
{ $subsection new-gadget }
|
||||
"Further topics:"
|
||||
{ $subsection "ui-gestures" }
|
||||
{ $subsection "ui-paint" }
|
||||
|
|
|
|||
|
|
@ -175,7 +175,6 @@ SYMBOL: ui-thread
|
|||
dup pref-dim over set-gadget-dim dup relayout graft ;
|
||||
|
||||
: open-window ( gadget title -- )
|
||||
>r [ 1 track, ] { 0 1 } make-track r>
|
||||
f <world> open-world-window ;
|
||||
|
||||
: set-fullscreen? ( ? gadget -- )
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
|||
: handle-wm-move ( hWnd uMsg wParam lParam -- )
|
||||
2nip
|
||||
[ lo-word ] keep hi-word 2array
|
||||
swap window set-world-loc ;
|
||||
swap window (>>window-loc) ;
|
||||
|
||||
: wm-keydown-codes ( -- key )
|
||||
H{
|
||||
|
|
@ -420,7 +420,7 @@ M: windows-ui-backend do-events
|
|||
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
|
||||
|
||||
: make-RECT ( world -- RECT )
|
||||
dup world-loc { 40 40 } vmax dup rot rect-dim v+
|
||||
dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
|
||||
"RECT" <c-object>
|
||||
over first over set-RECT-right
|
||||
swap second over set-RECT-bottom
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ C: <x11-handle> x11-handle
|
|||
M: world expose-event nip relayout ;
|
||||
|
||||
M: world configure-event
|
||||
over configured-loc over set-world-loc
|
||||
over configured-loc over (>>window-loc)
|
||||
swap configured-dim over set-gadget-dim
|
||||
! In case dimensions didn't change
|
||||
relayout-1 ;
|
||||
|
|
@ -170,7 +170,7 @@ M: world client-event
|
|||
swap close-box? [ ungraft ] [ drop ] if ;
|
||||
|
||||
: gadget-window ( world -- )
|
||||
dup world-loc over rect-dim glx-window
|
||||
dup window-loc>> over rect-dim glx-window
|
||||
over "Factor" create-xic <x11-handle>
|
||||
2dup x11-handle-window register-window
|
||||
swap set-world-handle ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue