From 57893118e066536decc093101714a1538e45e551 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Nov 2007 03:01:45 -0500 Subject: [PATCH] Clean up model-changed; no need for auxilliary tuples in editor and interactor --- extra/color-picker/color-picker.factor | 2 +- extra/models/models-tests.factor | 2 +- extra/models/models.factor | 52 +++++++++++------ extra/ui/gadgets/books/books-tests.factor | 4 ++ extra/ui/gadgets/books/books.factor | 7 +-- extra/ui/gadgets/buttons/buttons.factor | 4 +- extra/ui/gadgets/editors/editors-docs.factor | 3 - extra/ui/gadgets/editors/editors-tests.factor | 40 ++++++------- extra/ui/gadgets/editors/editors.factor | 55 +++++++++--------- extra/ui/gadgets/gadgets.factor | 4 +- .../ui/gadgets/incremental/incremental.factor | 15 +++-- extra/ui/gadgets/labels/labels.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 1 + extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 1 + .../tools/interactor/interactor-tests.factor | 4 ++ extra/ui/tools/interactor/interactor.factor | 24 ++++---- extra/ui/tools/tools.factor | 1 + extra/ui/tools/walker/walker-tests.factor | 57 ++++++++++--------- extra/ui/tools/walker/walker.factor | 5 +- 22 files changed, 158 insertions(+), 131 deletions(-) mode change 100644 => 100755 extra/models/models-tests.factor mode change 100644 => 100755 extra/models/models.factor create mode 100755 extra/ui/gadgets/books/books-tests.factor create mode 100755 extra/ui/tools/interactor/interactor-tests.factor mode change 100644 => 100755 extra/ui/tools/walker/walker-tests.factor diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index d8a18a6a8e..647c83d667 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -18,7 +18,7 @@ TUPLE: color-preview ; { 100 100 } over set-rect-dim ; M: color-preview model-changed - dup control-value over set-gadget-interior relayout-1 ; + swap model-value over set-gadget-interior relayout-1 ; : ( model -- model ) [ [ 256 /f ] map 1 add ] ; diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor old mode 100644 new mode 100755 index e47e1a66c3..ea615d2f9a --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -6,7 +6,7 @@ TUPLE: model-tester hit? ; : model-tester construct-empty ; -M: model-tester model-changed t swap set-model-tester-hit? ; +M: model-tester model-changed nip t swap set-model-tester-hit? ; [ T{ model-tester f t } ] [ diff --git a/extra/models/models.factor b/extra/models/models.factor old mode 100644 new mode 100755 index d76269eaf0..9c9ddd13e0 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -3,10 +3,10 @@ USING: generic kernel math sequences timers arrays assocs ; IN: models -TUPLE: model value connections dependencies ref ; +TUPLE: model value connections dependencies ref locked? ; : ( value -- model ) - V{ } clone V{ } clone 0 model construct-boa ; + V{ } clone V{ } clone 0 f model construct-boa ; M: model equal? 2drop f ; @@ -49,7 +49,7 @@ DEFER: remove-connection drop ] if ; -GENERIC: model-changed ( observer -- ) +GENERIC: model-changed ( model observer -- ) : add-connection ( observer model -- ) dup model-connections empty? [ dup activate-model ] when @@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- ) dup model-connections empty? [ dup deactivate-model ] when drop ; -GENERIC: set-model ( value model -- ) +: with-locked-model ( model quot -- ) + swap + t over set-model-locked? + slip + f swap set-model-locked? ; inline -M: model set-model - [ set-model-value ] keep - model-connections [ model-changed ] each ; +GENERIC: update-model ( model -- ) + +M: model update-model drop ; + +: set-model ( value model -- ) + dup model-locked? [ + 2drop + ] [ + dup [ + [ set-model-value ] keep + [ update-model ] keep + dup model-connections [ model-changed ] curry* each + ] with-locked-model + ] if ; : ((change-model)) ( model quot -- newvalue model ) over >r >r model-value r> call r> ; inline @@ -87,10 +102,10 @@ TUPLE: filter model quot ; [ add-dependency ] keep ; M: filter model-changed - dup filter-model model-value over filter-quot call + swap model-value over filter-quot call swap set-model ; -M: filter model-activated model-changed ; +M: filter model-activated dup filter-model swap model-changed ; TUPLE: compose ; @@ -103,11 +118,13 @@ TUPLE: compose ; : set-composed-value >r model-dependencies r> 2each ; inline M: compose model-changed + nip dup [ model-value ] composed-value swap delegate set-model ; -M: compose model-activated model-changed ; +M: compose model-activated dup model-changed ; -M: compose set-model [ set-model ] set-composed-value ; +M: compose update-model + dup model-value swap [ set-model ] set-composed-value ; TUPLE: mapping assoc ; @@ -117,13 +134,15 @@ TUPLE: mapping assoc ; tuck set-mapping-assoc ; M: mapping model-changed + nip dup mapping-assoc [ model-value ] assoc-map swap delegate set-model ; -M: mapping model-activated model-changed ; +M: mapping model-activated dup model-changed ; -M: mapping set-model - mapping-assoc [ swapd at set-model ] curry assoc-each ; +M: mapping update-model + dup model-value swap mapping-assoc + [ swapd at set-model ] curry assoc-each ; TUPLE: history back forward ; @@ -161,10 +180,9 @@ TUPLE: delay model timeout ; f delay construct-model [ set-delay-timeout ] keep [ set-delay-model ] 2keep - [ add-dependency ] keep - dup update-delay-model ; + [ add-dependency ] keep ; -M: delay model-changed 0 over delay-timeout add-timer ; +M: delay model-changed nip 0 over delay-timeout add-timer ; M: delay model-activated update-delay-model ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor new file mode 100755 index 0000000000..a7226299ab --- /dev/null +++ b/extra/ui/gadgets/books/books-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: tools.test.inference ui.gadgets.books ; + +{ 2 1 } [ ] unit-test-effect diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index f9e3262e8e..95b1eed89d 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -10,15 +10,14 @@ TUPLE: book ; : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ; -M: book model-changed ( book -- ) +M: book model-changed + nip dup hide-all dup current-page show-gadget relayout ; : ( pages model -- book ) - book construct-control - [ add-gadgets ] keep - [ model-changed ] keep ; + book construct-control [ add-gadgets ] keep ; M: book pref-dim* gadget-children pref-dims max-dim ; diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 6c10a11d3c..a196173852 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -141,7 +141,7 @@ TUPLE: checkbox ; dup checkbox-theme ; M: checkbox model-changed - dup control-value over set-button-selected? relayout-1 ; + swap model-value over set-button-selected? relayout-1 ; TUPLE: radio-paint color ; @@ -178,7 +178,7 @@ TUPLE: radio-control value ; tuck set-radio-control-value ; inline M: radio-control model-changed - dup control-value + swap model-value over radio-control-value = over set-button-selected? relayout-1 ; diff --git a/extra/ui/gadgets/editors/editors-docs.factor b/extra/ui/gadgets/editors/editors-docs.factor index 18e4e62ccc..42d300d330 100755 --- a/extra/ui/gadgets/editors/editors-docs.factor +++ b/extra/ui/gadgets/editors/editors-docs.factor @@ -16,9 +16,6 @@ $nl { { $link editor-focused? } " - a boolean." } } } ; -HELP: loc-monitor -{ $class-description "Instances of this class are used internally by " { $link editor } " controls to redraw the editor when the caret or mark is moved by calling " { $link set-model } " on " { $link editor-caret } " or " { $link editor-mark } "." } ; - HELP: { $values { "editor" "a new " { $link editor } } } { $description "Creates a new " { $link editor } " with an empty document." } ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index b7ddc8359c..fa4351b1b8 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -1,41 +1,41 @@ USING: ui.gadgets.editors tools.test kernel io io.streams.plain io.streams.string definitions namespaces ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures -tools.test.inference ; +tools.test.inference tools.test.ui ; [ t ] [ "editor" set - "editor" get graft* - "editor" get [ \ = see ] with-stream - "editor" get editor-string [ \ = see ] string-out = - "editor" get ungraft* + "editor" get [ + "editor" get [ \ = see ] with-stream + "editor" get editor-string [ \ = see ] string-out = + ] with-grafted-gadget ] unit-test [ "foo bar" ] [ "editor" set - "editor" get graft* - "foo bar" "editor" get set-editor-string - "editor" get T{ one-line-elt } select-elt - "editor" get gadget-selection - "editor" get ungraft* + "editor" get [ + "foo bar" "editor" get set-editor-string + "editor" get T{ one-line-elt } select-elt + "editor" get gadget-selection + ] with-grafted-gadget ] unit-test [ "baz quux" ] [ "editor" set - "editor" get graft* - "foo bar\nbaz quux" "editor" get set-editor-string - "editor" get T{ one-line-elt } select-elt - "editor" get gadget-selection - "editor" get ungraft* + "editor" get [ + "foo bar\nbaz quux" "editor" get set-editor-string + "editor" get T{ one-line-elt } select-elt + "editor" get gadget-selection + ] with-grafted-gadget ] unit-test [ ] [ "editor" set - "editor" get graft* - "foo bar\nbaz quux" "editor" get set-editor-string - 4 hand-click# set - "editor" get position-caret - "editor" get ungraft* + "editor" get [ + "foo bar\nbaz quux" "editor" get set-editor-string + 4 hand-click# set + "editor" get position-caret + ] with-grafted-gadget ] unit-test { 0 1 } [ ] unit-test-effect diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 4250744ea5..65758ab54c 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -13,15 +13,11 @@ font color caret-color selection-color caret mark focused? ; -TUPLE: loc-monitor editor ; - -: ( editor -- loc ) - loc-monitor construct-boa - { 0 0 } [ add-connection ] keep ; +: ( -- loc ) { 0 0 } ; : init-editor-locs ( editor -- ) - dup over set-editor-caret - dup swap set-editor-mark ; + over set-editor-caret + swap set-editor-mark ; : editor-theme ( editor -- ) black over set-editor-color @@ -47,10 +43,14 @@ TUPLE: source-editor ; : source-editor construct-editor ; : activate-editor-model ( editor model -- ) - dup activate-model swap gadget-model add-loc ; + 2dup add-connection + dup activate-model + swap gadget-model add-loc ; : deactivate-editor-model ( editor model -- ) - dup deactivate-model swap gadget-model remove-loc ; + 2dup remove-connection + dup deactivate-model + swap gadget-model remove-loc ; M: editor graft* dup @@ -62,12 +62,6 @@ M: editor ungraft* dup editor-caret deactivate-editor-model dup editor-mark deactivate-editor-model ; -M: editor model-changed - dup gadget-model - over editor-caret [ over validate-loc ] (change-model) - over editor-mark [ over validate-loc ] (change-model) - drop editor-self relayout ; - : editor-caret* ( editor -- loc ) editor-caret model-value ; : editor-mark* ( editor -- loc ) editor-mark model-value ; @@ -133,10 +127,6 @@ M: editor model-changed over scroll>rect ] when drop ; -M: loc-monitor model-changed - loc-monitor-editor editor-self - dup relayout-1 scroll>caret ; - : draw-caret ( -- ) editor get editor-focused? [ editor get @@ -218,6 +208,22 @@ M: editor draw-gadget* M: editor pref-dim* dup editor-font* swap control-value text-dim ; +: contents-changed + editor-self swap + over editor-caret [ over validate-loc ] (change-model) + over editor-mark [ over validate-loc ] (change-model) + drop relayout ; + +: caret/mark-changed + nip editor-self dup relayout-1 scroll>caret ; + +M: editor model-changed + { + { [ 2dup gadget-model eq? ] [ contents-changed ] } + { [ 2dup editor-caret eq? ] [ caret/mark-changed ] } + { [ 2dup editor-mark eq? ] [ caret/mark-changed ] } + } cond ; + M: editor gadget-selection? selection-start/end = not ; @@ -420,16 +426,6 @@ editor "selection" f { { T{ key-down f { S+ C+ } "END" } select-end-of-document } } define-command-map -! Editors support the stream output protocol -M: editor stream-write1 >r 1string r> stream-write ; - -M: editor stream-write - editor-self dup end-of-document user-input ; - -M: editor stream-close drop ; - -M: editor stream-flush drop ; - ! Fields are like editors except they edit an external model TUPLE: field model editor ; @@ -452,5 +448,6 @@ M: field ungraft* dup field-editor gadget-model remove-connection ; M: field model-changed + nip dup field-editor editor-string swap field-model set-model ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index fc28d16fdc..9929cece29 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -50,7 +50,7 @@ M: gadget equal? 2drop f ; M: gadget hashcode* drop gadget hashcode* ; -M: gadget model-changed drop ; +M: gadget model-changed 2drop ; : gadget-child ( gadget -- child ) gadget-children first ; @@ -71,7 +71,7 @@ M: gadget model-changed drop ; : activate-control ( gadget -- ) dup gadget-model dup [ 2dup add-connection ] when drop - model-changed ; + dup gadget-model swap model-changed ; : deactivate-control ( gadget -- ) dup gadget-model dup [ 2dup remove-connection ] when 2drop ; diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 2cd2c3d13c..a5c7431d36 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -11,14 +11,15 @@ IN: ui.gadgets.incremental ! pack-gap. ! The cursor is the current size of the incremental pack. -! New gadgets are added at cursor-cursor*gadget-orientation. +! New gadgets are added at +! incremental-cursor gadget-orientation v* TUPLE: incremental cursor ; : ( pack -- incremental ) - incremental construct-empty - [ set-gadget-delegate ] keep - dup delegate pref-dim over set-incremental-cursor ; + dup pref-dim + { set-gadget-delegate set-incremental-cursor } + incremental construct ; M: incremental pref-dim* dup gadget-layout-state [ @@ -39,7 +40,8 @@ M: incremental pref-dim* swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup forget-pref-dim dup pref-dim over set-rect-dim layout ; + dup forget-pref-dim dup pref-dim over set-rect-dim + layout ; : add-incremental ( gadget incremental -- ) not-in-layout @@ -52,6 +54,7 @@ M: incremental pref-dim* : clear-incremental ( incremental -- ) not-in-layout - dup (clear-gadget) dup forget-pref-dim + dup (clear-gadget) + dup forget-pref-dim { 0 0 } over set-incremental-cursor gadget-parent [ relayout ] when* ; diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor index 4e1a4712ba..2ac0240ed1 100755 --- a/extra/ui/gadgets/labels/labels.factor +++ b/extra/ui/gadgets/labels/labels.factor @@ -40,7 +40,7 @@ M: label gadget-text* label-string % ; TUPLE: label-control ; M: label-control model-changed - dup control-value over set-label-text relayout ; + swap model-value over set-label-text relayout ; : ( model -- gadget ) ""