steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Browser now makes more efficient use of screen space; new MVC/reactive programming framework

darcs
slava 2006-06-27 07:26:52 +00:00
parent e94d38c31b
commit f47986dcff
15 changed files with 243 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
library/bootstrap/boot-stage1.factor
View File

@ -171,6 +171,7 @@ sequences vectors words ;
"/library/ui/freetype/freetype.factor"
"/library/ui/freetype/freetype-gl.factor"
"/library/ui/models.factor"
"/library/ui/backend.factor"
"/library/ui/timers.factor"
"/library/ui/gadgets.factor"
@ -180,10 +181,11 @@ sequences vectors words ;
"/library/ui/gadgets/frames.factor"
"/library/ui/world.factor"
"/library/ui/paint.factor"
"/library/ui/gestures.factor"
"/library/ui/gadgets/controls.factor"
"/library/ui/gadgets/grid-lines.factor"
"/library/ui/gadgets/theme.factor"
"/library/ui/gadgets/labels.factor"
"/library/ui/gestures.factor"
"/library/ui/gadgets/borders.factor"
"/library/ui/gadgets/buttons.factor"
"/library/ui/gadgets/tiles.factor"
@ -196,7 +198,7 @@ sequences vectors words ;
"/library/ui/gadgets/incremental.factor"
"/library/ui/gadgets/paragraphs.factor"
"/library/ui/gadgets/panes.factor"
"/library/ui/gadgets/tabs.factor"
"/library/ui/gadgets/books.factor"
"/library/ui/gadgets/outliner.factor"
"/library/ui/ui.factor"
"/library/ui/gadgets/presentations.factor"

29
library/ui/gadgets/books.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-books
USING: gadgets gadgets-controls gadgets-panes gadgets-scrolling
kernel sequences ;
TUPLE: book page pages ;
: show-page ( n book -- )
dup book-page unparent
[ book-pages nth ] keep
[ set-book-page ] 2keep
add-gadget ;
C: book ( pages -- book )
dup delegate>gadget
[ set-book-pages ] keep
0 over show-page ;
: <book-control> ( model pages -- book )
<book> [ show-page ] <control> ;
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
M: book layout* ( book -- )
dup rect-dim swap book-page set-gadget-dim ;
: make-book ( model obj quots -- assoc )
[ make-pane <scroller> ] map-with <book-control> ;

3
library/ui/gadgets/borders.factor
View File

@ -26,3 +26,6 @@ M: border pref-dim* ( border -- dim )
M: border layout* ( border -- )
dup layout-border-loc layout-border-dim ;
: <spacing> ( -- gadget )
<gadget> { 10 10 } over set-gadget-dim ;

18
library/ui/gadgets/buttons.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-buttons
USING: gadgets gadgets-borders gadgets-theme generic io kernel
math namespaces sequences styles threads ;
USING: gadgets gadgets-borders gadgets-controls gadgets-labels
gadgets-theme generic io kernel math models namespaces sequences
strings styles threads ;
TUPLE: button rollover? pressed? selected? quot ;
@ -35,8 +36,12 @@ M: button gadget-gestures
{ T{ mouse-enter } [ button-update ] }
} ;
GENERIC: >label ( obj -- gadget )
M: string >label <label> ;
M: object >label ;
C: button ( gadget quot -- button )
rot <default-border> over set-gadget-delegate
rot >label <default-border> over set-gadget-delegate
[ set-button-quot ] keep ;
: <highlight-button> ( gadget quot -- button )
@ -86,3 +91,10 @@ M: button-paint draw-interior ( button paint -- )
M: button-paint draw-boundary ( button paint -- )
button-paint draw-boundary ;
: <radio-control> ( model value gadget -- gadget )
over [ swap control-model set-model ] curry <bevel-button>
swap [ swap >r = r> set-button-selected? ] curry <control> ;
: <radio-box> ( model assoc -- gadget )
[ first2 <radio-control> ] map-with make-shelf ;

22
library/ui/gadgets/controls.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-controls
USING: gadgets kernel models ;
TUPLE: control model quot ;
C: control ( model gadget quot -- gadget )
[ set-control-quot ] keep
[ set-gadget-delegate ] keep
[ set-control-model ] keep
dup model-changed ;
M: control add-notify*
dup control-model add-connection ;
M: control remove-notify*
dup control-model remove-connection ;
M: control model-changed ( gadget -- )
[ control-model model-value ] keep
[ dup control-quot call ] keep relayout ;

