working on layouts; simpler tuple delegation

library/bootstrap/init-stage2.factor

@@ -14,7 +14,7 @@ words ;
     init-random
     default-cli-args
     parse-command-line
-    "null-stdio" get [ << null-stream >> stdio set ] when ;
+    "null-stdio" get [ << null-stream f >> stdio set ] when ;
 
 : shell ( str -- )
     #! This handles the -shell:<foo> cli argument.

library/errors.factor

@@ -5,12 +5,12 @@ IN: streams DEFER: line-number
 IN: parser DEFER: file
 IN: errors USING: kernel-internals lists namespaces streams ;
 
-TUPLE: undefined-method object generic ;
+TUPLE: no-method object generic ;
 
-: undefined-method ( object generic -- )
+: no-method ( object generic -- )
     #! We 2dup here to leave both values on the stack, for
     #! post-mortem inspection.
-    2dup <undefined-method> throw ;
+    2dup <no-method> throw ;
 
 ! This is a very lightweight exception handling system.
 

library/generic/generic.factor

@@ -54,7 +54,7 @@ namespaces parser strings words vectors math math-internals ;
 
 : <empty-vtable> ( generic -- vtable )
     unit num-types
-    [ drop dup [ car undefined-method ] cons ] vector-project
+    [ drop dup [ car no-method ] cons ] vector-project
     nip ;
 
 : <vtable> ( generic -- vtable )

library/generic/slots.factor

@@ -7,12 +7,6 @@ IN: generic
 USING: kernel kernel-internals lists math namespaces parser
 strings words ;
 
-! So far, only tuples can have delegates, which also must be
-! tuples (the UI uses numbers as delegates in a couple of places
-! but this is Unsupported(tm)).
-GENERIC: delegate
-M: object delegate drop f ;
-
 : simple-generic ( class generic def -- )
     #! Just like:
     #! GENERIC: generic
@@ -64,24 +58,11 @@ M: object delegate drop f ;
 : simple-slot-spec ( class slots -- spec )
     [ simple-slot ] map-with ;
 
-: set-delegate-prop ( base class slots -- )
-    #! This sets the delegate-slot property of the class for
-    #! the benefit of tuples. Built-in types do not have
-    #! delegate slots.
-    swap >r [ "delegate" = dup [ >r 1 + r> ] unless ] some? [
-        r> swap
-        2dup "delegate-slot" set-word-prop
-        "delegate" [ "generic" ] search define-reader
-    ] [
-        r> 2drop
-    ] ifte ;
-
 : simple-slots ( base class slots -- )
     #! Takes a list of slot names, and for each slot name
     #! defines a pair of words <class>-<slot> and 
     #! set-<class>-<slot>. Slot numbering is consecutive and
     #! begins at base.
     >r tuck r>
-    3dup set-delegate-prop
     simple-slot-spec [ length [ + ] project-with ] keep zip
     define-slots ;

library/generic/tuple.factor

@@ -4,6 +4,14 @@ IN: kernel-internals
 USING: words parser kernel namespaces lists strings math
 hashtables errors vectors ;
 
+! Tuples are really arrays in the runtime, but with a different
+! type number. The layout is as follows:
+
+! slot 0 - object header with type number (as usual)
+! slot 1 - length, including class/delegate slots
+! slot 2 - the class, a word
+! slot 3 - the delegate tuple, or f
+
 : make-tuple ( class size -- tuple )
     #! Internal allocation function. Do not call it directly,
     #! since you can fool the runtime and corrupt memory by
@@ -16,6 +24,18 @@ IN: generic
 
 BUILTIN: tuple 18 [ 1 array-capacity f ] ;
 
+! So far, only tuples can have delegates, which also must be
+! tuples (the UI uses numbers as delegates in a couple of places
+! but this is Unsupported(tm)).
+GENERIC: delegate
+GENERIC: set-delegate
+
+M: object delegate drop f ;
+M: tuple delegate 3 slot ;
+
+M: object set-delegate 2drop ;
+M: tuple set-delegate 3 set-slot ;
+
 #! arrayed objects can be passed to array-capacity,
 #! array-nth, and set-array-nth.
 UNION: arrayed array tuple ;
@@ -48,15 +68,15 @@ UNION: arrayed array tuple ;
     #! If the new list of slots is different from the previous,
     #! forget the old definition.
     >r "use" get search dup [
-        dup "tuple-size" word-prop r> length 1 + =
+        dup "tuple-size" word-prop r> length 2 + =
         [ drop ] [ forget ] ifte
     ] [
         r> 2drop
     ] ifte ;
 
 : tuple-slots ( tuple slots -- )
-    2dup length 1 + "tuple-size" set-word-prop
-    3 -rot simple-slots ;
+    2dup length 2 + "tuple-size" set-word-prop
+    4 -rot simple-slots ;
 
 : constructor-word ( word -- word )
     word-name "<" swap ">" cat3 create-in ;
@@ -123,7 +143,7 @@ UNION: arrayed array tuple ;
         ] [
             2drop [ dup delegate ] swap
             dup unit swap
-            unit [ car ] cons [ undefined-method ] append
+            unit [ car ] cons [ no-method ] append
             \ ?ifte 3list append
         ] ifte
     ] ifte ;
@@ -143,16 +163,9 @@ UNION: arrayed array tuple ;
     #! delegate.
     dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
 
-: clone-delegate ( tuple -- )
-    dup class "delegate-slot" word-prop dup [
-        [ >fixnum slot clone ] 2keep set-slot
-    ] [
-        2drop
-    ] ifte ;
-
 M: tuple clone ( tuple -- tuple )
     #! Clone a tuple and its delegate.
-    clone-tuple dup clone-delegate ;
+    clone-tuple dup delegate clone over set-delegate ;
 
 : tuple>list ( tuple -- list )
     dup array-capacity swap array>list ;
@@ -169,10 +182,12 @@ M: tuple = ( obj tuple -- ? )
     ] ifte ;
 
 M: tuple hashcode ( vec -- n )
-    dup array-capacity 1 number= [
+    #! If the capacity is two, then all we have is the class
+    #! slot and delegate.
+    dup array-capacity 2 number= [
         drop 0
     ] [
-        1 swap array-nth hashcode
+        2 swap array-nth hashcode
     ] ifte ;
 
 tuple [

library/httpd/html.factor

@@ -100,7 +100,7 @@ url-encoding presentation generic ;
         drop call
     ] ifte ;
 
-TUPLE: html-stream delegate ;
+TUPLE: html-stream ;
 
 M: html-stream stream-write-attr ( str style stream -- )
     wrapper-stream-scope [
@@ -127,7 +127,7 @@ C: html-stream ( stream -- stream )
     #! underline
     #! size
     #! link - an object path
-    [ >r <wrapper-stream> r> set-html-stream-delegate ] keep ;
+    [ >r <wrapper-stream> r> set-delegate ] keep ;
 
 : with-html-stream ( quot -- )
     [ stdio [ <html-stream> ] change  call ] with-scope ;

library/inference/inference.factor

@@ -33,21 +33,21 @@ TUPLE: value class recursion class-ties literal-ties ;
 C: value ( recursion -- value )
     [ set-value-recursion ] keep ;
 
-TUPLE: computed delegate ;
+TUPLE: computed ;
 
 C: computed ( class -- value )
     swap recursive-state get <value> [ set-value-class ] keep
-    over set-computed-delegate ;
+    over set-delegate ;
 
 M: computed value= ( literal value -- ? )
     2drop f ;
 
 : failing-class-and ( class class -- class )
     2dup class-and dup null = [
-        drop [
+        -rot [
             word-name , " and " , word-name ,
             " do not intersect" ,
-        ] make-string inference-error
+        ] make-string inference-warning
     ] [
         2nip
     ] ifte ;
@@ -57,12 +57,12 @@ M: computed value-class-and ( class value -- )
         value-class  failing-class-and
     ] keep set-value-class ;
 
-TUPLE: literal value delegate ;
+TUPLE: literal value ;
 
 C: literal ( obj rstate -- value )
     [
         >r <value> [ >r dup class r> set-value-class ] keep
-        r> set-literal-delegate
+        r> set-delegate
     ] keep
     [ set-literal-value ] keep ;
 

library/inference/ties.factor

@@ -24,7 +24,7 @@ USING: kernel lists prettyprint ;
 ! GENERIC: car
 ! M: cons car 0 slot ;
 !
-! The only branch that does not end with undefined-method pulls
+! The only branch that does not end with no-method pulls
 ! a tie that sets the value's type to cons after two steps.
 
 ! Formally, a tie is a tuple.

library/inference/words.factor

@@ -173,7 +173,7 @@ M: word apply-object ( word -- )
 \ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
 \ = [ [ object object ] [ object ] ] "infer-effect" set-word-prop
 
-\ undefined-method t "terminator" set-word-prop
-\ undefined-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
+\ no-method t "terminator" set-word-prop
+\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
 \ not-a-number t "terminator" set-word-prop
 \ throw t "terminator" set-word-prop

library/io/ansi.factor

@@ -48,11 +48,12 @@ presentation generic ;
 : ansi-attr-string ( string style -- string )
     [ ansi-attrs , reset , ] make-string ;
 
-TUPLE: ansi-stream delegate ;
+TUPLE: ansi-stream ;
+C: ansi-stream ( stream -- stream ) [ set-delegate ] keep ;
 
 M: ansi-stream stream-write-attr ( string style stream -- )
     >r [ default-style ] unless* ansi-attr-string r>
-    ansi-stream-delegate stream-write ;
+    delegate stream-write ;
 
 IN: shells
 

library/io/network.factor

@@ -16,11 +16,11 @@ C: server ( port -- stream )
     #! with accept. No other stream operations are supported.
     [ >r server-socket r> set-server-port ] keep ;
 
-TUPLE: client-stream delegate host ;
+TUPLE: client-stream host ;
 
 C: client-stream ( host port in out -- stream )
     #! stream-flush yields until connection is established.
-    [ >r <fd-stream> r> set-client-stream-delegate ] keep
+    [ >r <fd-stream> r> set-delegate ] keep
     [ >r ":" swap unparse cat3 r> set-client-stream-host ] keep
     dup stream-flush ;
 

library/io/stdio.factor

@@ -29,10 +29,7 @@ SYMBOL: stdio
         call stdio get stream>str
     ] with-stream ;
 
