From 4f8632b6560bd79b72d6f66d48af3c620da26900 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Fri, 24 Mar 2006 08:28:46 +0000
Subject: [PATCH] New browser gadget

---
 TODO.FACTOR.txt                      |  1 -
 library/bootstrap/boot-stage1.factor |  6 +-
 library/help/commands.factor         |  6 --
 library/tools/components.factor      | 24 ++++++++
 library/ui/browser.factor            | 70 +++++++++++++++++++++++
 library/ui/commands.factor           | 85 ----------------------------
 library/ui/editors.factor            | 11 ++--
 library/ui/launchpad.factor          | 26 ++++++---
 library/ui/listener.factor           | 11 +---
 library/ui/menus.factor              | 37 ------------
 library/ui/presentations.factor      | 18 +++---
 library/ui/theme.factor              |  6 +-
 library/ui/world.factor              | 13 +----
 13 files changed, 132 insertions(+), 182 deletions(-)
 delete mode 100644 library/help/commands.factor
 create mode 100644 library/tools/components.factor
 create mode 100644 library/ui/browser.factor
 delete mode 100644 library/ui/commands.factor
 delete mode 100644 library/ui/menus.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 06b03e2769..2f67058467 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -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
diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor
index a578319918..b8f4bb8db0 100644
--- a/library/bootstrap/boot-stage1.factor
+++ b/library/bootstrap/boot-stage1.factor
@@ -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"
diff --git a/library/help/commands.factor b/library/help/commands.factor
deleted file mode 100644
index e2839d8b28..0000000000
--- a/library/help/commands.factor
+++ /dev/null
@@ -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
diff --git a/library/tools/components.factor b/library/tools/components.factor
new file mode 100644
index 0000000000..fb405ccee1
--- /dev/null
+++ b/library/tools/components.factor
@@ -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
diff --git a/library/ui/browser.factor b/library/ui/browser.factor
new file mode 100644
index 0000000000..cd43d6a5e8
--- /dev/null
+++ b/library/ui/browser.factor
@@ -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 ;
diff --git a/library/ui/commands.factor b/library/ui/commands.factor
deleted file mode 100644
index de564e2db2..0000000000
--- a/library/ui/commands.factor
+++ /dev/null
@@ -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
diff --git a/library/ui/editors.factor b/library/ui/editors.factor
index 483f59e345..14fc578dff 100644
--- a/library/ui/editors.factor
+++ b/library/ui/editors.factor
@@ -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 ;
diff --git a/library/ui/launchpad.factor b/library/ui/launchpad.factor
index 2495ad9af2..7acf4910f5 100644
--- a/library/ui/launchpad.factor
+++ b/library/ui/launchpad.factor
@@ -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> ;
diff --git a/library/ui/listener.factor b/library/ui/listener.factor
index 2fc3d8a26a..504aae14fb 100644
--- a/library/ui/listener.factor
+++ b/library/ui/listener.factor
@@ -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
diff --git a/library/ui/menus.factor b/library/ui/menus.factor
deleted file mode 100644
index cf2c6327d7..0000000000
--- a/library/ui/menus.factor
+++ /dev/null
@@ -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 ;
diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor
index 123ab75918..141e0ee4d9 100644
--- a/library/ui/presentations.factor
+++ b/library/ui/presentations.factor
@@ -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 ;
 
diff --git a/library/ui/theme.factor b/library/ui/theme.factor
index e93409171c..af34938e47 100644
--- a/library/ui/theme.factor
+++ b/library/ui/theme.factor
@@ -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 ;
diff --git a/library/ui/world.factor b/library/ui/world.factor
index 9c89d6ee58..5a8dadc8eb 100644
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -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 ;