extra/gml/ui/ui.factor

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