16
library/ui/gadgets/labels.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-labels
USING: arrays freetype gadgets gadgets-theme generic hashtables
io kernel math namespaces opengl sequences styles ;
USING: arrays freetype gadgets gadgets-controls gadgets-theme
generic hashtables io kernel math namespaces opengl sequences
styles ;
! A label gadget draws a string.
TUPLE: label text font color ;
@ -12,10 +13,6 @@ C: label ( text -- label )
[ set-label-text ] keep
dup label-theme ;
: set-label-text* ( text label -- )
2dup label-text =
[ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
: label-size ( gadget text -- dim )
dup label-font lookup-font dup font-height >r
swap label-text string-width r> 2array ;
@ -27,3 +24,6 @@ M: label pref-dim* ( label -- dim ) label-size ;
dup label-font swap label-text draw-string ;
M: label draw-gadget* ( label -- ) draw-label ;
: <label-control> ( model -- gadget )
"" <label> [ set-label-text ] <control> ;

12
library/ui/gadgets/panes.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-panes
USING: arrays gadgets gadgets-buttons gadgets-editors
gadgets-frames gadgets-grids gadgets-labels gadgets-scrolling
gadgets-theme generic hashtables io kernel line-editor math
namespaces prettyprint sequences strings styles threads ;
USING: arrays gadgets gadgets-buttons gadgets-controls
gadgets-editors gadgets-frames gadgets-grids gadgets-labels
gadgets-scrolling gadgets-theme generic hashtables io kernel
line-editor math namespaces prettyprint sequences strings styles
threads ;
TUPLE: pane output active current input prototype continuation ;
@ -144,3 +145,6 @@ M: pane with-stream-style ( quot style pane -- )
: make-pane ( quot -- pane )
#! Execute the quotation with output to an output-only pane.
<pane> [ swap with-pane ] keep ; inline
: <pane-control> ( model quot -- pane )
[ with-pane ] curry <pane> swap <control> ;

77
library/ui/gadgets/tabs.factor
View File

@ -1,77 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-tabs
USING: arrays gadgets gadgets-buttons gadgets-frames
gadgets-grids gadgets-labels gadgets-panes gadgets-scrolling
gadgets-theme kernel sequences ;
TUPLE: book page pages ;
: show-page ( gadget book -- )
dup book-page unparent [ set-book-page ] 2keep add-gadget ;
C: book ( pages -- book )
dup delegate>gadget
[ set-book-pages ] keep
dup book-pages first over show-page ;
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
M: book layout* ( book -- )
dup rect-dim swap book-page set-gadget-dim ;
TUPLE: radio-box value buttons quot ;
: update-selection ( radio-box -- )
dup radio-box-buttons [
second f swap set-button-selected?
] each
dup radio-box-value over radio-box-buttons assoc
t swap set-button-selected?
dup dup radio-box-quot call
relayout-1 ;
: find-radio-box [ radio-box? ] find-parent ;
: set-radio-box-value* ( value gadget -- )
[ set-radio-box-value ] keep update-selection ;
: select-value ( button value -- )
swap find-radio-box set-radio-box-value* ;
: <radio-button> ( string value -- gadget )
[ select-value ] curry >r <label> r> <bevel-button> ;
C: radio-box ( assoc quot -- gadget )
{ 1 0 } over delegate>pack
[ set-radio-box-quot ] keep
>r [ first2 tuck <radio-button> 2array ] map r>
[ >r [ second ] map r> add-gadgets ] 2keep
[ set-radio-box-buttons ] 2keep
[ >r first first r> set-radio-box-value* ] keep
dup highlight-theme ;
TUPLE: tabs buttons book ;
C: tabs dup delegate>frame ;
: find-tabs [ tabs? ] find-parent ;
: update-tabs ( tabs -- )
dup tabs-buttons radio-box-value swap tabs-book show-page ;
: make-tabs ( assoc -- gadget )
[ find-tabs [ update-tabs ] when* ] <radio-box> ;
: set-tabs ( assoc tabs -- )
{
{ [ dup [ second ] map <book> ] set-tabs-book @center }
{ [ make-tabs ] set-tabs-buttons @top }
} build-grid ;
: make-pages ( obj assoc -- assoc )
[ first2 swapd make-pane <scroller> 2array ] map-with ;
: set-pages ( obj assoc tabs -- ) >r make-pages r> set-tabs ;
: <pages> ( obj assoc -- tabs ) <tabs> [ set-pages ] keep ;

8
library/ui/gestures.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets
USING: gadgets-labels hashtables kernel math namespaces queues
sequences words ;
USING: hashtables kernel math models namespaces queues sequences
words ;
GENERIC: gadget-gestures ( gadget -- hash )
@ -139,9 +139,9 @@ V{ } clone hand-buttons set-global
: relevant-help ( seq -- help )
[ gadget-help ] map [ ] find nip ;
: show-message ( string/f -- )
: show-message ( string/f world -- )
#! Show a message in the status bar.
world-status [ set-label-text* ] [ drop ] if* ;
world-status set-model ;
: update-help ( -- )
#! Update mouse-over help message.

78
library/ui/models.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: models
USING: generic kernel sequences ;
TUPLE: model connections value dependencies ;
M: model = eq? ;
C: model ( value -- model )
[ set-model-value ] keep
V{ } clone over set-model-connections
V{ } clone over set-model-dependencies ;
: add-dependency ( model model -- )
model-dependencies push ;
: remove-dependency ( model model -- )
model-dependencies delete ;
DEFER: add-connection
: activate-model ( model -- )
dup model-dependencies [ add-connection ] each-with ;
DEFER: remove-connection
: deactivate-model ( model -- )
dup model-dependencies [ remove-connection ] each-with ;
GENERIC: model-changed ( model -- )
: add-connection ( obj model -- )
dup model-connections empty? [ dup activate-model ] when
model-connections push ;
: remove-connection ( obj model -- )
[ model-connections delete ] keep
dup model-connections empty? [ dup deactivate-model ] when
drop ;
: set-model ( value model -- )
2dup model-value = [
2drop
] [
[ set-model-value ] keep
model-connections [ model-changed ] each
] if ;
: change-model ( model quot -- )
over >r >r model-value r> call r> set-model ; inline
: delegate>model ( obj -- )
f <model> swap set-delegate ;
TUPLE: filter model quot ;
C: filter ( model quot -- filter )
dup delegate>model
[ set-filter-quot ] keep
[ set-filter-model ] 2keep
[ add-dependency ] keep
dup model-changed ;
M: filter model-changed ( filter -- )
dup filter-model model-value over filter-quot call
swap set-model ;
TUPLE: compose ;
C: compose ( models -- compose )
dup delegate>model
[ set-model-dependencies ] keep
dup model-changed ;
M: compose model-changed ( compose -- )
dup model-dependencies [ model-value ] map
swap set-model ;

98
library/ui/tools/browser.factor
View File

@ -1,44 +1,51 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-browser
USING: gadgets gadgets-buttons gadgets-labels gadgets-panes
USING: arrays gadgets gadgets-borders gadgets-buttons
gadgets-frames gadgets-labels gadgets-panes
gadgets-presentations gadgets-scrolling gadgets-search
gadgets-tabs gadgets-theme gadgets-tiles gadgets-tracks generic
hashtables help inspector kernel math prettyprint sequences
words ;
gadgets-books gadgets-theme gadgets-tiles gadgets-tracks generic
hashtables help inspector kernel math models namespaces
prettyprint sequences words ;
TUPLE: browser-track showing builder closer ;
TUPLE: asset-track showing builder closer ;
C: browser-track ( builder closer -- gadget )
C: asset-track ( builder closer -- gadget )
{ 0 1 } <track> over set-delegate
H{ } clone over set-browser-track-showing
[ set-browser-track-closer ] keep
[ set-browser-track-builder ] keep ;
H{ } clone over set-asset-track-showing
[ set-asset-track-closer ] keep
[ set-asset-track-builder ] keep ;
: showing-asset? ( asset track -- ? )
browser-track-showing hash-member? ;
asset-track-showing hash-member? ;
: (show-asset) ( gadget asset track -- )
[ browser-track-showing set-hash ] 3keep nip track-add ;
[ asset-track-showing set-hash ] 3keep nip track-add ;
: show-asset ( asset track -- )
2dup showing-asset? [
2drop
] [
[ browser-track-builder call ] 2keep (show-asset)
[ asset-track-builder call ] 2keep (show-asset)
] if ;
: hide-asset ( asset track -- )
[ dup browser-track-closer call ] 2keep
[ browser-track-showing remove-hash* ] keep track-remove ;
[ dup asset-track-closer call ] 2keep
[ asset-track-showing remove-hash* ] keep track-remove ;
TUPLE: browser vocab-track word-track ;
TUPLE: browser track page ;
TUPLE: browser-tracks vocabs words ;
: browser-vocab-track browser-track browser-tracks-vocabs ;
: browser-word-track browser-track browser-tracks-words ;
: find-browser [ browser? ] find-parent ;
: close-tile ( tile -- )
dup gadget-parent [
browser-track-showing hash>alist rassoc
asset-track-showing hash>alist rassoc
] keep hide-asset ;
: <browser-tile> ( gadget title -- gadget )
@ -49,16 +56,20 @@ TUPLE: browser vocab-track word-track ;
DEFER: show-vocab
: <word-pages> ( word -- tabs )
: browser-tabs
{
{ "Definition" [ see ] }
{ "Documentation" [ help ] }
{ "Calls in" [ usage. ] }
{ "Properties" [ word-props describe ] }
} <pages> ;
{ "Definition" [ see ] }
{ "Calls in" [ usage. ] }
{ "Properties" [ word-props describe ] }
} ;
: <word-view> ( word -- gadget )
[ <word-pages> ] keep word-name <browser-tile> ;
: <word-book> ( model word -- book )
browser-tabs [ second ] map make-book ;
: <word-view> ( word browser -- gadget )
browser-page swap [ <word-book> ] keep
word-name <browser-tile> ;
: show-word ( word browser -- )
over word-vocabulary over show-vocab
@ -71,7 +82,7 @@ DEFER: show-vocab
2dup showing-word? [ hide-word ] [ show-word ] if ;
: <word-button> ( word -- gadget )
dup word-name <label> swap
dup word-name swap
[ swap find-browser toggle-word ] curry
<roll-button> ;
@ -89,7 +100,7 @@ DEFER: show-vocab
: hide-vocab-words ( vocab browser -- )
[
browser-word-track browser-track-showing hash-keys
browser-word-track asset-track-showing hash-keys
[ word-vocabulary = ] subset-with
] keep swap [ swap hide-word ] each-with ;
@ -100,8 +111,7 @@ DEFER: show-vocab
2dup showing-vocab? [ hide-vocab ] [ show-vocab ] if ;
: <vocab-button> ( vocab -- gadget )
dup <label> swap
[ swap find-browser toggle-vocab ] curry
dup [ swap find-browser toggle-vocab ] curry
<roll-button> ;
: <vocabs> ( -- gadget )
@ -110,18 +120,40 @@ DEFER: show-vocab
: <vocab-track> ( -- track )
[ <vocab-view> ] [ find-browser hide-vocab-words ]
<browser-track> ;
<asset-track> ;
: <word-track> ( -- track )
[ <word-view> ] [ 2drop ] <browser-track> ;
: <word-track> ( browser -- track )
[ <word-view> ] curry [ 2drop ] <asset-track> ;
C: browser ( -- browser )
C: browser-tracks ( browser -- browser-track )
{
{ [ <vocabs> ] f 1/5 }
{ [ <vocab-track> ] set-browser-vocab-track 1/5 }
{ [ <word-track> ] set-browser-word-track 3/5 }
{ [ <vocab-track> ] set-browser-tracks-vocabs 1/5 }
{ [ <word-track> ] set-browser-tracks-words 3/5 }
} { 1 0 } make-track* ;
: <browser-tabs> ( browser -- tabs )
browser-page
browser-tabs dup length [ swap first 2array ] 2map
<radio-box> ;
: make-toolbar ( quot -- gadget )
{ } make make-shelf dup highlight-theme ; inline
: <browser-toolbar> ( browser -- toolbar )
[
<browser-tabs> ,
<spacing> ,
"Apropos" [ drop apropos-window ] <bevel-button> ,
] make-toolbar ;
C: browser ( -- browser )
0 <model> over set-browser-page
dup dup {
{ [ <browser-toolbar> ] f @top }
{ [ <browser-tracks> ] set-browser-track @center }
} make-frame* ;
M: browser gadget-title drop "Browser" ;
: browser-window ( -- ) <browser> open-window ;

