New browser gadget
slava
parent
6893186be4
commit
4f8632b656
|
|
@ -36,7 +36,6 @@
|
|||
- use glRect
|
||||
- display lists
|
||||
- saving the image should save window configuration
|
||||
- menu drag retarget broken
|
||||
- changelog in the UI
|
||||
- make the UI look better, something like this:
|
||||
http://twb.ath.cx/~twb/darcs/OBSOLETE/factor/final.html
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ vectors words ;
|
|||
|
||||
"/library/tools/annotations.factor"
|
||||
"/library/tools/inspector.factor"
|
||||
"/library/tools/components.factor"
|
||||
|
||||
"/library/test/test.factor"
|
||||
|
||||
|
|
@ -177,7 +178,6 @@ vectors words ;
|
|||
"/library/ui/line-editor.factor"
|
||||
"/library/ui/sliders.factor"
|
||||
"/library/ui/scrolling.factor"
|
||||
"/library/ui/menus.factor"
|
||||
"/library/ui/editors.factor"
|
||||
"/library/ui/splitters.factor"
|
||||
"/library/ui/incremental.factor"
|
||||
|
|
@ -185,12 +185,10 @@ vectors words ;
|
|||
"/library/ui/panes.factor"
|
||||
"/library/ui/outliner.factor"
|
||||
"/library/ui/listener.factor"
|
||||
"/library/ui/browser.factor"
|
||||
"/library/ui/launchpad.factor"
|
||||
"/library/ui/commands.factor"
|
||||
"/library/ui/presentations.factor"
|
||||
|
||||
"/library/help/commands.factor"
|
||||
|
||||
"/library/continuations.facts"
|
||||
"/library/errors.facts"
|
||||
"/library/kernel.facts"
|
||||
|
|
|
|||
|
|
@ -1,6 +0,0 @@
|
|||
IN: help
|
||||
USING: gadgets-listener gadgets-presentations words ;
|
||||
|
||||
"Show word documentation" [ word? ] [ help ] \ in-browser define-default-command
|
||||
"Show term definition" [ term? ] [ help ] \ in-browser define-default-command
|
||||
"Show article" [ link? ] [ help ] \ in-browser define-default-command
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
IN: components
|
||||
USING: help inspector kernel namespaces sequences words ;
|
||||
|
||||
! Component document framework, like OpenDoc.
|
||||
|
||||
TUPLE: component name predicate builder ;
|
||||
|
||||
SYMBOL: components
|
||||
|
||||
V{ } clone components set-global
|
||||
|
||||
: get-components ( obj -- seq )
|
||||
components get-global
|
||||
[ component-predicate call ] subset-with ;
|
||||
|
||||
: define-component ( name predicate builder -- )
|
||||
<component> components get-global push ;
|
||||
|
||||
"Slots" [ drop t ] [ describe ] define-component
|
||||
"Documentation" [ word? ] [ help ] define-component
|
||||
"Calls in" [ word? ] [ usage. ] define-component
|
||||
"Calls out" [ word? ] [ uses. ] define-component
|
||||
"Definition" [ term? ] [ help ] define-component
|
||||
"Documentation" [ link? ] [ help ] define-component
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
IN: gadgets-browser
|
||||
USING: components gadgets gadgets-buttons gadgets-labels
|
||||
gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
|
||||
hashtables help inspector kernel lists math namespaces
|
||||
prettyprint sequences words ;
|
||||
|
||||
TUPLE: book page pages ;
|
||||
|
||||
: show-page ( key book -- )
|
||||
dup book-page unparent
|
||||
[ book-pages hash ] keep
|
||||
[ set-book-page ] 2keep
|
||||
add-gadget ;
|
||||
|
||||
C: book ( page pages -- book )
|
||||
dup delegate>gadget
|
||||
[ set-book-pages ] keep
|
||||
[ show-page ] keep ;
|
||||
|
||||
M: book pref-dim* ( book -- dim )
|
||||
{ 0 0 0 } swap book-pages [ nip pref-dim vmax ] hash-each ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rect-dim swap book-page set-gadget-dim ;
|
||||
|
||||
: component-page ( obj component -- gadget )
|
||||
component-builder make-pane <scroller> ;
|
||||
|
||||
: component-pages ( obj -- hash )
|
||||
dup get-components [
|
||||
[ component-name over ] keep component-page
|
||||
] map>hash nip ;
|
||||
|
||||
: component-book ( hash -- book )
|
||||
dup hash-keys natural-sort first swap <book> ;
|
||||
|
||||
: <tab> ( name book -- button )
|
||||
dupd [ show-page ] curry curry
|
||||
>r <label> r> <bevel-button> ;
|
||||
|
||||
: tabs ( hash book -- gadget )
|
||||
swap hash-keys natural-sort
|
||||
[ swap <tab> ] map-with make-pile
|
||||
1 over set-pack-fill dup highlight-theme ;
|
||||
|
||||
TUPLE: browser history ;
|
||||
|
||||
: browse ( obj browser -- )
|
||||
swap component-pages
|
||||
[ component-book dup pick @center frame-add ] keep
|
||||
swap tabs over @left frame-add ;
|
||||
|
||||
C: browser ( obj -- browser )
|
||||
dup delegate>frame [ browse ] keep ;
|
||||
|
||||
TUPLE: browser-button object ;
|
||||
|
||||
: in-browser ( obj -- )
|
||||
[ <browser> "Browser: " ] keep unparse-short append
|
||||
simple-window ;
|
||||
|
||||
C: browser-button ( gadget object -- button )
|
||||
[ set-browser-button-object ] keep
|
||||
[
|
||||
>r [ browser-button-object in-browser ] <roll-button> r>
|
||||
set-gadget-delegate
|
||||
] keep ;
|
||||
|
||||
M: browser-button gadget-help ( button -- string )
|
||||
browser-button-object dup word? [ synopsis ] [ summary ] if ;
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
IN: gadgets-presentations
|
||||
USING: arrays compiler gadgets gadgets-buttons gadgets-listener
|
||||
gadgets-menus gadgets-panes generic hashtables inference
|
||||
inspector io jedit kernel lists namespaces parser prettyprint
|
||||
sequences strings styles words ;
|
||||
|
||||
SYMBOL: commands
|
||||
|
||||
TUPLE: command name pred quot context default? ;
|
||||
|
||||
V{ } clone commands set-global
|
||||
|
||||
: forget-command ( name -- )
|
||||
global [
|
||||
commands [ [ command-name = not ] subset-with ] change
|
||||
] bind ;
|
||||
|
||||
: (define-command) ( name pred quot context default? -- )
|
||||
<command> dup command-name forget-command commands get push ;
|
||||
|
||||
: define-command ( name pred quot context -- )
|
||||
f (define-command) ;
|
||||
|
||||
: define-default-command ( name pred quot context -- )
|
||||
t (define-command) ;
|
||||
|
||||
: applicable ( object -- seq )
|
||||
commands get [ command-pred call ] subset-with ;
|
||||
|
||||
: command>quot ( presented command -- quot )
|
||||
[ command-quot curry ] keep command-context unit curry ;
|
||||
|
||||
TUPLE: command-button object ;
|
||||
|
||||
: command-action ( command-button -- )
|
||||
#! Invoke the default action.
|
||||
command-button-object dup applicable
|
||||
[ command-default? ] find-last nip command>quot call ;
|
||||
|
||||
: <command-menu-item> ( presented command -- item )
|
||||
[ command>quot [ drop ] swap append ] keep
|
||||
command-name swap 2array ;
|
||||
|
||||
: <command-menu> ( presented -- menu )
|
||||
dup applicable
|
||||
[ <command-menu-item> ] map-with <menu> ;
|
||||
|
||||
: command-menu ( command-button -- )
|
||||
dup button-update
|
||||
[ command-button-object <command-menu> ] keep
|
||||
show-hand-menu ;
|
||||
|
||||
: command-button-actions ( gadget -- )
|
||||
dup
|
||||
[ command-menu ] [ button-down 3 ] set-action
|
||||
[ button-update ] [ button-up 3 ] set-action ;
|
||||
|
||||
C: command-button ( gadget object -- button )
|
||||
[ set-command-button-object ] keep
|
||||
[
|
||||
>r [ command-action ] <roll-button> r>
|
||||
set-gadget-delegate
|
||||
] keep
|
||||
dup command-button-actions ;
|
||||
|
||||
M: command-button gadget-help ( button -- string )
|
||||
command-button-object dup word? [ synopsis ] [ summary ] if ;
|
||||
|
||||
"Describe object" [ drop t ] [ describe ] \ in-browser define-default-command
|
||||
"Inspect object" [ drop t ] [ inspect ] \ in-listener define-command
|
||||
"Describe commands" [ drop t ] [ applicable describe ] \ in-browser define-command
|
||||
"Prettyprint" [ drop t ] [ . ] \ in-listener define-command
|
||||
"Push on data stack" [ drop t ] [ ] \ in-listener define-command
|
||||
|
||||
"Word call hierarchy" [ word? ] [ uses. ] \ in-browser define-command
|
||||
"Word caller hierarchy" [ word? ] [ usage. ] \ in-browser define-command
|
||||
"Open in jEdit" [ word? ] [ jedit ] \ call define-command
|
||||
"Reload original source" [ word? ] [ reload ] \ in-listener define-command
|
||||
"Infer stack effect" [ word? ] [ unit infer . ] \ in-listener define-command
|
||||
|
||||
"Use word vocabulary" [ word? ] [ word-vocabulary use+ ] \ in-listener define-command
|
||||
|
||||
"Display gadget" [ [ gadget? ] is? ] [ gadget. ] \ in-listener define-command
|
||||
|
||||
"Use as input" [ input? ] [ input-string pane get replace-input ] \ call define-default-command
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: gadgets-editors
|
||||
USING: arrays freetype gadgets gadgets-labels gadgets-layouts
|
||||
gadgets-menus gadgets-scrolling gadgets-theme generic kernel
|
||||
gadgets-scrolling gadgets-theme generic kernel
|
||||
lists math namespaces sequences strings styles threads ;
|
||||
|
||||
! A blinking caret
|
||||
|
|
@ -76,12 +76,13 @@ TUPLE: editor line caret font color ;
|
|||
: <completion-item> ( completion editor -- menu-item )
|
||||
dupd [ [ complete ] with-editor drop ] curry curry 2array ;
|
||||
|
||||
: <completion-menu> ( editor completions -- menu )
|
||||
[ swap <completion-item> ] map-with <menu> ;
|
||||
! : <completion-menu> ( editor completions -- menu )
|
||||
! [ swap <completion-item> ] map-with <menu> ;
|
||||
|
||||
: completion-menu ( editor completions -- )
|
||||
over popup-location -rot
|
||||
over >r <completion-menu> r> show-menu ;
|
||||
2drop ;
|
||||
! over popup-location -rot
|
||||
! over >r <completion-menu> r> show-menu ;
|
||||
|
||||
: do-completion-1 ( editor completions -- )
|
||||
swap [ first complete ] with-editor ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,31 @@
|
|||
IN: gadgets-launchpad
|
||||
USING: gadgets gadgets-borders gadgets-buttons gadgets-labels
|
||||
gadgets-layouts gadgets-listener gadgets-theme help inspector io
|
||||
kernel memory namespaces sequences ;
|
||||
USING: gadgets 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 ;
|
||||
|
||||
: <launchpad> ( menu -- )
|
||||
[ first2 >r <label> [ drop ] r> append <bevel-button> ] map
|
||||
make-pile 1 over set-pack-fill { 5 5 0 } over set-pack-gap
|
||||
<default-border> dup highlight-theme ;
|
||||
|
||||
: scratch-window ( quot -- )
|
||||
make-pane <scroller> "Scratch" simple-window ;
|
||||
|
||||
: handbook-window ( -- )
|
||||
T{ link f "handbook" } in-browser ;
|
||||
|
||||
: tutorial-window ( -- )
|
||||
T{ link f "tutorial" } in-browser ;
|
||||
|
||||
: default-launchpad
|
||||
{
|
||||
{ "Listener" [ listener-window ] }
|
||||
{ "Documentation" [ [ handbook ] in-browser ] }
|
||||
{ "Tutorial" [ [ tutorial ] in-browser ] }
|
||||
{ "Vocabularies" [ [ vocabs. ] in-browser ] }
|
||||
{ "Globals" [ [ global describe ] in-browser ] }
|
||||
{ "Memory" [ [ heap-stats. terpri room. ] in-browser ] }
|
||||
{ "Documentation" [ handbook-window ] }
|
||||
{ "Tutorial" [ tutorial-window ] }
|
||||
{ "Vocabularies" [ [ vocabs. ] scratch-window ] }
|
||||
{ "Globals" [ global in-browser ] }
|
||||
{ "Memory" [ [ heap-stats. terpri room. ] scratch-window ] }
|
||||
{ "Save image" [ save ] }
|
||||
{ "Exit" [ 0 exit ] }
|
||||
} <launchpad> ;
|
||||
|
|
|
|||
|
|
@ -9,12 +9,6 @@ namespaces parser prettyprint sequences threads words ;
|
|||
|
||||
TUPLE: listener-gadget pane stack status ;
|
||||
|
||||
: in-browser ( quot -- )
|
||||
make-pane <scroller> "Browser" simple-window ; inline
|
||||
|
||||
: in-listener ( quot -- )
|
||||
pane get pane-call ; inline
|
||||
|
||||
: usable-words ( -- words )
|
||||
use get hash-concat hash-values ;
|
||||
|
||||
|
|
@ -48,11 +42,8 @@ TUPLE: listener-gadget pane stack status ;
|
|||
|
||||
: <stack-bar> ( -- gadget ) <shelf> dup highlight-theme ;
|
||||
|
||||
: <scroller> ( -- gadget )
|
||||
<input-pane> dup pane set-global <scroller> ;
|
||||
|
||||
C: listener-gadget ( -- gadget )
|
||||
<frame> over set-delegate
|
||||
dup delegate>frame
|
||||
<input-pane> dup pick set-listener-gadget-pane
|
||||
<scroller> over @center frame-add
|
||||
<status-bar> dup pick set-listener-gadget-status
|
||||
|
|
|
|||
|
|
@ -1,37 +0,0 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-menus
|
||||
USING: gadgets gadgets-borders gadgets-buttons gadgets-layouts
|
||||
gadgets-labels gadgets-theme generic kernel lists math
|
||||
namespaces sequences ;
|
||||
|
||||
: retarget-click ( gadget -- )
|
||||
find-world dup hide-glass
|
||||
hand-loc get-global swap move-hand update-clicked ;
|
||||
|
||||
: menu-actions ( glass -- )
|
||||
[ retarget-click ] [ button-down ] set-action ;
|
||||
|
||||
: menu-loc ( loc menu world -- loc )
|
||||
[ rect-dim ] 2apply swap |v-| vmin ;
|
||||
|
||||
: show-menu ( loc menu gadget -- )
|
||||
find-world 2dup show-glass
|
||||
dup world-glass menu-actions
|
||||
over >r menu-loc r> set-rect-loc ;
|
||||
|
||||
: show-hand-menu ( menu gadget -- )
|
||||
hand-click-loc get-global -rot show-menu ;
|
||||
|
||||
: menu-item-quot ( quot -- quot )
|
||||
[ keep find-world hide-glass ] curry ;
|
||||
|
||||
: menu-items ( assoc -- pile )
|
||||
#! Given an association list mapping labels to quotations.
|
||||
#! Prepend a call to hide-menu to each quotation.
|
||||
[ first2 menu-item-quot >r <label> r> <roll-button> ] map
|
||||
make-pile 1 over set-pack-fill ;
|
||||
|
||||
: <menu> ( assoc -- gadget )
|
||||
#! Given an association list mapping labels to quotations.
|
||||
menu-items <default-border> dup menu-theme ;
|
||||
|
|
@ -1,9 +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-presentations
|
||||
USING: arrays gadgets gadgets-borders gadgets-labels
|
||||
gadgets-layouts gadgets-outliner gadgets-panes hashtables io
|
||||
kernel sequences strings styles ;
|
||||
USING: arrays gadgets gadgets-borders gadgets-browser
|
||||
gadgets-labels gadgets-layouts gadgets-outliner gadgets-panes
|
||||
hashtables io kernel sequences strings styles ;
|
||||
|
||||
! Character styles
|
||||
|
||||
|
|
@ -24,15 +24,15 @@ kernel sequences strings styles ;
|
|||
: apply-font-style ( style gadget -- style gadget )
|
||||
over specified-font over set-label-font ;
|
||||
|
||||
: apply-command-style ( style gadget -- style gadget )
|
||||
presented [ <command-button> ] apply-style ;
|
||||
: apply-browser-style ( style gadget -- style gadget )
|
||||
presented [ <browser-button> ] apply-style ;
|
||||
|
||||
: <presentation> ( style text -- gadget )
|
||||
<label>
|
||||
apply-foreground-style
|
||||
apply-background-style
|
||||
apply-font-style
|
||||
apply-command-style
|
||||
apply-browser-style
|
||||
nip ;
|
||||
|
||||
! Paragraph styles
|
||||
|
|
@ -64,7 +64,7 @@ kernel sequences strings styles ;
|
|||
apply-border-width-style
|
||||
apply-border-color-style
|
||||
apply-page-color-style
|
||||
apply-command-style
|
||||
apply-browser-style
|
||||
apply-outliner-style
|
||||
nip ;
|
||||
|
||||
|
|
|
|||
|
|
@ -70,10 +70,6 @@ USING: arrays gadgets kernel sequences styles ;
|
|||
: reverse-video-theme ( gadget -- )
|
||||
solid-black swap set-gadget-interior ;
|
||||
|
||||
: menu-theme ( menu -- )
|
||||
dup solid-boundary
|
||||
T{ solid f { 0.9 0.9 0.9 0.9 } } swap set-gadget-interior ;
|
||||
|
||||
: label-theme ( label -- )
|
||||
{ 0.0 0.0 0.0 1.0 } over set-label-color
|
||||
{ "monospace" plain 12 } swap set-label-font ;
|
||||
|
|
@ -83,4 +79,4 @@ USING: arrays gadgets kernel sequences styles ;
|
|||
{ "monospace" bold 12 } swap set-label-font ;
|
||||
|
||||
: highlight-theme ( label -- )
|
||||
T{ solid f { 1.0 1.0 0.8 1.0 } } swap set-gadget-interior ;
|
||||
T{ solid f { 0.7 0.7 0.7 1.0 } } swap set-gadget-interior ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ math namespaces opengl sequences ;
|
|||
|
||||
! fonts: mapping font tuples to sprite vectors
|
||||
! handle: native resource
|
||||
TUPLE: world glass status focus fonts handle ;
|
||||
TUPLE: world status focus fonts handle ;
|
||||
|
||||
: free-fonts ( world -- )
|
||||
dup world-handle select-gl-context
|
||||
|
|
@ -27,17 +27,6 @@ C: world ( gadget status dim -- world )
|
|||
[ set-world-status ] keep
|
||||
[ add-gadget ] keep ;
|
||||
|
||||
: hide-glass ( world -- )
|
||||
dup world-glass unparent f swap set-world-glass ;
|
||||
|
||||
: <glass> ( gadget -- glass )
|
||||
<gadget> 2dup add-gadget swap prefer ;
|
||||
|
||||
: show-glass ( gadget world -- )
|
||||
dup hide-glass
|
||||
>r <glass> r> 2dup add-gadget
|
||||
set-world-glass ;
|
||||
|
||||
GENERIC: find-world ( gadget -- world )
|
||||
|
||||
M: f find-world ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue