library/ui/tools/browser.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays sequences kernel gadgets-panes definitions
   4 prettyprint gadgets-theme gadgets-borders gadgets
   5 generic gadgets-scrolling math io words models styles
   6 namespaces gadgets-tracks gadgets-presentations gadgets-grids
   7 gadgets-workspace gadgets-frames help gadgets-buttons
   8 gadgets-search tools ;
   9 IN: gadgets-browser
  10
  11 TUPLE: browser navigator definitions search ;
  12
  13 TUPLE: definitions showing ;
  14
  15 : find-definitions ( gadget -- definitions )
  16     [ definitions? ] find-parent ;
  17
  18 : definition-index ( definition definitions -- n )
  19     definitions-showing index ;
  20
  21 : close-definition ( gadget definition -- )
  22     over find-definitions definitions-showing delete
  23     unparent ;
  24
  25 : close-definitions ( definitions -- )
  26     dup clear-gadget definitions-showing delete-all ;
  27
  28 C: definitions ( -- gadget )
  29     <pile> over set-delegate
  30     { 2 2 } over set-pack-gap
  31     V{ } clone over set-definitions-showing ;
  32
  33 TUPLE: tile definition gadget ;
  34
  35 : find-tile [ tile? ] find-parent ;
  36
  37 : close-tile ( tile -- )
  38     dup tile-definition over find-definitions
  39     definitions-showing delete
  40     unparent ;
  41
  42 : <tile-content> ( definition toolbar -- gadget )
  43     >r [ see ] make-pane r> 2array
  44     make-pile { 5 5 } over set-pack-gap
  45     <default-border> dup faint-boundary ;
  46
  47 C: tile ( definition -- gadget )
  48     2dup { tile } <toolbar>
  49     <tile-content> over set-gadget-delegate
  50     [ set-tile-definition ] keep ;
  51
  52 : show-definition ( definition definitions -- )
  53     2dup definition-index dup 0 >= [
  54         over nth-gadget swap scroll>rect drop
  55     ] [
  56         drop 2dup definitions-showing push
  57         swap <tile> over add-gadget
  58         scroll>bottom
  59     ] if ;
  60
  61 : <list-control> ( model quot -- gadget )
  62     [ map [ first2 write-object terpri ] each ] curry
  63     <pane-control> ;
  64
  65 TUPLE: navigator vocab ;
  66
  67 : <vocab-list> ( -- gadget )
  68     vocabs <model> [ dup <vocab-link> 2array ]
  69     <list-control> ;
  70
  71 : <word-list> ( model -- gadget )
  72     gadget get navigator-vocab
  73     [ words natural-sort ] <filter>
  74     [ dup word-name swap 2array ]
  75     <list-control> ;
  76
  77 C: navigator ( -- gadget )
  78     f <model> over set-navigator-vocab
  79     {
  80         { [ <vocab-list> ] f [ <scroller> ] 1/2 }
  81         { [ <word-list> ] f [ <scroller> ] 1/2 }
  82     } { 1 0 } make-track* ;
  83
  84 C: browser ( -- gadget )
  85     {
  86         {
  87             [ <navigator> ]
  88             set-browser-navigator
  89             f
  90             1/5
  91         }
  92         {
  93             [ <definitions> ]
  94             set-browser-definitions
  95             [ <scroller> ]
  96             3/5
  97         }
  98         {
  99             [ "" [ browser call-tool ] <word-search> ]
 100             set-browser-search
 101             [ "Word search" <labelled-gadget> ]
 102             1/5
 103         }
 104     } { 0 1 } make-track* ;
 105
 106 M: browser focusable-child* browser-search ;
 107
 108 : show-vocab ( vocab browser -- )
 109     browser-navigator navigator-vocab set-model* ;
 110
 111 : show-word ( word browser -- )
 112     over word-vocabulary over show-vocab
 113     browser-definitions show-definition ;
 114
 115 : clear-browser ( browser -- )
 116     browser-definitions close-definitions ;
 117
 118 browser "Toolbar" {
 119     { "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] }
 120 } define-commands
 121
 122 M: browser call-tool*
 123     over vocab-link? [
 124         >r vocab-link-name r> show-vocab
 125     ] [
 126         show-word
 127     ] if ;
 128
 129 M: browser tool-scroller browser-definitions find-scroller ;
 130
 131 M: browser tool-help drop "ui-browser" ;