New remove-hash* word; UI refactorings; adding new Whisker-style word browser
slava
parent
49d2eed42a
commit
8cdc10abdb
|
|
@ -1,3 +1,5 @@
|
|||
- redefine generic as tuple constructor -- still appears generic
|
||||
|
||||
- remove F_USERENV rel
|
||||
- update walker for new interpreter
|
||||
- quotations should store their originating word
|
||||
|
|
@ -33,16 +35,13 @@
|
|||
|
||||
+ ui/help:
|
||||
|
||||
- make-frame should compile
|
||||
- track:
|
||||
- don't allow negative dimensions
|
||||
- support removing items
|
||||
- fix round-off error
|
||||
- zooming doesn't work
|
||||
- implement handlers for open, quit events, and whatever else
|
||||
- fix top level window positioning
|
||||
- changing window titles
|
||||
- reimplement clicking input
|
||||
- polish OS X menu bar code
|
||||
- clicks sent twice
|
||||
- speed up ideas:
|
||||
- only do clipping for certain gadgets
|
||||
|
|
@ -51,8 +50,12 @@
|
|||
- x11 input methods
|
||||
- x11 title bars are funny
|
||||
- cocoa:
|
||||
- need to flush callbacks
|
||||
- don't multiplex in the event loop if there is no pending i/o
|
||||
- horizontal scrolling
|
||||
- zooming doesn't work
|
||||
- implement handlers for open, quit events, and whatever else
|
||||
- polish OS X menu bar code
|
||||
- fix mouse-overs...
|
||||
- display lists
|
||||
- saving the image should save window configuration
|
||||
|
|
|
|||
|
|
@ -193,10 +193,11 @@ vectors words ;
|
|||
"/library/ui/outliner.factor"
|
||||
"/library/ui/environment.factor"
|
||||
"/library/ui/listener.factor"
|
||||
"/library/ui/presentations.factor"
|
||||
"/library/ui/inspector.factor"
|
||||
"/library/ui/browser.factor"
|
||||
"/library/ui/apropos.factor"
|
||||
"/library/ui/launchpad.factor"
|
||||
"/library/ui/presentations.factor"
|
||||
|
||||
"/library/continuations.facts"
|
||||
"/library/errors.facts"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
USING: cocoa compiler gadgets gadgets-launchpad gadgets-layouts
|
||||
gadgets-listener kernel memory objc objc-FactorCallback
|
||||
objc-NSApplication objc-NSMenu objc-NSMenuItem objc-NSObject
|
||||
objc-NSWindow sequences strings words ;
|
||||
USING: cocoa compiler gadgets gadgets-browser gadgets-launchpad
|
||||
gadgets-layouts gadgets-listener kernel memory objc
|
||||
objc-FactorCallback objc-NSApplication objc-NSMenu
|
||||
objc-NSMenuItem objc-NSObject objc-NSWindow sequences strings
|
||||
words ;
|
||||
IN: gadgets-cocoa
|
||||
|
||||
! -------------------------------------------------------------------------
|
||||
|
|
@ -107,9 +108,9 @@ DEFER: described-menu
|
|||
{ "Listener" listener-window "n" }
|
||||
{ "Run..." menu-run-file "o" }
|
||||
{ }
|
||||
{ "Browser" browser-window "b" }
|
||||
{ "Apropos" apropos-window "r" }
|
||||
{ "Vocabularies" vocabs-window "" }
|
||||
{ "Globals" global-window "" }
|
||||
{ "Globals" globals-window "" }
|
||||
{ "Memory" memory-window "" }
|
||||
{ }
|
||||
{ "Save Image" save "s" }
|
||||
|
|
|
|||
|
|
@ -143,6 +143,9 @@ IN: hashtables
|
|||
3drop
|
||||
] if-key ;
|
||||
|
||||
: remove-hash* ( key hash -- oldvalue )
|
||||
[ hash ] 2keep remove-hash ;
|
||||
|
||||
: hash-size ( hash -- n )
|
||||
dup hash-count swap hash-deleted - ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -71,11 +71,15 @@ SYMBOL: c-types
|
|||
: init-c-type ( name vocab -- )
|
||||
over define-pointer define-nth ;
|
||||
|
||||
: define-primitive-type ( quot name -- )
|
||||
: (define-primitive-type) ( quot name -- )
|
||||
[ define-c-type ] keep "alien"
|
||||
2dup init-c-type
|
||||
2dup define-deref
|
||||
over c-setter [ 2dup define-set-nth define-out ] when ;
|
||||
|
||||
: define-primitive-type ( quot name -- )
|
||||
[ (define-primitive-type) ] keep dup c-setter
|
||||
[ "alien" 2dup define-set-nth define-out ] [ drop ] if ;
|
||||
|
||||
: typedef ( old new -- )
|
||||
over "*" append over "*" append (typedef) (typedef) ;
|
||||
|
|
|
|||
|
|
@ -103,25 +103,27 @@ USING: alien compiler kernel kernel-internals math namespaces ;
|
|||
|
||||
[
|
||||
[ alien-unsigned-cell <alien> alien>string ] "getter" set
|
||||
[ >r >r alien-address r> r> set-alien-unsigned-cell ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_c_string" "boxer-function" set
|
||||
"unbox_c_string" "unboxer-function" set
|
||||
] "char*" define-primitive-type
|
||||
] "char*" (define-primitive-type)
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 ] "getter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
[ >r >r alien-address r> r> set-alien-unsigned-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_utf16_string" "boxer-function" set
|
||||
"unbox_utf16_string" "unboxer-function" set
|
||||
] "ushort*" define-primitive-type
|
||||
] "ushort*" (define-primitive-type)
|
||||
|
||||
[
|
||||
[ alien-unsigned-4 zero? not ] "getter" set
|
||||
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_boolean" "boxer-function" set
|
||||
"unbox_boolean" "unboxer-function" set
|
||||
] "bool" define-primitive-type
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ C: apropos-gadget ( -- )
|
|||
{
|
||||
{ [ <pane> <scroller> ] set-apropos-gadget-scroller @center }
|
||||
{ [ <apropos-prompt> ] set-apropos-gadget-input @top }
|
||||
} make-frame ;
|
||||
} make-frame* ;
|
||||
|
||||
M: apropos-gadget pref-dim* drop { 350 200 0 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,122 +1,114 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-browser
|
||||
USING: arrays gadgets gadgets-buttons gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
|
||||
generic hashtables help inspector kernel math namespaces
|
||||
prettyprint sequences words ;
|
||||
USING: gadgets gadgets-buttons gadgets-inspector gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-presentations
|
||||
gadgets-scrolling gadgets-theme gadgets-tracks generic
|
||||
hashtables help inspector kernel math prettyprint sequences
|
||||
words ;
|
||||
|
||||
SYMBOL: components
|
||||
|
||||
H{ } clone components set-global
|
||||
|
||||
: get-components ( class -- assoc )
|
||||
components get-global hash [
|
||||
{ { "Slots" [ describe ] } }
|
||||
] unless* ;
|
||||
|
||||
{
|
||||
{ "Definition" [ help ] }
|
||||
{ "Calls in" [ usage. ] }
|
||||
{ "Calls out" [ uses. ] }
|
||||
{ "Links in" [ links-in. ] }
|
||||
{ "Links out" [ links-out. ] }
|
||||
{ "Vocabulary" [ word-vocabulary words. ] }
|
||||
{ "Properties" [ word-props describe ] }
|
||||
} \ word components get-global set-hash
|
||||
|
||||
{
|
||||
{ "Article" [ help ] }
|
||||
{ "Links in" [ links-in. ] }
|
||||
{ "Links out" [ links-out. ] }
|
||||
} \ link components get-global set-hash
|
||||
|
||||
{
|
||||
{ "Call stack" [ continuation-call callstack. ] }
|
||||
{ "Data stack" [ continuation-data stack. ] }
|
||||
{ "Retain stack" [ continuation-retain stack. ] }
|
||||
{ "Name stack" [ continuation-name stack. ] }
|
||||
{ "Catch stack" [ continuation-catch stack. ] }
|
||||
} \ continuation components get-global set-hash
|
||||
|
||||
TUPLE: book page pages ;
|
||||
|
||||
: show-page ( key book -- )
|
||||
dup book-page unparent
|
||||
[ book-pages assoc ] keep
|
||||
[ set-book-page ] 2keep
|
||||
add-gadget ;
|
||||
|
||||
C: book ( pages -- book )
|
||||
dup delegate>gadget
|
||||
[ set-book-pages ] 2keep
|
||||
[ >r first first r> show-page ] keep ;
|
||||
|
||||
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rect-dim swap book-page set-gadget-dim ;
|
||||
|
||||
: component-pages ( obj -- assoc )
|
||||
dup class get-components
|
||||
[ first2 swapd make-pane <scroller> 2array ] map-with ;
|
||||
|
||||
: <tab> ( name book -- button )
|
||||
dupd [ show-page drop ] curry curry
|
||||
>r <label> r> <bevel-button> ;
|
||||
|
||||
: tabs ( assoc book gadget -- )
|
||||
>r swap [ first swap <tab> ] map-with r> add-gadgets ;
|
||||
|
||||
TUPLE: browser object history tabs ;
|
||||
|
||||
: save-current ( browser -- )
|
||||
dup browser-object swap browser-history push ;
|
||||
|
||||
: browse ( obj browser -- )
|
||||
[ set-browser-object ] 2keep
|
||||
dup browser-tabs clear-gadget
|
||||
>r component-pages dup <book> r>
|
||||
[ @center frame-add ] 2keep browser-tabs tabs ;
|
||||
TUPLE: browser
|
||||
vocabs
|
||||
vocab-track showing-vocabs
|
||||
word-track showing-words ;
|
||||
|
||||
: find-browser [ browser? ] find-parent ;
|
||||
|
||||
: browse-back ( browser -- )
|
||||
dup browser-history dup empty?
|
||||
[ 2drop ] [ pop swap browse ] if ;
|
||||
: <title-border> ( gadget title -- gadget )
|
||||
{
|
||||
{ [ <label> dup highlight-theme ] f @top }
|
||||
{ [ ] f @center }
|
||||
} make-frame ;
|
||||
|
||||
C: browser ( obj -- browser )
|
||||
V{ } clone over set-browser-history
|
||||
dup delegate>frame [
|
||||
"<" <label> [ find-browser browse-back ] <bevel-button> ,
|
||||
<shelf> dup pick set-browser-tabs ,
|
||||
] { } make make-shelf dup highlight-theme
|
||||
over @top frame-add
|
||||
[ browse ] keep ;
|
||||
: showing-word? ( word browser -- ? )
|
||||
browser-showing-words hash-member? ;
|
||||
|
||||
TUPLE: browser-button object ;
|
||||
: (show-word) ( gadget word browser -- )
|
||||
[ browser-showing-words set-hash ] 3keep nip
|
||||
browser-word-track track-add ;
|
||||
|
||||
: browser-window ( obj -- ) <browser> "Browser" open-window ;
|
||||
DEFER: show-vocab
|
||||
|
||||
: browser-button-action ( button -- )
|
||||
[ browser-button-object ] keep find-browser [
|
||||
find-browser dup save-current browse
|
||||
: show-word ( word browser -- )
|
||||
2dup showing-word? [
|
||||
2drop
|
||||
] [
|
||||
browser-window
|
||||
] if* ;
|
||||
over word-vocabulary over show-vocab
|
||||
>r [ f <inspector> ] keep r> (show-word)
|
||||
] if ;
|
||||
|
||||
: browser-button-gestures ( gadget -- )
|
||||
: hide-word ( word browser -- )
|
||||
[ browser-showing-words remove-hash* ] keep
|
||||
browser-word-track track-remove ;
|
||||
|
||||
: toggle-word ( word browser -- )
|
||||
2dup showing-word? [ hide-word ] [ show-word ] if ;
|
||||
|
||||
: <word-button> ( word -- gadget )
|
||||
dup word-name <label> swap
|
||||
[ swap find-browser toggle-word ] curry
|
||||
<roll-button> ;
|
||||
|
||||
: <vocab> ( vocab -- gadget )
|
||||
[
|
||||
[ browser-button-object browser-window ] if-clicked
|
||||
] T{ button-up f 3 } set-action ;
|
||||
words natural-sort
|
||||
[ <word-button> ] map make-pile <scroller>
|
||||
] keep <title-border> ;
|
||||
|
||||
C: browser-button ( gadget object -- button )
|
||||
[ set-browser-button-object ] keep
|
||||
: showing-vocab? ( vocab browser -- ? )
|
||||
browser-showing-vocabs hash-member? ;
|
||||
|
||||
: (show-vocab) ( gadget vocab browser -- )
|
||||
[ browser-showing-vocabs set-hash ] 3keep nip
|
||||
browser-vocab-track track-add ;
|
||||
|
||||
: show-vocab ( vocab browser -- )
|
||||
2dup showing-vocab?
|
||||
[ 2drop ] [ >r [ <vocab> ] keep r> (show-vocab) ] if ;
|
||||
|
||||
: hide-vocab-words ( vocab browser -- )
|
||||
[
|
||||
>r [ browser-button-action ] <roll-button> r>
|
||||
set-gadget-delegate
|
||||
] keep
|
||||
dup browser-button-gestures ;
|
||||
browser-showing-words hash-keys
|
||||
[ word-vocabulary = ] subset-with
|
||||
] keep swap [ swap hide-word ] each-with ;
|
||||
|
||||
M: browser-button gadget-help ( button -- string )
|
||||
browser-button-object dup word? [ synopsis ] [ summary ] if ;
|
||||
: hide-vocab ( vocab browser -- )
|
||||
2dup hide-vocab-words
|
||||
[ browser-showing-vocabs remove-hash* ] keep
|
||||
browser-vocab-track track-remove ;
|
||||
|
||||
: toggle-vocab ( word browser -- )
|
||||
2dup showing-vocab? [ hide-vocab ] [ show-vocab ] if ;
|
||||
|
||||
: <vocab-button> ( vocab -- gadget )
|
||||
dup <label> swap
|
||||
[ swap find-browser toggle-vocab ] curry
|
||||
<roll-button> ;
|
||||
|
||||
: <vocabs> ( -- gadget )
|
||||
vocabs [ <vocab-button> ] map make-pile <scroller>
|
||||
"Vocabularies" <title-border> ;
|
||||
|
||||
: add-vocabs ( vocabs browser -- )
|
||||
[ set-browser-vocabs ] 2keep track-add ;
|
||||
|
||||
: add-vocab-track ( track browser -- )
|
||||
[ set-browser-vocab-track ] 2keep track-add ;
|
||||
|
||||
: add-word-track ( track browser -- )
|
||||
[ set-browser-word-track ] 2keep track-add ;
|
||||
|
||||
C: browser ( -- browser )
|
||||
H{ } clone over set-browser-showing-vocabs
|
||||
H{ } clone over set-browser-showing-words
|
||||
<y-track> over set-delegate
|
||||
<vocabs> over add-vocabs
|
||||
<x-track> over add-vocab-track
|
||||
<x-track> over add-word-track
|
||||
{ 1/4 1/4 1/2 } over set-track-sizes ;
|
||||
|
||||
: browser-window ( word -- )
|
||||
<browser> [ "Browser" open-window ] keep show-word ;
|
||||
|
||||
M: word show-object ( word button -- )
|
||||
find-browser [ show-word ] [ browser-window ] if* ;
|
||||
|
|
|
|||
|
|
@ -95,8 +95,8 @@ M: frame layout* ( frame -- dim )
|
|||
#! the loc is @center, @top, etc.
|
||||
[ swap frame set [ frame-add-spec ] each ] with-scope ;
|
||||
|
||||
: make-frame ( gadget specs -- gadget )
|
||||
#! Specs is an array of triples { quot setter loc }.
|
||||
#! The setter has stack effect ( new gadget -- ),
|
||||
#! the loc is @center, @top, etc.
|
||||
: make-frame ( specs -- gadget )
|
||||
<frame> [ swap build-frame ] keep ;
|
||||
|
||||
: make-frame* ( gadget specs -- gadget )
|
||||
over [ delegate>frame build-frame ] keep ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays gadgets gadgets-buttons gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-presentations
|
||||
gadgets-scrolling gadgets-theme generic hashtables help
|
||||
inspector kernel math namespaces prettyprint sequences words ;
|
||||
IN: gadgets-inspector
|
||||
|
||||
SYMBOL: components
|
||||
|
||||
H{ } clone components set-global
|
||||
|
||||
: get-components ( class -- assoc )
|
||||
components get-global hash [
|
||||
{ { "Slots" [ describe ] } }
|
||||
] unless* ;
|
||||
|
||||
{
|
||||
{ "Definition" [ help ] }
|
||||
{ "Calls in" [ usage. ] }
|
||||
{ "Calls out" [ uses. ] }
|
||||
{ "Links in" [ links-in. ] }
|
||||
{ "Links out" [ links-out. ] }
|
||||
{ "Properties" [ word-props describe ] }
|
||||
} \ word components get-global set-hash
|
||||
|
||||
{
|
||||
{ "Article" [ help ] }
|
||||
{ "Links in" [ links-in. ] }
|
||||
{ "Links out" [ links-out. ] }
|
||||
} \ link components get-global set-hash
|
||||
|
||||
{
|
||||
{ "Call stack" [ continuation-call callstack. ] }
|
||||
{ "Data stack" [ continuation-data stack. ] }
|
||||
{ "Retain stack" [ continuation-retain stack. ] }
|
||||
{ "Name stack" [ continuation-name stack. ] }
|
||||
{ "Catch stack" [ continuation-catch stack. ] }
|
||||
} \ continuation components get-global set-hash
|
||||
|
||||
TUPLE: book page pages ;
|
||||
|
||||
: show-page ( key book -- )
|
||||
dup book-page unparent
|
||||
[ book-pages assoc ] keep
|
||||
[ set-book-page ] 2keep
|
||||
add-gadget ;
|
||||
|
||||
C: book ( pages -- book )
|
||||
dup delegate>gadget
|
||||
[ set-book-pages ] 2keep
|
||||
[ >r first first r> show-page ] keep ;
|
||||
|
||||
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rect-dim swap book-page set-gadget-dim ;
|
||||
|
||||
: component-pages ( obj -- assoc )
|
||||
dup class get-components
|
||||
[ first2 swapd make-pane <scroller> 2array ] map-with ;
|
||||
|
||||
: <tab> ( name book -- button )
|
||||
dupd [ show-page drop ] curry curry
|
||||
>r <label> r> <bevel-button> ;
|
||||
|
||||
: tabs ( assoc book gadget -- )
|
||||
>r swap [ first swap <tab> ] map-with r> add-gadgets ;
|
||||
|
||||
TUPLE: inspector object history tabs ;
|
||||
|
||||
: save-current ( inspector -- )
|
||||
dup inspector-object swap inspector-history push ;
|
||||
|
||||
: (inspect) ( obj inspector -- )
|
||||
[ set-inspector-object ] 2keep
|
||||
dup inspector-tabs clear-gadget
|
||||
>r component-pages dup <book> r>
|
||||
[ @center frame-add ] 2keep inspector-tabs tabs ;
|
||||
|
||||
: inspect ( obj inspector -- ) dup save-current (inspect) ;
|
||||
|
||||
: find-inspector [ inspector? ] find-parent ;
|
||||
|
||||
: go-back ( inspector -- )
|
||||
dup inspector-history dup empty?
|
||||
[ 2drop ] [ pop swap inspect ] if ;
|
||||
|
||||
: <back-button> ( -- gadget )
|
||||
"<" <label> [ find-inspector go-back ] <bevel-button> ;
|
||||
|
||||
C: inspector ( obj history? -- inspector )
|
||||
V{ } clone over set-inspector-history
|
||||
dup delegate>frame [
|
||||
swap [ <back-button> , ] when
|
||||
<shelf> dup pick set-inspector-tabs ,
|
||||
] { } make make-shelf dup highlight-theme
|
||||
over @top frame-add
|
||||
[ (inspect) ] keep ;
|
||||
|
||||
: inspector-window ( obj -- )
|
||||
t <inspector> "Inspector" open-window ;
|
||||
|
||||
M: object show-object ( object button -- )
|
||||
find-inspector [ inspect ] [ inspector-window ] if* ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
IN: gadgets-launchpad
|
||||
USING: gadgets gadgets-apropos gadgets-browser gadgets-borders
|
||||
gadgets-buttons gadgets-labels gadgets-layouts gadgets-listener
|
||||
gadgets-panes gadgets-scrolling gadgets-theme help inspector io
|
||||
kernel memory namespaces sequences ;
|
||||
USING: gadgets gadgets-apropos gadgets-borders gadgets-browser
|
||||
gadgets-buttons gadgets-inspector gadgets-labels gadgets-layouts
|
||||
gadgets-listener gadgets-panes gadgets-scrolling gadgets-theme
|
||||
help inspector io kernel memory namespaces sequences ;
|
||||
|
||||
: <launchpad> ( menu -- )
|
||||
[ first2 >r <label> [ drop ] r> append <bevel-button> ] map
|
||||
|
|
@ -24,20 +24,17 @@ kernel memory namespaces sequences ;
|
|||
: apropos-window ( -- )
|
||||
<apropos-gadget> "Apropos" open-window ;
|
||||
|
||||
: vocabs-window ( -- )
|
||||
[ vocabs. ] "Vocabularies" pane-window ;
|
||||
|
||||
: global-window ( -- )
|
||||
global browser-window ;
|
||||
: globals-window ( -- )
|
||||
global inspector-window ;
|
||||
|
||||
: default-launchpad
|
||||
{
|
||||
{ "Listener" [ listener-window ] }
|
||||
{ "Documentation" [ handbook-window ] }
|
||||
{ "Help index" [ articles-window ] }
|
||||
{ "Browser" [ browser-window ] }
|
||||
{ "Apropos" [ apropos-window ] }
|
||||
{ "Vocabularies" [ vocabs-window ] }
|
||||
{ "Globals" [ global-window ] }
|
||||
{ "Globals" [ globals-window ] }
|
||||
{ "Memory" [ memory-window ] }
|
||||
{ "Save image" [ save ] }
|
||||
{ "Exit" [ 0 exit ] }
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ C: listener-gadget ( -- gadget )
|
|||
{
|
||||
{ [ <stack-bar> ] set-listener-gadget-stack @top }
|
||||
{ [ <input-pane> <scroller> ] set-listener-gadget-scroller @center }
|
||||
} make-frame dup start-listener ;
|
||||
} make-frame* dup start-listener ;
|
||||
|
||||
M: listener-gadget pref-dim* drop { 600 600 0 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,26 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-presentations
|
||||
USING: arrays gadgets gadgets-borders gadgets-browser
|
||||
gadgets-labels gadgets-layouts gadgets-outliner gadgets-panes
|
||||
hashtables io kernel sequences strings styles ;
|
||||
USING: arrays gadgets gadgets-borders
|
||||
gadgets-buttons gadgets-labels gadgets-layouts gadgets-outliner
|
||||
gadgets-panes generic hashtables inspector io kernel prettyprint
|
||||
sequences strings styles words ;
|
||||
|
||||
! Clickable objects
|
||||
TUPLE: object-button object ;
|
||||
|
||||
G: show-object ( object gadget -- ) 1 standard-combination ;
|
||||
|
||||
C: object-button ( gadget object -- button )
|
||||
[ set-object-button-object ] keep
|
||||
[
|
||||
>r [
|
||||
[ object-button-object ] keep show-object
|
||||
] <roll-button> r> set-gadget-delegate
|
||||
] keep ;
|
||||
|
||||
M: object-button gadget-help ( button -- string )
|
||||
object-button-object dup word? [ synopsis ] [ summary ] if ;
|
||||
|
||||
! Character styles
|
||||
|
||||
|
|
@ -25,7 +42,7 @@ hashtables io kernel sequences strings styles ;
|
|||
over specified-font over set-label-font ;
|
||||
|
||||
: apply-browser-style ( style gadget -- style gadget )
|
||||
presented [ <browser-button> ] apply-style ;
|
||||
presented [ <object-button> ] apply-style ;
|
||||
|
||||
: <presentation> ( style text -- gadget )
|
||||
<label>
|
||||
|
|
|
|||
|
|
@ -71,6 +71,9 @@ M: viewport layout* ( viewport -- )
|
|||
M: viewport focusable-child* ( viewport -- gadget )
|
||||
gadget-child ;
|
||||
|
||||
M: viewport pref-dim* ( viewport -- dim )
|
||||
gadget-child pref-dim ;
|
||||
|
||||
: scroll-to ( gadget -- )
|
||||
#! Scroll the scroller that contains this gadget, if any, so
|
||||
#! that the gadget becomes visible.
|
||||
|
|
@ -92,7 +95,7 @@ C: scroller ( gadget -- scroller )
|
|||
{ [ <viewport> ] set-scroller-viewport @center }
|
||||
{ [ <x-slider> ] set-scroller-x @bottom }
|
||||
{ [ <y-slider> ] set-scroller-y @right }
|
||||
} make-frame dup scroller-actions ;
|
||||
} make-frame* dup scroller-actions ;
|
||||
|
||||
M: scroller focusable-child* ( scroller -- viewport )
|
||||
scroller-viewport ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,10 @@ IN: gadgets-tracks
|
|||
USING: gadgets gadgets-layouts gadgets-theme io kernel math
|
||||
namespaces sequences ;
|
||||
|
||||
TUPLE: divider # splitter ;
|
||||
TUPLE: divider ;
|
||||
|
||||
: divider-# ( divider -- n )
|
||||
dup gadget-parent gadget-children index 2 /i ;
|
||||
|
||||
: divider-size { 8 8 0 } ;
|
||||
|
||||
|
|
@ -15,6 +18,10 @@ TUPLE: track sizes saved-sizes ;
|
|||
C: track ( orientation -- track )
|
||||
[ delegate>pack ] keep 1 over set-pack-fill ;
|
||||
|
||||
: <x-track> { 0 1 0 } <track> ;
|
||||
|
||||
: <y-track> { 1 0 0 } <track> ;
|
||||
|
||||
: track-dim ( track -- dim )
|
||||
#! Space available for content (minus dividers)
|
||||
dup rect-dim swap track-sizes length 1-
|
||||
|
|
@ -58,8 +65,7 @@ M: track layout* ( splitter -- )
|
|||
dup [ drop ] T{ button-up } set-action
|
||||
[ divider-motion ] T{ drag } set-action ;
|
||||
|
||||
C: divider ( n -- divider )
|
||||
[ set-divider-# ] keep
|
||||
C: divider ( -- divider )
|
||||
dup delegate>gadget
|
||||
dup divider-actions
|
||||
dup reverse-video-theme ;
|
||||
|
|
@ -71,14 +77,24 @@ C: divider ( n -- divider )
|
|||
dup length 1 max recip add normalize-sizes ;
|
||||
|
||||
: add-divider ( track -- )
|
||||
dup track-sizes length dup zero?
|
||||
[ 2drop ] [ 1- <divider> swap add-gadget ] if ;
|
||||
dup track-sizes empty?
|
||||
[ drop ] [ <divider> swap add-gadget ] if ;
|
||||
|
||||
: track-add ( gadget track -- )
|
||||
dup add-divider [ add-gadget ] keep
|
||||
dup track-sizes track-add-size swap set-track-sizes ;
|
||||
|
||||
: nth-gadget gadget-children nth ;
|
||||
|
||||
: track-remove@ ( n track -- )
|
||||
#! Remove the divider if this is not the last child.
|
||||
2dup nth-gadget unparent
|
||||
dup gadget-children empty? [
|
||||
2dup gadget-children length = [ >r 1- r> ] when
|
||||
2dup nth-gadget unparent
|
||||
] unless
|
||||
[ >r 2 /i r> track-sizes remove-index normalize-sizes ] keep
|
||||
[ set-track-sizes ] keep relayout-1 ;
|
||||
|
||||
: track-remove ( gadget track -- )
|
||||
! wrong
|
||||
[ gadget-children index ] 2keep swap unparent
|
||||
[ remove-index ] keep set-track-sizes ;
|
||||
[ gadget-children index ] keep track-remove@ ;
|
||||
|
|
|
|||
|
|
@ -24,8 +24,8 @@ DEFER: request-focus
|
|||
C: world ( gadget status -- world )
|
||||
{
|
||||
{ [ ] set-world-status @bottom }
|
||||
{ [ ] f @center }
|
||||
} make-frame
|
||||
{ [ ] set-world-gadget @center }
|
||||
} make-frame*
|
||||
t over set-gadget-root?
|
||||
H{ } clone over set-world-fonts
|
||||
dup world-gadget request-focus ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue