Merge branch 'master' of git://factorcode.org/git/factor

core/kernel/kernel.factor

@@ -210,3 +210,6 @@ GENERIC# set-slots 1 ( ... tuple slots -- )
 
 : construct ( ... slots class -- tuple )
     new [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+    >r { set-delegate } r> construct ; inline

extra/models/compose/compose.factor

@@ -1,19 +1,24 @@
-USING: models kernel sequences ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models kernel sequences ;
 IN: models.compose
 
-TUPLE: compose ;
+TUPLE: compose < model ;
+
+: new-compose ( models class -- compose )
+    f swap new-model
+        swap clone >>dependencies ; inline
 
 : <compose> ( models -- compose )
-    f compose construct-model
+    compose new-compose ;
-    swap clone over set-model-dependencies ;
 
-: composed-value >r model-dependencies r> map ; inline
+: composed-value [ dependencies>> ] dip map ; inline
 
-: set-composed-value >r model-dependencies r> 2each ; inline
+: set-composed-value [ dependencies>> ] dip 2each ; inline
 
 M: compose model-changed
     nip
-    dup [ model-value ] composed-value swap delegate set-model ;
+    [ [ model-value ] composed-value ] keep set-model ;
 
 M: compose model-activated dup model-changed ;
 

extra/models/delay/delay.factor

@@ -1,24 +1,26 @@
-USING: kernel models alarms ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models alarms ;
 IN: models.delay
 
-TUPLE: delay model timeout alarm ;
+TUPLE: delay < model model timeout alarm ;
 
 : update-delay-model ( delay -- )
-    dup delay-model model-value swap set-model ;
+    [ delay-model model-value ] keep set-model ;
 
 : <delay> ( model timeout -- delay )
-    f delay construct-model
+    f delay new-model
-    [ set-delay-timeout ] keep
+        swap >>timeout
-    [ set-delay-model ] 2keep
+        over >>model
         [ add-dependency ] keep ;
 
 : cancel-delay ( delay -- )
     delay-alarm [ cancel-alarm ] when* ;
 
 : start-delay ( delay -- )
-    dup [ f over set-delay-alarm update-delay-model ] curry
+    dup
-    over delay-timeout later
+    [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later
-    swap set-delay-alarm ;
+    >>alarm drop ;
 
 M: delay model-changed nip dup cancel-delay start-delay ;
 

extra/models/filter/filter.factor

@@ -1,16 +1,17 @@
-USING: models kernel ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models kernel ;
 IN: models.filter
 
-TUPLE: filter model quot ;
+TUPLE: filter < model model quot ;
 
 : <filter> ( model quot -- filter )
-    f filter construct-model
+    f filter new-model
-    [ set-filter-quot ] keep
+        swap >>quot
-    [ set-filter-model ] 2keep
+        over >>model
         [ add-dependency ] keep ;
 
 M: filter model-changed
-    swap model-value over filter-quot call
+    [ [ value>> ] [ quot>> ] bi* call ] [ nip ] 2bi set-model ;
-    swap set-model ;
 
-M: filter model-activated dup filter-model swap model-changed ;
+M: filter model-activated [ model>> ] keep model-changed ;

extra/models/history/history.factor

@@ -1,14 +1,17 @@
-USING: kernel models sequences ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models sequences ;
 IN: models.history
 
-TUPLE: history back forward ;
+TUPLE: history < model back forward ;
 
-: reset-history ( history -- )
+: reset-history ( history -- history )
-    V{ } clone over set-history-back
+    V{ } clone >>back
-    V{ } clone swap set-history-forward ;
+    V{ } clone >>forward ; inline
 
 : <history> ( value -- history )
-    history construct-model dup reset-history ;
+    history new-model
+        reset-history ;
 
 : (add-history) ( history to -- )
     swap model-value dup [ swap push ] [ 2drop ] if ;

extra/models/mapping/mapping.factor

@@ -1,20 +1,21 @@
-USING: models kernel assocs ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models kernel assocs ;
 IN: models.mapping
 
-TUPLE: mapping assoc ;
+TUPLE: mapping < model assoc ;
 
 : <mapping> ( models -- mapping )
-    f mapping construct-model
+    f mapping new-model
-    over values over set-model-dependencies
+        over values >>dependencies
-    tuck set-mapping-assoc ;
+        swap >>assoc ;
 
 M: mapping model-changed
-    nip
+    nip [ assoc>> [ value>> ] assoc-map ] keep set-model ;
-    dup mapping-assoc [ model-value ] assoc-map
-    swap delegate set-model ;
 
-M: mapping model-activated dup model-changed ;
+M: mapping model-activated
+    dup model-changed ;
 
 M: mapping update-model
-    dup model-value swap mapping-assoc
+    [ value>> ] [ assoc>> ] bi
     [ swapd at set-model ] curry assoc-each ;

extra/models/models.factor

@@ -100,9 +100,6 @@ M: model update-model drop ;
 : (change-model) ( model quot -- )
     ((change-model)) set-model-value ; inline
 
-: construct-model ( value class -- instance )
-    >r <model> { set-delegate } r> construct ; inline
-
 GENERIC: range-value ( model -- value )
 GENERIC: range-page-value ( model -- value )
 GENERIC: range-min-value ( model -- value )

extra/models/range/range.factor

@@ -1,32 +1,33 @@
-USING: kernel models arrays sequences math math.order
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models arrays sequences math math.order
 models.compose ;
 IN: models.range
 
-TUPLE: range ;
+TUPLE: range < compose ;
 
 : <range> ( value min max page -- range )
-    4array [ <model> ] map <compose>
+    4array [ <model> ] map range new-compose ;
-    { set-delegate } range construct ;
 
-: range-model ( range -- model ) model-dependencies first ;
+: range-model ( range -- model ) dependencies>> first ;
-: range-page ( range -- model ) model-dependencies second ;
+: range-page ( range -- model ) dependencies>> second ;
-: range-min ( range -- model ) model-dependencies third ;
+: range-min ( range -- model ) dependencies>> third ;
-: range-max ( range -- model ) model-dependencies fourth ;
+: range-max ( range -- model ) dependencies>> fourth ;
 
 M: range range-value
-    [ range-model model-value ] keep clamp-value ;
+    [ range-model value>> ] keep clamp-value ;
 
-M: range range-page-value range-page model-value ;
+M: range range-page-value range-page value>> ;
 
-M: range range-min-value range-min model-value ;
+M: range range-min-value range-min value>> ;
 
-M: range range-max-value range-max model-value ;
+M: range range-max-value range-max value>> ;
 
 M: range range-max-value*
-    dup range-max-value swap range-page-value [-] ;
+    [ range-max-value ] [ range-page-value ] bi [-] ;
 
 M: range set-range-value
-    [ clamp-value ] keep range-model set-model ;
+    [ clamp-value ] [ range-model ] bi set-model ;
 
 M: range set-range-page-value range-page set-model ;
 

extra/ui/gadgets/borders/borders-tests.factor

@@ -0,0 +1,25 @@
+IN: ui.gadgets.borders.tests
+USING: tools.test accessors namespaces kernel
+ui.gadgets ui.gadgets.borders ;
+
+[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
+
+[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
+
+[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 0 0 } >>align drop ] unit-test
+
+[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
+
+[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
+
+[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test

extra/ui/gadgets/borders/borders.factor

@@ -4,43 +4,44 @@ USING: accessors arrays ui.gadgets kernel math
 namespaces vectors sequences math.vectors ;
 IN: ui.gadgets.borders
 
-TUPLE: border < gadget size fill ;
+TUPLE: border < gadget
+{ size initial: { 0 0 } }
+{ fill initial: { 0 0 } }
+{ align initial: { 1/2 1/2 } } ;
+
+: new-border ( child class -- border )
+    new-gadget [ add-gadget ] keep ; inline
 
 : <border> ( child gap -- border )
-    border new-gadget
+    swap border new-border
-        swap dup 2array >>size
+        swap dup 2array >>size ;
-        { 0 0 } >>fill
-        [ add-gadget ] keep ;
 
 M: border pref-dim*
-    [ border-size 2 v*n ] keep
+    [ size>> 2 v*n ] keep
     gadget-child pref-dim v+ ;
 
-: border-major-rect ( border -- rect )
+: border-major-dim ( border -- dim )
-    dup border-size swap rect-dim over 2 v*n v- <rect> ;
+    [ dim>> ] [ size>> 2 v*n ] bi v- ;
 
-: border-minor-rect ( major border -- rect )
+: border-minor-dim ( border -- dim )
-    gadget-child pref-dim
+    gadget-child pref-dim ;
-    [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
-    <rect> ;
 
-: scale-rect ( rect vec -- loc dim )
+: scale ( a b s -- c )
-    [ v* ] curry >r rect-bounds r> bi@ ;
+    tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
 
-: average-rects ( rect1 rect2 weight -- rect )
+: border-dim ( border -- dim )
-    tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
+    [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
-    swapd v+ >r v+ r> <rect> ;
+
+: border-loc ( border dim -- loc )
+    [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
 
 : border-child-rect ( border -- rect )
-    dup border-major-rect
+    dup border-dim [ border-loc ] keep <rect> ;
-    dup pick border-minor-rect
-    rot border-fill
-    average-rects ;
 
 M: border layout*
     dup border-child-rect swap gadget-child
-    over rect-loc over set-rect-loc
+    over loc>> over set-rect-loc
-    swap rect-dim swap set-layout-dim ;
+    swap dim>> swap set-layout-dim ;
 
 M: border focusable-child*
     gadget-child ;

extra/ui/gadgets/buttons/buttons.factor

@@ -4,12 +4,12 @@ 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.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
 ui.render ;
 IN: ui.gadgets.buttons
 
-TUPLE: button < wrapper pressed? selected? quot ;
+TUPLE: button < border pressed? selected? quot ;
 
 : buttons-down? ( -- ? )
     hand-buttons get-global empty? not ;
@@ -41,11 +41,9 @@ button H{
 } set-gestures
 
 : new-button ( label quot class -- button )
-    new-gadget
+    [ swap >label ] dip new-border swap >>quot ; inline
-        swap >>quot
-        [ >r >label r> add-gadget ] keep ; inline
 
-: <button> ( gadget quot -- button )
+: <button> ( label quot -- button )
     button new-button ;
 
 TUPLE: button-paint plain rollover pressed selected ;
@@ -70,7 +68,8 @@ M: button-paint draw-boundary
     button-paint draw-boundary ;
 
 : roll-button-theme ( button -- button )
-    f black <solid> dup f <button-paint> >>boundary ; inline
+    f black <solid> dup f <button-paint> >>boundary
+    { 0 1/2 } >>align ; inline
 
 : <roll-button> ( label quot -- button )
     <button> roll-button-theme ;
@@ -84,13 +83,11 @@ M: button-paint draw-boundary
 
 : bevel-button-theme ( gadget -- gadget )
     <bevel-button-paint> >>interior
+    { 5 5 } >>size
     faint-boundary ; inline
 
-: >bevel-label ( label -- gadget )
-    >label 5 <border> ;
-
 : <bevel-button> ( label quot -- button )
-    >r >bevel-label r> <button> bevel-button-theme ;
+    <button> bevel-button-theme ;
 
 TUPLE: repeat-button < button ;
 
@@ -101,7 +98,7 @@ repeat-button H{
 : <repeat-button> ( label quot -- button )
     #! Button that calls the quotation every 100ms as long as
     #! the mouse is held down.
-    >r >bevel-label r> repeat-button new-button bevel-button-theme ;
+    repeat-button new-button bevel-button-theme ;
 
 TUPLE: checkmark-paint color ;
 
@@ -209,7 +206,7 @@ M: radio-control model-changed
     dup radio-buttons-theme ;
 
 : <toggle-button> ( value model label -- gadget )
-    >bevel-label <radio-control> bevel-button-theme ;
+    <radio-control> bevel-button-theme ;
 
 : <toggle-buttons> ( model assoc -- gadget )
     [ [ <toggle-button> ] <radio-controls> ] make-shelf ;

extra/ui/gadgets/editors/editors.factor

@@ -9,7 +9,6 @@ ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
-self
 font color caret-color selection-color
 caret mark
 focused? ;
@@ -30,8 +29,7 @@ focused? ;
     new-gadget
         <document> >>model
         init-editor-locs
-        editor-theme
+        editor-theme ; inline
-        dup dup set-editor-self ; inline
 
 : <editor> ( -- editor )
     editor new-editor ;
@@ -209,19 +207,19 @@ M: editor pref-dim*
     dup editor-font* swap control-value text-dim ;
 
 : contents-changed ( model editor -- )
-    editor-self swap
+    swap
-    over editor-caret [ over validate-loc ] (change-model)
+    over caret>> [ over validate-loc ] (change-model)
-    over editor-mark [ over validate-loc ] (change-model)
+    over mark>> [ over validate-loc ] (change-model)
     drop relayout ;
 
 : caret/mark-changed ( model editor -- )
-    nip editor-self dup relayout-1 scroll>caret ;
+    nip [ relayout-1 ] [ scroll>caret ] bi ;
 
 M: editor model-changed
     {
-        { [ 2dup gadget-model eq? ] [ contents-changed ] }
+        { [ 2dup model>> eq? ] [ contents-changed ] }
-        { [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
+        { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
-        { [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
+        { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
     } cond ;
 
 M: editor gadget-selection?

extra/xmode/keyword-map/keyword-map.factor

@@ -1,37 +1,43 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel strings assocs sequences hashtables
 sorting unicode.case unicode.categories sets ;
 IN: xmode.keyword-map
 
 ! Based on org.gjt.sp.jedit.syntax.KeywordMap
-TUPLE: keyword-map no-word-sep ignore-case? ;
+TUPLE: keyword-map no-word-sep ignore-case? assoc ;
 
 : <keyword-map> ( ignore-case? -- map )
-    H{ } clone { set-keyword-map-ignore-case? set-delegate }
+    keyword-map new
-    keyword-map construct ;
+        swap >>ignore-case?
+        H{ } clone >>assoc ;
 
 : invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ;
 
 : handle-case ( key keyword-map -- key assoc )
-    [ keyword-map-ignore-case? [ >upper ] when ] keep
+    [ ignore-case?>> [ >upper ] when ] [ assoc>> ] bi ;
-    delegate ;
+
+M: keyword-map assoc-size
+    assoc>> assoc-size ;
 
 M: keyword-map at* handle-case at* ;
 
 M: keyword-map set-at
-    [ handle-case set-at ] keep invalid-no-word-sep ;
+    [ handle-case set-at ] [ invalid-no-word-sep ] bi ;
 
 M: keyword-map clear-assoc
-    [ delegate clear-assoc ] keep invalid-no-word-sep ;
+    [ assoc>> clear-assoc ] [ invalid-no-word-sep ] bi ;
 
-M: keyword-map >alist delegate >alist ;
+M: keyword-map >alist
+    assoc>> >alist ;
 
 : (keyword-map-no-word-sep) ( assoc -- str )
     keys concat [ alpha? not ] filter prune natural-sort ;
 
 : keyword-map-no-word-sep* ( keyword-map -- str )
-    dup keyword-map-no-word-sep [ ] [
+    dup no-word-sep>> [ ] [
-        dup (keyword-map-no-word-sep)
+        dup (keyword-map-no-word-sep) >>no-word-sep
-        dup rot set-keyword-map-no-word-sep
+        keyword-map-no-word-sep*
     ] ?if ;
 
 INSTANCE: keyword-map assoc