-TUPLE: stdio-stream delegate ;
-
-M: stdio-stream stream-auto-flush ( -- )
-    stdio-stream-delegate stream-flush ;
-
-M: stdio-stream stream-close ( -- )
-    drop ;
+TUPLE: stdio-stream ;
+C: stdio-stream ( stream -- stream ) [ set-delegate ] keep ;
+M: stdio-stream stream-auto-flush ( -- ) delegate stream-flush ;
+M: stdio-stream stream-close ( -- ) drop ;

library/io/stream.factor

@@ -45,10 +45,10 @@ C: string-output ( size -- stream )
 
 ! Sometimes, we want to have a delegating stream that uses stdio
 ! words.
-TUPLE: wrapper-stream delegate scope ;
+TUPLE: wrapper-stream scope ;
 
 C: wrapper-stream ( stream -- stream )
-    2dup set-wrapper-stream-delegate
+    2dup set-delegate
     [
         >r <namespace> [ stdio set ] extend r>
         set-wrapper-stream-scope

library/io/win32-io-internals.factor

@@ -142,7 +142,7 @@ END-STRUCT
     INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
     completion-port set 
     
-    << null-stream >> stdio set
+    << null-stream f >> stdio set
 
     <namespace> [
         32 <vector> callbacks set

library/io/win32-server.factor

@@ -29,7 +29,7 @@ USING: alien errors generic kernel kernel-internals lists math namespaces
        win32-io-internals ;
 
 TUPLE: win32-server this ;
-TUPLE: win32-client-stream delegate host ;
+TUPLE: win32-client-stream host ;
 SYMBOL: winsock
 SYMBOL: socket
 
@@ -72,7 +72,7 @@ SYMBOL: socket
     GetAcceptExSockaddrs r> indirect-pointer-value <alien> sockaddr>string ;
 
 C: win32-client-stream ( buf stream -- stream )
-    [ set-win32-client-stream-delegate extract-remote-host ] keep
+    [ set-delegate extract-remote-host ] keep
     [ set-win32-client-stream-host ] keep ;
 
 M: win32-client-stream client-stream-host win32-client-stream-host ;

library/test/dataflow.factor

@@ -63,10 +63,10 @@ USE: generic
 ] unit-test
 
 ! [ t ] [
-!     [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
+!     [ { [ drop ] [ no-method ] [ drop ] [ no-method ] } generic ] dataflow
 !     \ dispatch swap dataflow-contains-op? car [
 !         node-param get [
-!             [ [ node-param get \ undefined-method = ] bind ] some?
+!             [ [ node-param get \ no-method = ] bind ] some?
 !         ] some?
 !     ] bind >boolean
 ! ] unit-test

library/test/gadgets.factor

@@ -63,24 +63,10 @@ USING: gadgets kernel lists math namespaces test ;
     [
         100 x set
         100 y set
-        #{ 110 115 }# << line 0 0 100 150 >> inside?
+        #{ 110 115 }# << line f 0 0 100 150 >> inside?
     ] with-scope
 ] unit-test
 
-[
-    [
-        100
-        200
-        300
-    ]
-] [
-    [
-        0 0 100 100 <rectangle> <gadget> ,
-        0 0 200 200 <rectangle> <gadget> ,
-        0 0 300 300 <rectangle> <gadget> ,
-    ] make-list w/h drop 0 swap dup greatest swap layout-fill
-] unit-test
-
 [
     300 620
 ] [
@@ -90,3 +76,5 @@ USING: gadgets kernel lists math namespaces test ;
     0 0 300 300 <rectangle> <gadget> "pile" get add-gadget
     "pile" get pref-size
 ] unit-test
+
+[ ] [ "pile" get layout* ] unit-test

library/test/generic.factor

@@ -117,4 +117,4 @@ M: for-arguments-sake empty-method-test drop "Hi" ;
 TUPLE: another-one ;
 
 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
-[ << another-one >> ] [ <another-one> empty-method-test ] unit-test
+[ << another-one f >> ] [ <another-one> empty-method-test ] unit-test

library/test/inference.factor

@@ -236,3 +236,11 @@ M: fixnum potential-hang dup [ potential-hang ] when ;
 ! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
 ! 
 ! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
+
+TUPLE: funny-cons car cdr ;
+GENERIC: iterate
+M: funny-cons iterate funny-cons-cdr iterate ;
+M: f iterate drop ;
+M: real iterate drop ;
+
+[ [[ 1 0 ]] ] [ [ iterate ] infer old-effect ] unit-test

library/test/tuple.factor

@@ -20,9 +20,9 @@ M: object delegation-test drop 3 ;
 TUPLE: quux-tuple ;
 C: quux-tuple ;
 M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple delegate ;
+TUPLE: quuux-tuple ;
 C: quuux-tuple
-    [ set-quuux-tuple-delegate ] keep ;
+    [ set-delegate ] keep ;
 
 [ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
 
@@ -30,9 +30,9 @@ GENERIC: delegation-test-2
 TUPLE: quux-tuple-2 ;
 C: quux-tuple-2 ;
 M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 delegate ;
+TUPLE: quuux-tuple-2 ;
 C: quuux-tuple-2
-    [ set-quuux-tuple-2-delegate ] keep ;
+    [ set-delegate ] keep ;
 
 [ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
 

library/tools/debugger.factor

@@ -142,12 +142,12 @@ M: object error. ( error -- )
     kernel-error 12 setenv ;
     
 
-M: undefined-method error. ( error -- )
+M: no-method error. ( error -- )
     [
         "The generic word " ,
-        dup undefined-method-generic unparse ,
+        dup no-method-generic unparse ,
         " does not have a suitable method for " ,
-        undefined-method-object unparse ,
+        no-method-object unparse ,
     ] make-string print ;
 
 ! So that stage 2 boot gives a useful error message if something

library/tools/jedit-wire.factor

@@ -78,7 +78,7 @@ USE: listener
     dup string-length write-big-endian-32
     write ;
 
-TUPLE: jedit-stream delegate ;
+TUPLE: jedit-stream ;
 
 M: jedit-stream stream-readln ( stream -- str )
     wrapper-stream-scope
@@ -93,7 +93,7 @@ M: jedit-stream stream-flush ( stream -- )
     [ CHAR: f write flush ] bind ;
 
 C: jedit-stream ( stream -- stream )
-    [ >r <wrapper-stream> r> set-jedit-stream-delegate ] keep ;
+    [ >r <wrapper-stream> r> set-delegate ] keep ;
 
 : stream-server ( -- )
     #! Execute this in the inferior Factor.

library/ui/checkboxes.factor

@@ -8,7 +8,7 @@ USING: generic kernel lists math namespaces sdl ;
     >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
     2list <stack> ;
 
-TUPLE: checkbox bevel selected? delegate ;
+TUPLE: checkbox bevel selected? ;
 
 : init-checkbox-bevel ( bevel checkbox -- )
     2dup set-checkbox-bevel add-gadget ;
@@ -38,7 +38,7 @@ TUPLE: checkbox bevel selected? delegate ;
     [ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
 
 C: checkbox ( label -- checkbox )
-    <default-shelf> over set-checkbox-delegate
+    <default-shelf> over set-delegate
     [ f line-border swap init-checkbox-bevel ] keep
     [ >r <label> r> add-gadget ] keep
     dup checkbox-actions

library/ui/dialogs.factor

@@ -1,7 +1,7 @@
 IN: gadgets
-USING: kernel namespaces threads ;
+USING: generic kernel namespaces threads ;
 
-TUPLE: dialog continuation delegate ;
+TUPLE: dialog continuation ;
 
 : dialog-action ( ok dialog -- )
     dup unparent  dialog-continuation call ;
@@ -24,7 +24,7 @@ TUPLE: dialog continuation delegate ;
     [ dialog-cancel ] dup set-action ;
 
 C: dialog ( content -- gadget )
-    [ f line-border swap set-dialog-delegate ] keep
+    [ f line-border swap set-delegate ] keep
     [
         >r <default-pile>
         [ add-gadget ] keep

library/ui/editors.factor

@@ -7,7 +7,7 @@ strings ;
 ! An editor gadget wraps a line editor object and passes
 ! gestures to the line editor.
 
-TUPLE: editor line caret delegate ;
+TUPLE: editor line caret ;
 
 : editor-text ( editor -- text )
     editor-line [ line-text get ] bind ;
@@ -70,7 +70,7 @@ TUPLE: editor line caret delegate ;
     dup red background set-paint-prop ;
 
 C: editor ( text -- )
-    0 0 0 0 <line> <gadget> over set-editor-delegate
+    0 0 0 0 <line> <gadget> over set-delegate
     [ <line-editor> swap set-editor-line ] keep
     [ <caret> swap set-editor-caret ] keep
     [ set-editor-text ] keep
@@ -89,8 +89,7 @@ M: editor user-input* ( ch field -- ? )
     [ insert-char ] with-editor t ;
 
 M: editor layout* ( field -- )
-    dup [ editor-text dup shape-w swap shape-h ] keep
-    resize-gadget
+    dup [ editor-text shape-size ] keep resize-gadget
     dup editor-caret over caret-size rot resize-gadget
     dup editor-caret swap caret-pos rot move-gadget ;
 

library/ui/ellipses.factor

@@ -39,19 +39,19 @@ M: ellipse inside? ( point ellipse -- ? )
 
 M: ellipse draw-shape drop ;
 
-TUPLE: hollow-ellipse delegate ;
+TUPLE: hollow-ellipse ;
 
 C: hollow-ellipse ( x y w h -- ellipse )
-    [ >r <ellipse> r> set-hollow-ellipse-delegate ] keep ;
+    [ >r <ellipse> r> set-delegate ] keep ;
 
 M: hollow-ellipse draw-shape ( ellipse -- )
     >r surface get r> ellipse>screen fg rgb
     ellipseColor ;
 
-TUPLE: plain-ellipse delegate ;
+TUPLE: plain-ellipse ;
 
 C: plain-ellipse ( x y w h -- ellipse )
-    [ >r <ellipse> r> set-plain-ellipse-delegate ] keep ;
+    [ >r <ellipse> r> set-delegate ] keep ;
 
 M: plain-ellipse draw-shape ( ellipse -- )
     >r surface get r> ellipse>screen bg rgb

library/ui/gadgets.factor

@@ -6,13 +6,10 @@ USING: generic hashtables kernel lists math namespaces ;
 ! A gadget is a shape, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent. A gadget
 ! delegates to its shape.
-TUPLE: gadget
-    paint gestures
-    relayout? redraw?
-    parent children delegate ;
+TUPLE: gadget paint gestures relayout? redraw? parent children ;
 
 C: gadget ( shape -- gadget )
-    [ set-gadget-delegate ] keep
+    [ set-delegate ] keep
     [ <namespace> swap set-gadget-paint ] keep
     [ <namespace> swap set-gadget-gestures ] keep
     [ t swap set-gadget-relayout? ] keep
@@ -40,7 +37,7 @@ C: gadget ( shape -- gadget )
 : set-paint-prop ( gadget value key -- ) rot gadget-paint set-hash ;
 
 GENERIC: pref-size ( gadget -- w h )
-M: gadget pref-size dup shape-w swap shape-h ;
+M: gadget pref-size shape-size ;
 
 GENERIC: layout* ( gadget -- )
 

library/ui/hand.factor

@@ -45,14 +45,13 @@ DEFER: pick-up
 ! - hand-gadget is the gadget under the mouse position
 ! - hand-clicked is the most recently clicked gadget
 ! - hand-focus is the gadget holding keyboard focus
-TUPLE: hand
-    world
+TUPLE: hand world
     click-pos click-rel clicked buttons
-    gadget focus delegate ;
+    gadget focus ;
 
 C: hand ( world -- hand )
     <empty-gadget>
-    over set-hand-delegate
+    over set-delegate
     [ set-hand-world ] 2keep
     [ set-gadget-parent ] 2keep
     [ set-hand-gadget ] keep ;

library/ui/labels.factor

@@ -4,14 +4,13 @@ IN: gadgets
 USING: generic kernel lists math namespaces sdl stdio ;
 
 ! A label gadget draws a string.
-TUPLE: label text delegate ;
+TUPLE: label text ;
 
-C: label ( text -- )
-    <empty-gadget> over set-label-delegate
-    [ set-label-text ] keep ;
+C: label ( text -- label )
+    <empty-gadget> over set-delegate [ set-label-text ] keep ;
 
-M: label pref-size ( label -- ) label-text pref-size ;
+M: label pref-size label-text shape-size ;
 
 M: label draw-shape ( label -- )
-    dup label-delegate draw-shape
+    dup delegate draw-shape
     dup shape-pos [ label-text draw-shape ] with-trans ;

library/ui/layouts.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic hashtables kernel lists math namespaces ;
+USING: errors generic hashtables kernel lists math namespaces
+sdl ;
 
 : layout ( gadget -- )
     #! Set the gadget's width and height to its preferred width
@@ -18,16 +19,24 @@ USING: generic hashtables kernel lists math namespaces ;
         drop
     ] ifte ;
 
+: with-pref-size ( quot -- )
+    [
+        0 width set  0 height set  call  width get height get
+    ] with-scope ; inline
+
+: with-layout ( quot -- )
+    [ 0 x set 0 y set call ] with-scope ; inline
+
 : default-gap 3 ;
 
 ! A pile is a box that lays out its contents vertically.
-TUPLE: pile align gap fill delegate ;
+TUPLE: pile align gap fill ;
 
 C: pile ( align gap fill -- pile )
     #! align: 0 left aligns, 1/2 center, 1 right.
     #! gap: between each child.
     #! fill: 0 leaves default width, 1 fills to pile width.
-    [ <empty-gadget> swap set-pile-delegate ] keep
+    [ <empty-gadget> swap set-delegate ] keep
     [ set-pile-fill ] keep
     [ set-pile-gap ] keep
     [ set-pile-align ] keep ;
@@ -35,65 +44,75 @@ C: pile ( align gap fill -- pile )
 : <default-pile> 1/2 default-gap 0 <pile> ;
 : <line-pile> 0 0 1 <pile> ;
 
-: w/h ( list -- widths heights ) [ pref-size cons ] map unzip ;
-
-: greatest ( integers -- n ) [ [ > ] top ] [ 0 ] ifte* ;
-
-: layout-align ( align max dimensions -- offsets )
-    [ >r 2dup r> - * ] map 2nip ;
-
-: layout-fill ( fill max dimensions -- dimensions )
-    [ layout-align ] keep zip [ uncons + ] map ;
-
-: layout-run ( gap list -- n list )
-    #! The nth element of the resulting list is the sum of the
-    #! first n elements of the given list plus gap, n times.
-    [ 0 swap [ over , + over + ] each ] make-list >r swap - r> ;
-
 M: pile pref-size ( pile -- w h )
-    dup pile-gap swap w/h swapd layout-run drop >r greatest r> ;
+    [
+        dup pile-gap swap gadget-children
+        [ length 1 - 0 max * height set ] keep
+        [
+            pref-size
+            height [ + ] change
+            width [ max ] change
+        ] each
+    ] with-pref-size ;
+
+: w- swap shape-w swap pref-size drop - ;
+: pile-x/y ( pile gadget offset -- )
+    rot pile-align * >fixnum y get rot move-gadget ;
+: pile-w/h ( pile gadget offset -- )
+    rot dup pile-gap y [ + ] change
+    pile-fill * >fixnum over pref-size dup y [ + ] change
+    >r + r> rot resize-gadget ;
+: vertically ( pile gadget -- ) 2dup w- 3dup pile-x/y pile-w/h ;
 
 M: pile layout* ( pile -- )
-    drop ;
+    [
+        dup gadget-children [ vertically ] each-with
+    ] with-layout ;
 
 ! A shelf is a box that lays out its contents horizontally.
-TUPLE: shelf gap align fill delegate ;
+TUPLE: shelf gap align fill ;
 
 C: shelf ( align gap fill -- shelf )
-    <empty-gadget> over set-shelf-delegate
+    <empty-gadget> over set-delegate
     [ set-shelf-fill ] keep
     [ set-shelf-gap ] keep
     [ set-shelf-align ] keep ;
 
-: h- swap shape-h swap shape-h - ;
-: shelf-h 2dup h- rot shelf-fill * swap shape-h + >fixnum ;
-: shelf-y dupd h- swap shelf-align * >fixnum ;
-
-: vertical-layout ( gadget x shelf -- )
-    >r 2dup shelf-h >r dup shape-w r> pick resize-gadget
-    tuck shelf-y r> swap rot move-gadget ;
-
 : <default-shelf> 1/2 default-gap 0 <shelf> ;
 : <line-shelf> 0 0 1 <shelf> ;
 
-M: shelf pref-size ( shelf -- w h )
-    dup shelf-gap over gadget-children run-widths drop
-    swap gadget-children max-height ;
+M: shelf pref-size ( pile -- w h )
+    [
+        dup shelf-gap swap gadget-children
+        [ length 1 - 0 max * width set ] keep
+        [
+            pref-size
+            height [ max ] change
+            width [ + ] change
+        ] each
+    ] with-pref-size ;
 
-M: shelf layout* ( shelf -- )
-    dup shelf-gap over gadget-children run-widths >r >r
-    dup gadget-children max-height r> swap pick resize-gadget
-    dup gadget-children r> zip [
-        uncons vertical-layout
-    ] each-with ;
+: h- swap shape-h swap pref-size nip - ;
+: shelf-x/y rot shelf-align * >fixnum >r x get r> rot move-gadget ;
+: shelf-w/h ( pile gadget offset -- )
+    rot dup shelf-gap x [ + ] change
+    shelf-fill * >fixnum >r dup pref-size over x [ + ] change
+    r> drop rot resize-gadget ; 
+: horizontally ( pile gadget -- )
+    2dup h- 3dup shelf-x/y shelf-w/h ;
+
+M: shelf layout* ( pile -- )
+    [
+        dup gadget-children [ horizontally ] each-with
+    ] with-layout ;
 
 ! A border lays out its children on top of each other, all with
 ! a 5-pixel padding.
-TUPLE: border size delegate ;
+TUPLE: border size ;
 
 C: border ( child delegate size -- border )
     [ set-border-size ] keep
-    [ set-border-delegate ] keep
+    [ set-delegate ] keep
     [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
 
 : empty-border ( child -- border )
@@ -105,34 +124,38 @@ C: border ( child delegate size -- border )
 : filled-border ( child -- border )
     0 0 0 0 <plain-rect> <gadget> 5 <border> ;
 
+: gadget-child gadget-children car ;
+
 : layout-border-x/y ( border -- )
-    dup gadget-children [
-        >r border-size dup r> move-gadget
-    ] each-with ;
+    dup border-size dup rot gadget-child move-gadget ;
 
 : layout-border-w/h ( border -- )
-    [
-        dup shape-h over border-size 2 * - >r
-        dup shape-w swap border-size 2 * - r>
-    ] keep
-    gadget-children [ >r 2dup r> resize-gadget ] each 2drop ;
+    [ border-size 2 * ] keep
+    [ shape-w over - ] keep
+    [ shape-h rot - ] keep
+    gadget-child resize-gadget ;
 
 M: border pref-size ( border -- w h )
-    dup gadget-children
-    dup max-width pick border-size 2 * +
-    swap max-height rot border-size 2 * + ;
+    [ border-size 2 * ] keep
+    gadget-child pref-size >r over + r> rot + ;
 
 M: border layout* ( border -- )
     dup layout-border-x/y layout-border-w/h ;
 
 ! A stack just lays out all its children on top of each other.
-TUPLE: stack delegate ;
+TUPLE: stack ;
 C: stack ( list -- stack )
-    <empty-gadget>
-    over set-stack-delegate
+    <empty-gadget> over set-delegate
     swap [ over add-gadget ] each ;
 
-: max-size ( stack -- w h ) w/h swap greatest swap greatest ;
+: max-size ( stack -- w h )
+    [
+        [
+            dup
+            shape-w width [ max ] change
+            shape-h height [ max ] change
+        ] each
+    ] with-pref-size ;
 
 M: stack pref-size gadget-children max-size ;
 

library/ui/menus.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel lists math namespaces ;
+USING: generic kernel lists math namespaces ;
 
 : hide-menu ( -- )
     world get
@@ -20,7 +20,7 @@ USING: kernel lists math namespaces ;
 : <menu-item> ( label quot -- gadget )
     >r <label> menu-item-border dup r> button-actions ;
 
-TUPLE: menu delegate ;
+TUPLE: menu ;
 
 : menu-actions ( menu -- )
     [ drop world get hide-menu ] [ button-down 1 ] set-action ;
@@ -34,7 +34,7 @@ TUPLE: menu delegate ;
 
 C: menu ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.
-    [ f line-border swap set-menu-delegate ] keep
+    [ f line-border swap set-delegate ] keep
     <line-pile> [ swap add-gadget ] 2keep
     rot assoc>menu dup menu-actions ;
 

library/ui/panes.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel line-editor listener lists namespaces stdio
-streams strings threads ;
+USING: generic kernel line-editor listener lists namespaces
+stdio streams strings threads ;
 
 ! A pane is an area that can display text.
 
 ! output: pile
 ! current: label
 ! input: editor
-TUPLE: pane output current input continuation delegate ;
+TUPLE: pane output current input continuation ;
 
 : add-output 2dup set-pane-output add-gadget ;
 : add-input 2dup set-pane-input add-gadget ;
@@ -38,7 +38,7 @@ TUPLE: pane output current input continuation delegate ;
     ] swap add-actions ;
 
 C: pane ( -- pane )
-    <line-pile> over set-pane-delegate
+    <line-pile> over set-delegate
     <line-pile> over add-output
     "" <label> dup pick set-pane-current >r
     "" <editor> dup pick set-pane-input r>

library/ui/rectangles.factor

@@ -50,10 +50,10 @@ M: rectangle inside? ( point rect -- ? )
 M: rectangle draw-shape drop ;
 
 ! A rectangle only whose outline is visible.
-TUPLE: hollow-rect delegate ;
+TUPLE: hollow-rect ;
 
 C: hollow-rect ( x y w h -- rect )
-    [ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
+    [ >r <rectangle> r> set-delegate ] keep ;
 
 : hollow-rect ( shape -- )
     #! Draw a hollow rect with the bounds of an arbitrary shape.
@@ -63,10 +63,10 @@ M: hollow-rect draw-shape ( rect -- )
     >r surface get r> hollow-rect ;
 
 ! A rectangle that is filled.
-TUPLE: plain-rect delegate ;
+TUPLE: plain-rect ;
 
 C: plain-rect ( x y w h -- rect )
-    [ >r <rectangle> r> set-plain-rect-delegate ] keep ;
+    [ >r <rectangle> r> set-delegate ] keep ;
 
 : plain-rect ( shape -- )
     #! Draw a filled rect with the bounds of an arbitrary shape.
@@ -76,10 +76,10 @@ M: plain-rect draw-shape ( rect -- )
     >r surface get r> plain-rect ;
 
 ! A rectangle that is filled, and has a visible outline.
-TUPLE: etched-rect delegate ;
+TUPLE: etched-rect ;
 
 C: etched-rect ( x y w h -- rect )
-    [ >r <rectangle> r> set-etched-rect-delegate ] keep ;
+    [ >r <rectangle> r> set-delegate ] keep ;
 
 M: etched-rect draw-shape ( rect -- )
     >r surface get r> 2dup plain-rect hollow-rect ;
@@ -88,10 +88,10 @@ M: etched-rect draw-shape ( rect -- )
 ! paint property is set.
 SYMBOL: rollover?
 
-TUPLE: roll-rect delegate ;
+TUPLE: roll-rect ;
 
 C: roll-rect ( x y w h -- rect )
-    [ >r <rectangle> r> set-roll-rect-delegate ] keep ;
+    [ >r <rectangle> r> set-delegate ] keep ;
 
 M: roll-rect draw-shape ( rect -- )
     >r surface get r> 2dup

library/ui/scrolling.factor

@@ -1,12 +1,11 @@
 IN: gadgets
-USING: kernel lists math namespaces threads ;
+USING: generic kernel lists math namespaces threads ;
 
 ! A viewport can be scrolled.
 
-TUPLE: viewport x y delegate ;
+TUPLE: viewport x y ;
 
-: viewport-h ( viewport -- h ) gadget-children max-height ;
-: viewport-w ( viewport -- w ) gadget-children max-width ;
+: viewport-h ( viewport -- h ) gadget-child pref-size nip ;
 
 : adjust-scroll ( y viewport -- y )
     #! Make sure we don't scroll above the first line, or beyond
@@ -29,14 +28,13 @@ TUPLE: viewport x y delegate ;
     ] swap add-actions ;
 
 C: viewport ( content -- viewport )
-    [ <empty-gadget> swap set-viewport-delegate ] keep
+    [ <empty-gadget> swap set-delegate ] keep
     [ add-gadget ] keep
     0 over set-viewport-x
     0 over set-viewport-y
-    dup viewport-actions
-    640 480 pick resize-gadget ;
+    dup viewport-actions ;
 
-M: viewport pref-size gadget-children max-size ;
+M: viewport pref-size gadget-child pref-size ;
 
 M: viewport layout* ( viewport -- )
     dup gadget-children [
@@ -52,7 +50,7 @@ M: viewport layout* ( viewport -- )
 
 ! The offset slot is the y co-ordinate of the mouse relative to
 ! the thumb when it was clicked.
-TUPLE: slider viewport thumb delegate ;
+TUPLE: slider viewport thumb ;
 
 : hand-y ( gadget -- y )
     #! Vertical offset of hand from gadget.
@@ -91,11 +89,7 @@ TUPLE: slider viewport thumb delegate ;
 
 C: slider ( viewport -- slider )
     [ set-slider-viewport ] keep
-    [
-        f line-border
-        slider-size 200 pick resize-gadget
-        swap set-slider-delegate
-    ] keep
+    [ f line-border swap set-delegate ] keep
     [ <thumb> swap add-thumb ] keep
     [ slider-actions ] keep ;
 
@@ -114,18 +108,19 @@ C: slider ( viewport -- slider )
 : thumb-y ( slider -- y )
     dup slider-viewport viewport-y neg >thumb ;
 
+M: slider pref-size drop slider-size 100 ;
+
 M: slider layout* ( slider -- )
-    dup slider-viewport layout*
     dup shape-w over thumb-height pick slider-thumb resize-gadget
     0 over thumb-y rot slider-thumb move-gadget ;
 
-TUPLE: scroller viewport slider delegate ;
+TUPLE: scroller viewport slider ;
 
 : add-viewport 2dup set-scroller-viewport add-gadget ;
 : add-slider 2dup set-scroller-slider add-gadget ;
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.
-    [ <line-shelf> swap set-scroller-delegate ] keep
+    [ <line-shelf> swap set-delegate ] keep
     [ >r <viewport> r> add-viewport ] keep
     [ dup scroller-viewport <slider> swap add-slider ] keep ;

library/ui/shapes.factor

@@ -50,26 +50,8 @@ GENERIC: draw-shape ( obj -- )
         r> call
     ] with-scope ; inline
 
-: max-width ( list -- n )
-    #! The width of the widest shape.
-    [ [ shape-w ] map [ > ] top ] [ 0 ] ifte* ;
-
-: max-height ( list -- n )
-    #! The height of the tallest shape.
-    [ [ shape-h ] map [ > ] top ] [ 0 ] ifte* ;
-
-: accumilate ( gap list -- n list )
-    #! The nth element of the resulting list is the sum of the
-    #! first n elements of the given list plus gap, n times.
-    [ 0 swap [ over , + over + ] each ] make-list >r swap - r> ;
-
-: run-widths ( gap list -- w list )
-    #! Compute a list of running sums of widths of shapes.
-    [ shape-w ] map accumilate ;
-
-: run-heights ( gap list -- h list )
-    #! Compute a list of running sums of heights of shapes.
-    [ shape-h ] map accumilate ;
-
 : shape-pos ( shape -- pos )
     dup shape-x swap shape-y rect> ;
+
+: shape-size ( shape -- w h )
+    dup shape-w swap shape-h ;

library/ui/tiles.factor

@@ -1,14 +1,12 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel math namespaces ;
+USING: generic kernel math namespaces ;
 
 ! A tile is a gadget with a caption. Dragging the caption
 ! moves the gadget. The title bar also has buttons for
 ! performing various actions.
 
-TUPLE: caption tile delegate ;
-
 : click-rel ( gadget -- point )
     screen-pos
     hand [ hand-clicked screen-pos - ] keep hand-click-rel - ;
@@ -20,9 +18,9 @@ TUPLE: caption tile delegate ;
     dup gadget-parent >r dup unparent r> add-gadget ;
 
 : caption-actions ( caption -- )
-    dup [ caption-tile raise ] [ button-down 1 ] set-action
+    dup [ [ raise ] swap handle-gesture drop ] [ button-down 1 ] set-action
     dup [ drop ] [ button-up 1 ] set-action
-    [ caption-tile drag-tile ] [ drag 1 ] set-action ;
+    [ [ drag-tile ] swap handle-gesture drop ] [ drag 1 ] set-action ;
 
 : close-tile [ close-tile ] swap handle-gesture drop ;
 : inspect-tile [ inspect-tile ] swap handle-gesture drop ;
@@ -38,23 +36,29 @@ TUPLE: caption tile delegate ;
     [ "Menu" [ tile-menu ] <roll-button> swap add-gadget ] keep
     [ >r <label> r> add-gadget ] keep ;
 
-C: caption ( text -- caption )
-    [ f filled-border swap set-caption-delegate ] keep
-    [ >r caption-content r> add-gadget ] keep
-    dup caption-actions
-    dup t reverse-video set-paint-prop ;
+: <caption> ( text -- caption )
+    caption-content line-border
+    dup t reverse-video set-paint-prop
+    dup caption-actions ;
 
 DEFER: inspect
 
 : tile-actions ( tile -- )
     dup [ unparent ] [ close-tile ] set-action
-    [ inspect ] [ inspect-tile ] set-action ;
+    dup [ inspect ] [ inspect-tile ] set-action
+    dup [ raise ] [ raise ] set-action
+    [ drag-tile ] [ drag-tile ] set-action ;
 
-: <tile> ( child caption -- )
-    <caption> [
-        0 1 1 <pile>
-        [ add-gadget ] keep
-        [ add-gadget ] keep
-        line-border dup
-    ] keep set-caption-tile
-    dup tile-actions ;
+: tile-content ( child caption -- pile )
+    0 1 1 <pile>
+    [ >r <caption> r> add-gadget ] keep
+    [ add-gadget ] keep ;
+
+TUPLE: tile ;
+C: tile ( child caption -- tile )
+    [ f line-border swap set-delegate ] keep
+    [ >r tile-content r> add-gadget ] keep
+    [ tile-actions ] keep
+    dup delegate pref-size pick resize-gadget ;
+
+M: tile pref-size shape-size ;

library/ui/world.factor

@@ -8,13 +8,13 @@ prettyprint sdl stdio strings threads ;
 ! gadgets are contained in. The current world is stored in the
 ! world variable. The menu slot ensures that only one menu is
 ! open at any one time.
-TUPLE: world running? hand menu delegate ;
+TUPLE: world running? hand menu ;
 
 : <world-box> ( -- box )
     0 0 0 0 <plain-rect> <gadget> ;
 
 C: world ( -- world )
-    <world-box> over set-world-delegate
+    <world-box> over set-delegate
     t over set-world-running?
     dup <hand> over set-world-hand ;