From 588a04c62d55f4d776489790a8cbfea255c41956 Mon Sep 17 00:00:00 2001
From: Sam Anklesaria <sam@Tintin.local>
Date: Sat, 30 May 2009 10:58:32 -0500
Subject: [PATCH] ui.frp book gadgets

---
 basis/inverse/inverse.factor                  |  4 +++
 extra/darcs-ui                                |  2 +-
 extra/drills/drills.factor                    |  2 +-
 extra/ui/frp/gadgets/gadgets.factor           | 27 ++++++++++++++-----
 extra/ui/frp/layout/layout.factor             | 18 +++++--------
 extra/ui/frp/signals/signals.factor           |  2 +-
 extra/ui/gadgets/alerts/alerts.factor         |  4 +--
 .../ui/gadgets/book-extras/book-extras.factor | 13 ++++++---
 8 files changed, 44 insertions(+), 28 deletions(-)

diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index 7a9e821b37..70af955c77 100755
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -243,6 +243,10 @@ DEFER: __
 
 \ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
 
+! misc
+\ join 1 [ [ split ] curry ] define-pop-inverse
+\ split 1 [ [ join ] curry ] define-pop-inverse
+
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
     "predicate" word-prop [ dupd call assure ] curry ;
diff --git a/extra/darcs-ui b/extra/darcs-ui
index 98627a6ce4..4112107342 160000
--- a/extra/darcs-ui
+++ b/extra/darcs-ui
@@ -1 +1 @@
-Subproject commit 98627a6ce4a1ef23691cfb752fecf056e2eacd01
+Subproject commit 4112107342733e412dda8c1b747aa2ec1f27ddb6
diff --git a/extra/drills/drills.factor b/extra/drills/drills.factor
index 8251851511..1da1fcaa1d 100644
--- a/extra/drills/drills.factor
+++ b/extra/drills/drills.factor
@@ -11,7 +11,7 @@ IN: drills
 SYMBOLS: it startLength ;
 : big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
 : card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
 
 : show ( model -- gadget ) dup it set-global [ random ] <arrow>
    { [ [ first ] card ]
diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor
index f80ecf55dc..1fd6563082 100644
--- a/extra/ui/frp/gadgets/gadgets.factor
+++ b/extra/ui/frp/gadgets/gadgets.factor
@@ -1,15 +1,15 @@
-USING: accessors arrays kernel models ui.frp.signals ui.gadgets
-ui.gadgets.buttons ui.gadgets.buttons.private
-ui.gadgets.editors ui.gadgets.tables ;
+USING: accessors arrays kernel models monads ui.frp.signals ui.gadgets
+ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.editors
+ui.gadgets.tables sequences splitting models.illusion
+ui.gadgets.scrollers documents ;
 IN: ui.frp.gadgets
 
 TUPLE: frp-button < button hook ;
 : <frp-button> ( gadget -- button ) [
       [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
-      t swap set-control-value
+      dup set-control-value
    ] frp-button new-button f <basic> >>model ;
-
-: <frp-bevel-button> ( text -- button ) <frp-button> border-button-theme ;
+: <frp-border-button> ( text -- button ) <frp-button> border-button-theme ;
 
 TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ;
 M: frp-table column-titles column-titles>> ;
@@ -25,4 +25,17 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
 : <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
 : indexed ( table -- table ) f >>val-quot ;
 
-: <frp-field> ( -- field ) "" <model> <model-field> ;
\ No newline at end of file
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup multiple-selection?>>
+   [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
+   [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
+M: model-field output-model field-model>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: multiline-editor output-model model>> [ "\n" join ] <illusion> ;
+
+: <frp-field> ( -- field ) "" <model> <model-field> ;
+: <frp-editor> ( model -- editor ) [ "\n" split document new-model ] bind <multiline-editor> swap >>model ;
+
+IN: accessors
+M: frp-button text>> children>> first text>> ;
\ No newline at end of file
diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor
index 508f30b2ab..6e6689dce3 100644
--- a/extra/ui/frp/layout/layout.factor
+++ b/extra/ui/frp/layout/layout.factor
@@ -1,18 +1,10 @@
-USING: accessors fry kernel lexer math.parser models sequences
-ui.frp.signals ui.gadgets ui.gadgets.editors ui.gadgets.scrollers
-ui.gadgets.tables ui.gadgets.tracks ;
+USING: accessors fry kernel lexer math.parser models
+sequences ui.frp.signals ui.gadgets.tracks ui.gadgets
+ui.frp.gadgets ui.gadgets.books ;
 QUALIFIED: make
 IN: ui.frp.layout
 TUPLE: layout gadget width ; C: <layout> layout
 
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: table output-model dup multiple-selection?>>
-   [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
-   [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
-M: model-field output-model field-model>> ;
-M: scroller output-model viewport>> children>> first output-model ;
-
 GENERIC: , ( uiitem -- )
 M: gadget , f <layout> make:, ;
 M: model , activate-model ;
@@ -31,4 +23,6 @@ M: model -> dup , ;
 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
 : <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
 : <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
\ No newline at end of file
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
+
+: <frp-book> ( gadgets -- book ) { } make:make [ gadget>> ] map f <book> ; inline
\ No newline at end of file
diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor
index a08a49e329..9813165b1d 100644
--- a/extra/ui/frp/signals/signals.factor
+++ b/extra/ui/frp/signals/signals.factor
@@ -21,7 +21,7 @@ M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
 TUPLE: fold-model < multi-model oldval quot ;
 M: fold-model (model-changed) [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
    call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- signal ) 1array fold-model <multi-model> swap >>quot
+: <fold> ( model oldval quot -- signal ) rot 1array fold-model <multi-model> swap >>quot
    swap [ >>oldval ] [ >>value ] bi ;
 
 TUPLE: updater-model < multi-model values updates ;
diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor
index 8c04362b28..d7085302e0 100644
--- a/extra/ui/gadgets/alerts/alerts.factor
+++ b/extra/ui/gadgets/alerts/alerts.factor
@@ -13,7 +13,7 @@ IN: ui.gadgets.alerts
 :: ask-user* ( model string -- model' )
    [ [let | lbl  [ string <label>  T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
             fldm [ <frp-field> ->% 1 ]
-            btn  [ "okay" <frp-bevel-button> model >>model ] |
+            btn  [ "okay" <frp-border-button> model >>model ] |
          btn -> [ fldm swap <updates> ]
                 [ [ drop lbl close-window ] $> , ] bi
    ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
@@ -23,7 +23,7 @@ IN: ui.gadgets.alerts
 MACRO: ask-buttons ( buttons -- quot ) dup length [
       [ swap
          [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
-         [ [ <frp-bevel-button> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+         [ [ <frp-border-button> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
          "" open-window
       ] dip firstn
    ] 2curry ;
\ No newline at end of file
diff --git a/extra/ui/gadgets/book-extras/book-extras.factor b/extra/ui/gadgets/book-extras/book-extras.factor
index 9e94747919..41e16e0f9f 100644
--- a/extra/ui/gadgets/book-extras/book-extras.factor
+++ b/extra/ui/gadgets/book-extras/book-extras.factor
@@ -5,8 +5,13 @@ IN: ui.gadgets.book-extras
 : |<< ( book -- ) 0 swap set-control-value ;
 : next ( book -- ) model>> [ 1 + ] change-model ;
 : prev ( book -- ) model>> [ 1 - ] change-model ;
-: (book-t) ( quot -- quot ) '[ : owner ( gadget -- book ) parent>> dup book? [ owner ] unless ; owner @ ] ;
+: owner ( gadget -- book ) parent>> dup book? [ owner ] unless ;
+: (book-t) ( quot -- quot ) '[ owner @ ] ;
 : <book-btn> ( label quot -- button ) (book-t) <button> ;
-: <book-bevel-btn> ( label quot -- button ) (book-t) <border-button> ;
-: >>> ( label -- button ) [ next ] <book-btn> ;
-: <<< ( label -- button ) [ prev ] <book-btn> ;
\ No newline at end of file
+: <book-border-btn> ( label quot -- button ) (book-t) <border-button> ;
+: >>> ( gadget -- ) owner next ;
+: <<< ( gadget -- ) owner prev ;
+: go-to ( gadget number -- ) swap owner model>> set-model ;
+
+: <forward-btn> ( label -- button ) [ >>> ] <button> ;
+: <backward-btn> ( label -- button ) [ <<< ] <button> ;