2
library/ui/tools/help.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets-help
USING: gadgets gadgets-panes gadgets-presentations
gadgets-scrolling gadgets-search gadgets-tabs gadgets-tiles
gadgets-scrolling gadgets-search gadgets-tiles
gadgets-tracks help io kernel sequences words ;
TUPLE: history pane seq ;

2
library/ui/tools/launchpad.factor
View File

@ -8,7 +8,7 @@ gadgets-theme generic help inspector io kernel memory namespaces
prettyprint sequences words ;
: <launchpad> ( menu -- )
[ first2 >r <label> [ drop ] r> append <bevel-button> ] map
[ first2 [ drop ] append <bevel-button> ] map
make-pile 1 over set-pack-fill { 5 5 } over set-pack-gap
<default-border> dup highlight-theme ;

2
library/ui/ui.factor
View File

@ -83,7 +83,7 @@ C: titled-gadget ( gadget title -- )
[ >r gadget-title r> set-title ] [ 2drop ] if ;
: open-window ( gadget -- )
<status-bar> <world> dup prefer open-window* ;
<world> dup prefer open-window* ;
: open-titled-window ( gadget title -- )
<titled-gadget> open-window ;

10
library/ui/world.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets
USING: arrays errors freetype gadgets-frames generic hashtables
kernel math namespaces opengl sequences ;
kernel math models namespaces opengl sequences ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. There is one world per top-level
@ -22,11 +22,9 @@ TUPLE: world gadget status focus focused? fonts handle loc ;
DEFER: request-focus
C: world ( gadget status -- world )
{
{ [ ] set-world-status @bottom }
{ [ ] set-world-gadget @center }
} make-frame*
C: world ( gadget -- world )
f <model> over set-world-status
{ { [ ] set-world-gadget @center } } make-frame*
t over set-gadget-root?
H{ } clone over set-world-fonts
dup world-gadget request-focus