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 ;
12 SINGLETON: stack-entry-renderer
14 M: stack-entry-renderer row-columns
15 drop [ write-gml ] with-string-writer 1array ;
17 M: stack-entry-renderer row-value
20 : <stack-table> ( model -- table )
21 stack-entry-renderer <table>
27 : <stack-display> ( model -- gadget )
28 <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
30 TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
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 ]
37 : with-gml-editor ( gml-editor quot -- )
39 [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
44 : find-gml-editor ( gadget -- gml-editor )
45 [ gml-editor? ] find-parent ;
47 : load-input ( file gml-editor -- )
48 [ utf8 file-contents ] dip editor>> set-editor-string ;
50 : update-viewer ( gml-editor -- )
51 dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
53 : new-viewer ( gml-editor -- )
55 [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
58 : reset-viewer ( gml-editor -- )
61 gml get operand-stack>> delete-all
64 : <new-button> ( -- button )
65 "New viewer" [ find-gml-editor new-viewer ] <border-button> ;
67 : <update-button> ( -- button )
68 "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
70 : <reset-button> ( -- button )
71 "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
73 : <control-buttons> ( -- gadget )
75 <new-button> add-gadget
76 <update-button> add-gadget
77 <reset-button> add-gadget ;
79 CONSTANT: example-dir "vocab:gml/examples/"
81 : gml-files ( -- seq )
82 example-dir directory-files
83 [ file-extension >lower "gml" = ] filter ;
85 : <example-button> ( file -- button )
86 dup '[ example-dir _ append-path swap find-gml-editor load-input ]
89 : <example-buttons> ( -- gadget )
92 "Examples:" <label> add-gadget
93 [ <example-button> add-gadget ] reduce ;
95 : <editor-panel> ( editor -- gadget )
100 <scroller> "Editor" <labeled-gadget> ;
102 : <gml-editor> ( -- gadget )
103 2 3 gml-editor new-frame
106 dup b-rep>> <model> >>b-rep-model
107 dup gml>> operand-stack>> <model> >>stack-model
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 ;
116 M: gml-editor focusable-child* editor>> ;
118 : gml-editor-window ( -- )
119 <gml-editor> "Generative Modeling Language" open-window ;
121 MAIN: gml-editor-window