From e8cbb5b2289eb8d0cf9eb9d448e4ae9104cf3a99 Mon Sep 17 00:00:00 2001
From: Sam Anklesaria <sam@Tintin.local>
Date: Sun, 7 Jun 2009 17:03:32 -0500
Subject: [PATCH] frp.layout works with books

---
 extra/persistency/persistency.factor |  5 +++--
 extra/ui/frp/layout/layout.factor    | 33 ++++++++++++++++++----------
 2 files changed, 24 insertions(+), 14 deletions(-)

diff --git a/extra/persistency/persistency.factor b/extra/persistency/persistency.factor
index 9a4b99c457..683318f98b 100644
--- a/extra/persistency/persistency.factor
+++ b/extra/persistency/persistency.factor
@@ -6,11 +6,12 @@ IN: persistency
 
 TUPLE: persistent id ;
 UNION: bool word POSTPONE: f ;
-PREDICATE: short-string < string length 100 <= ;
+UNION: short-string string ;
+
 : db-ize ( class -- db-class ) {
    { bool [ BOOLEAN ] }
-   { string [ TEXT ] }
    { short-string [ { VARCHAR 100 } ] }
+   { string [ TEXT ] }
    { float [ DOUBLE ] }
    { timestamp [ TIMESTAMP ] }
    { fixnum [ INTEGER ] }
diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor
index 17fc4a8abd..48cb0398e0 100644
--- a/extra/ui/frp/layout/layout.factor
+++ b/extra/ui/frp/layout/layout.factor
@@ -16,30 +16,39 @@ M: model -> dup , ;
 : <spacer> ( -- ) <gadget> 1 <layout> , ;
 
 SYMBOL: wordnames
-: layouts ( gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter
-   [ dup layout? [ f <layout> ] unless ] map ;
+: insert-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
+: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
+   [ [ dup layout? [ f <layout> ] unless ] map ] when ;
+: make-layout ( building sized? -- models words layouts ) [ swap layouts ] curry
+   [ { } make [ [ model? ] filter ] [ [ word? ] filter ] ] dip tri ; inline
+: handle-words ( words gadget -- gadget ) tuck
+   [ [ swap 2array ] curry wordnames get swap change-at ] curry each ;
 : <box> ( gadgets type -- track )
-   [ { } make [ [ model? ] filter ] [ [ word? ] filter ] [ layouts ] tri ] dip <track>
-   swap [ [ gadget>> ] [ size>> ] bi track-add ] each
-   tuck [ [ swap 2array ] curry wordnames get swap change-at ] curry each
+   [ t make-layout ] dip <track>
+   swap [ insert-layout ] each
+   handle-words
    swap [ <product> >>model ] unless-empty ; inline
 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
 : <vbox> ( gadgets -- track ) vertical <box> ; inline
 
-: <frp-book> ( gadgets -- book ) { } make [ gadget>> ] map f <book> ; inline
+: <frp-book> ( gadgets -- book ) f make-layout f <book> handle-words ; inline
 
 SYNTAX: $ CREATE-WORD dup [ , ] curry (( -- )) define-declared "$" expect
    word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ;
 
+: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
+
 GENERIC# insert-item 1 ( item location -- )
-M: gadget insert-item [ f <layout> ] dip insert-item ;
-M: layout insert-item first2 spin [ [ gadget>> ] [ size>> ] bi track-add ] keep gadget>> 
-   -rot [ but-last insert-nth ] change-children drop ;
-M: model insert-item first model>> swap add-connection ;
+M: gadget insert-item dup first book? [ first2 spin [ add-gadget ] keep insert-gadget ]
+   [ [ f <layout> ] dip insert-item ] if ;
+M: layout insert-item first2 spin [ insert-layout ] keep gadget>> insert-gadget ;
+M: model insert-item dup first book? [ "Books can't contain models" throw ]
+   [ first model>> swap add-connection ] if ;
 
 : insert-items ( makelist -- ) f swap [ dup word?
-      [ nip ] [ over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi ] if
-   ] each drop ;
+   [ nip ] [
+      over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi
+   ] if ] each drop ;
 
 : with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames
    [ { } make insert-items ] with-variable ; inline