extra/gopher/ui/ui.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays debugger fonts fry gopher gopher.private
   5 kernel math.vectors models present sequences ui ui.commands ui.gadgets
   6 ui.gadgets.editors ui.gadgets.panes ui.gadgets.scrollers
   7 ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks
   8 ui.gadgets.viewports ui.gestures ui.operations ui.tools.browser
   9 ui.tools.browser.history ui.tools.common urls webbrowser ;
  10
  11 IN: gopher.ui
  12
  13 TUPLE: gopher-gadget < tool history scroller url-field ;
  14
  15 gopher-gadget default-font-size { 50 50 } n*v set-tool-dim
  16
  17 M: gopher-gadget history-value
  18     [ control-value ] [ scroller>> scroll-position ]
  19     bi 2array ;
  20
  21 M: gopher-gadget set-history-value
  22     [ first2 ] dip
  23     [ set-control-value ] [ scroller>> set-scroll-position ]
  24     bi-curry bi* ;
  25
  26 M: gopher-gadget model-changed
  27     [ value>> present ]
  28     [ url-field>> editor>> set-editor-string ] bi* ;
  29
  30 : show-gopher ( url gopher-gadget -- )
  31     [ [ >url ] [ f ] if* ] dip
  32     over [ protocol>> "gopher" = ] [ t ] if* [
  33         [
  34             2dup control-value =
  35             [ 2drop ] [ nip history>> add-history ] if
  36         ]
  37         [ set-control-value ]
  38         2bi
  39     ] [ drop open-url ] if ;
  40
  41 : <url-field> ( gopher-gadget -- field )
  42     '[ >url _ show-gopher ] <action-field>
  43         "Gopher URL" >>default-text
  44         white-interior ;
  45
  46 : <gopher-pane> ( gopher-gadget -- gadget )
  47     model>> [ '[ _ [ gopher. ] when* ] try ] <pane-control> ;
  48
  49 : <gopher-toolbar> ( browser -- toolbar )
  50     horizontal <track>
  51         0 >>fill
  52         1/2 >>align
  53         { 5 5 } >>gap
  54         over <toolbar> f track-add
  55         swap url-field>> 1 track-add ;
  56
  57 : add-gopher-toolbar ( track -- track )
  58     dup <gopher-toolbar> format-toolbar f track-add ;
  59
  60 : add-gopher-pane ( track -- track )
  61     dup dup <gopher-pane> margins
  62     <scroller> >>scroller scroller>> white-interior 1 track-add ;
  63
  64 : <gopher-gadget> ( -- gadget )
  65     vertical gopher-gadget new-track with-lines
  66         f <model> >>model
  67         dup <history> >>history
  68         dup <url-field> >>url-field
  69         add-gopher-toolbar
  70         add-gopher-pane ;
  71
  72 : open-gopher-window ( url -- )
  73     <gopher-gadget>
  74     [ "Gopher" open-status-window ]
  75     [ show-gopher ] bi ;
  76
  77 : com-clear ( gopher -- )
  78     f swap set-control-value ;
  79
  80 : com-gopher ( url -- )
  81     [ gopher-gadget? ] find-window
  82     [ [ raise-window ] [ gadget-child show-gopher ] bi ]
  83     [ open-gopher-window ] if* ;
  84
  85 gopher-gadget "toolbar" f {
  86     { f com-back }
  87     { f com-forward }
  88     { f com-clear }
  89 } define-command-map
  90
  91 gopher-gadget "scrolling" f {
  92     { T{ key-down f f "UP" } com-scroll-up }
  93     { T{ key-down f f "DOWN" } com-scroll-down }
  94     { T{ key-down f f "PAGE_UP" } com-page-up }
  95     { T{ key-down f f "PAGE_DOWN" } com-page-down }
  96 } define-command-map
  97
  98 [ gopher-link? ] \ com-gopher H{ { +primary+ t } } define-operation