extra/gml/ui/ui.factor

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