extra/gml/ui/ui.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
   3 gml.printer io.directories io.encodings.utf8 io.files
   4 io.pathnames io.streams.string kernel locals models namespaces
   5 sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
   6 ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
   7 ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
   8 ui.gadgets.tables ui.gadgets.labeled unicode.case ;
   9 FROM: gml => gml ;
  10 IN: gml.ui
  11
  12 SINGLETON: stack-entry-renderer
  13
  14 M: stack-entry-renderer row-columns
  15     drop [ write-gml ] with-string-writer 1array ;
  16
  17 M: stack-entry-renderer row-value
  18     drop ;
  19
  20 : <stack-table> ( model -- table )
  21     stack-entry-renderer <table>
  22         10 >>min-rows
  23         10 >>max-rows
  24         40 >>min-cols
  25         40 >>max-cols ;
  26
  27 : <stack-display> ( model -- gadget )
  28     <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
  29
  30 TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
  31
  32 : update-models ( gml-editor -- )
  33     [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
  34     [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
  35     bi ;
  36
  37 : with-gml-editor ( gml-editor quot -- )
  38     '[
  39         [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
  40         [ update-models ]
  41         bi
  42     ] with-scope ; inline
  43
  44 : find-gml-editor ( gadget -- gml-editor )
  45     [ gml-editor? ] find-parent ;
  46
  47 : load-input ( file gml-editor -- )
  48     [ utf8 file-contents ] dip editor>> set-editor-string ;
  49
  50 : update-viewer ( gml-editor -- )
  51     dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
  52
  53 : new-viewer ( gml-editor -- )
  54     [ update-viewer ]
  55     [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
  56     bi ;
  57
  58 : reset-viewer ( gml-editor -- )
  59     [
  60         b-rep get clear-b-rep
  61         gml get operand-stack>> delete-all
  62     ] with-gml-editor ;
  63
  64 : <new-button> ( -- button )
  65     "New viewer" [ find-gml-editor new-viewer ] <border-button> ;
  66
  67 : <update-button> ( -- button )
  68     "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
  69
  70 : <reset-button> ( -- button )
  71     "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
  72
  73 : <control-buttons> ( -- gadget )
  74     <shelf> { 5 5 } >>gap
  75     <new-button> add-gadget
  76     <update-button> add-gadget
  77     <reset-button> add-gadget ;
  78
  79 CONSTANT: example-dir "vocab:gml/examples/"
  80
  81 : gml-files ( -- seq )
  82     example-dir directory-files
  83     [ file-extension >lower "gml" = ] filter ;
  84
  85 : <example-button> ( file -- button )
  86     dup '[ example-dir _ append-path swap find-gml-editor load-input ]
  87     <border-button> ;
  88
  89 : <example-buttons> ( -- gadget )
  90     gml-files
  91     <pile> { 5 5 } >>gap
  92     "Examples:" <label> add-gadget
  93     [ <example-button> add-gadget ] reduce ;
  94
  95 : <editor-panel> ( editor -- gadget )
  96         30 >>min-rows
  97         30 >>max-rows
  98         40 >>min-cols
  99         40 >>max-cols
 100     <scroller> "Editor" <labeled-gadget> ;
 101
 102 : <gml-editor> ( -- gadget )
 103     2 3 gml-editor new-frame
 104         <gml> >>gml
 105         <b-rep> >>b-rep
 106         dup b-rep>> <model> >>b-rep-model
 107         dup gml>> operand-stack>> <model> >>stack-model
 108         { 20 20 } >>gap
 109         { 0 0 } >>filled-cell
 110         <source-editor> >>editor
 111         dup editor>> <editor-panel> { 0 0 } grid-add
 112         dup stack-model>> <stack-display> { 0 1 } grid-add
 113         <control-buttons> { 0 2 } grid-add
 114         <example-buttons> { 1 0 } grid-add ;
 115
 116 M: gml-editor focusable-child* editor>> ;
 117
 118 : gml-editor-window ( -- )
 119     <gml-editor> "Generative Modeling Language" open-window ;
 120
 121 MAIN: gml-editor-window