Minsky
godley.tcl
Go to the documentation of this file.
1 proc openGodley {id} {
2  if {![ winfo exists ".$id.popup"]} {
3  image create cairoSurface $id -surface $id.popup
4  toplevel .$id
5  wm title .$id "Godley Table:[$id.table.title]"
6  $id.deleteCallback "destroy .$id"
7 
8  frame .$id.controls
9  button .$id.controls.run -image runButton -height 25 -width 25 -command runstop -takefocus 0
10  button .$id.controls.reset -image resetButton -height 25 -width 25 -command reset -takefocus 0
11  button .$id.controls.step -image stepButton -height 25 -width 25 -command {step} -takefocus 0
12  bind .$id.controls.step <ButtonPress-1> "set buttonPressed 1; autoRepeatButton .$id.controls.step"
13  bind .$id <ButtonRelease-1> {set buttonPressed 0}
14  tooltip .$id.controls.run "Run/Stop"
15  tooltip .$id.controls.reset "Reset simulation"
16  tooltip .$id.controls.step "Step simulation"
17 
18  label .$id.controls.slowSpeed -text "slow" -takefocus 0
19  label .$id.controls.fastSpeed -text "fast" -takefocus 0
20  scale .$id.controls.simSpeed -variable delay -command setSimulationDelay -to 0 -from 12 -length 150 -label "Simulation Speed" -orient horizontal -showvalue 0 -takefocus 0
21 
22  button .$id.controls.zoomOut -image zoomOutImg -height 24 -width 37 -command "zoomOut $id" -takefocus 0
23  tooltip .$id.controls.zoomOut "Zoom Out"
24  button .$id.controls.zoomIn -image zoomInImg -height 24 -width 37 -command "zoomIn $id" -takefocus 0
25  tooltip .$id.controls.zoomIn "Zoom In"
26  button .$id.controls.zoomOrig -image zoomOrigImg -height 24 -width 37 \
27  -command "$id.popup.zoomFactor 1; $id.popup.requestRedraw" -takefocus 0
28  tooltip .$id.controls.zoomOrig "Reset Zoom"
29  pack .$id.controls.run .$id.controls.reset .$id.controls.step .$id.controls.slowSpeed .$id.controls.simSpeed .$id.controls.fastSpeed .$id.controls.zoomOut .$id.controls.zoomIn .$id.controls.zoomOrig -side left
30  pack .$id.controls
31 
32 
33  label .$id.table -image $id -width 800 -height 200 -takefocus 1
34  bind .$id.table <Configure> "$id.popup.requestRedraw"
35 
36  bind .$id.table <ButtonPress-1> "moveAssetClass $id %x %y %X %Y"
37  bind .$id.table <ButtonRelease-1> "defaultCursor .$id.table; swapAssetClass $id %x %y"
38  bind .$id.table <B1-Motion> "motionCursor .$id.table; $id.popup.mouseMoveB1 %x %y"
39  bind .$id.table <Motion> "$id.popup.mouseMove %x %y; $id.popup.requestRedraw"
40  bind .$id.table <Leave> "$id.popup.mouseMove -1 -1; $id.update; $id.popup.requestRedraw"
41  bind .$id.table <Enter> "$id.popup.adjustWidgets; $id.popup.update; $id.popup.requestRedraw"
42 
43  bind .$id.table <<contextMenu>> "godleyContext $id %x %y %X %Y"
44  bind .$id.table <Key> "$id.popup.keyPress %N [encoding convertto utf-8 %A] 0 0 0; $id.popup.requestRedraw"
45  global meta meta_menu
46  bind .$id.table <$meta-y> "$id.popup.undo -1; $id.popup.requestRedraw"
47  bind .$id.table <$meta-z> "$id.popup.undo 1; $id.popup.requestRedraw"
48  bind .$id <$meta-y> "$id.popup.undo -1; $id.popup.requestRedraw"
49  bind .$id <$meta-z> "$id.popup.undo 1; $id.popup.requestRedraw"
50 
51  bind .$id <$meta-plus> "zoomIn $id"
52  bind .$id <$meta-minus> "zoomOut $id"
53  bind .$id.table <Key-KP_Add> "zoomIn $id"
54  bind .$id.table <Key-KP_Subtract> "zoomOut $id"
55  bind .$id <Key-KP_Add> "zoomIn $id"
56  bind .$id <Key-KP_Subtract> "zoomOut $id"
57  # mouse wheel bindings for X11
58  bind .$id.table <Button-4> "zoomIn $id"
59  bind .$id.table <Button-5> "zoomOut $id"
60  # mouse wheel bindings for pc and aqua
61  bind .$id.table <MouseWheel> "if {%D>=0} {zoomIn $id} {zoomOut $id}"
62 
63  menu .$id.context -tearoff 0
64  menu .$id.context.import -tearoff 0
65 
66  frame .$id.vscrollFrame
67  scrollbar .$id.vscroll -orient vertical -command "scrollGodley $id row"
68  .$id.vscroll set 0 0.25
69  pack .$id.vscroll -in .$id.vscrollFrame -anchor n -fill y -side top -expand 1
70  ttk::sizegrip .$id.sizegrip
71  pack .$id.sizegrip -in .$id.vscrollFrame -anchor s -side bottom
72  pack .$id.vscrollFrame -side right -anchor s -fill y
73 
74  scrollbar .$id.hscroll -orient horiz -command "scrollGodley $id col"
75  pack .$id.hscroll -side bottom -fill x
76  .$id.hscroll set 0 0.25
77  pack .$id.table -fill both -expand 1
78 
79  menu .$id.menubar -type menubar
80 
81  if {[tk windowingsystem] == "aqua"} {
82  menu .$id.menubar.apple
83  .$id.menubar.apple add command -label "About Minsky" -command aboutMinsky
84  .$id.menubar add cascade -menu .$id.menubar.apple
85  }
86 
87  menu .$id.menubar.file
88  .$id.menubar.file add command -label "Export" -command "exportGodley $id"
89 
90  menu .$id.menubar.edit -postcommand "toggleGodleyPaste $id"
91  .$id configure -menu .$id.menubar
92  .$id.menubar.edit add command -label Undo -command "$id.popup.undo 1" -accelerator $meta_menu-Z
93  .$id.menubar.edit add command -label Redo -command "$id.popup.undo -1" -accelerator $meta_menu-Y
94  .$id.menubar.edit add command -label Title -command "textEntryPopup .godleyTitle {[$id.table.title]} {setGodleyTitleOK $id}"
95  .$id.menubar.edit add command -label Cut -command "$id.popup.cut; $id.popup.requestRedraw" -accelerator $meta_menu-X
96  .$id.menubar.edit add command -label Copy -command "$id.popup.copy" -accelerator $meta_menu-C
97  .$id.menubar.edit add command -label Paste -command "$id.popup.paste; $id.popup.requestRedraw" -accelerator $meta_menu-V
98 
99  menu .$id.menubar.view
100  .$id.menubar.view add command -label "Zoom in" -command "zoomIn $id" -accelerator $meta_menu-+
101  .$id.menubar.view add command -label "Zoom out" -command "zoomOut $id" -accelerator $meta_menu--
102  .$id.menubar.view add command -label "Reset zoom" -command "$id.popup.zoomFactor 1; $id.popup.requestRedraw"
103 
104  menu .$id.menubar.options
105  .$id.menubar.options add checkbutton -label "Show Values" -variable preferences(godleyDisplay) -command setGodleyDisplay
106  .$id.menubar.options add checkbutton -label "DR/CR style" -variable preferences(godleyDisplayStyle) -onvalue DRCR -offvalue sign -command setGodleyDisplay
107  .$id.menubar.options add checkbutton -label "Enable multiple equity columns" -variable preferences(multipleEquities) -command setGodleyDisplay
108 
109  .$id.menubar add cascade -label File -menu .$id.menubar.file -underline 0
110  .$id.menubar add cascade -label Edit -menu .$id.menubar.edit -underline 0
111  .$id.menubar add cascade -label View -menu .$id.menubar.view -underline 0
112  .$id.menubar add cascade -label Options -menu .$id.menubar.options -underline 0
113  .$id.menubar add command -label Help -command {help GodleyTable} -underline 0
114 
115  }
116  wm deiconify .$id
117  raise .$id .
118 }
119 
120 proc toggleGodleyPaste id {
121  if {[getClipboard]==""} {
122  .$id.menubar.edit entryconfigure end -state disabled
123  } else {
124  .$id.menubar.edit entryconfigure end -state normal
125  }
126 }
127 
128 proc zoomOut id {
129  $id.popup.zoomFactor [expr [$id.popup.zoomFactor]/1.1]
130  $id.popup.requestRedraw
131 }
132 proc zoomIn id {
133  $id.popup.zoomFactor [expr [$id.popup.zoomFactor]*1.1]
134  $id.popup.requestRedraw
135 }
136 
137 proc mouseDown {id x y X Y} {
138  if {[$id.popup.clickTypeZoomed $x $y]=="importStock"} {
139  set importOptions [matchingTableColumns $id [$id.table.assetClass [$id.popup.colXZoomed $x]]]
140  if {[llength $importOptions]>0} {
141  if {![llength [info commands .$id.import]]} {menu .$id.import}
142  .$id.import delete 0 end
143  foreach var $importOptions {
144  .$id.import add command -label $var -command "importStockVar $id $var $x"
145  }
146  tk_popup .$id.import $X $Y
147  }
148  } else {
149  $id.popup.mouseDown $x $y
150  $id.popup.requestRedraw
151  focus .$id.table
152  }
153 }
154 
155 # warn user when a stock variable column is going to be moved to a different asset class on pressing a column button widget. For ticket 1072.
156 proc moveAssetClass {id x y X Y} {
157  set testStr [$id.popup.moveAssetClass $x $y]
158  set c [$id.popup.colXZoomed $x]
159  if {$testStr==""} {
160  mouseDown $id $x $y $X $Y
161  } elseif {$testStr=="Cannot convert stock variable to an equity class"} {
162  tk_messageBox -message $testStr -type ok -parent .$id.table
163  } else {
164  switch [tk_messageBox -message $testStr -type yesno -parent .$id.table] {
165  yes {mouseDown $id $x $y $X $Y}
166  no {mouseDown $id $x $c $X $Y}
167  }
168  }
169 }
170 
171 # warn user when a stock variable column is going to be swapped with a column from a different asset class on mouse click and drag. For ticket 1072.
172 proc swapAssetClass {id x y} {
173  set testStr [$id.popup.swapAssetClass $x $y]
174  set c [$id.popup.colXZoomed $x]
175  if {$testStr==""} {
176  $id.popup.mouseUp $x $y
177  } elseif {$testStr=="Cannot convert stock variable to an equity class"} {
178  tk_messageBox -message $testStr -type ok -parent .$id.table
179  } else {
180  switch [tk_messageBox -message $testStr -type yesno -parent .$id.table] {
181  yes { $id.popup.mouseUp $x $y}
182  no { $id.popup.mouseUp $x $c}
183  }
184  }
185  $id.popup.requestRedraw
186 }
187 
188 proc importStockVar {id var x} {
189  set oldVar [$id.table.getCell 0 [$id.popup.colXZoomed $x]]
190  if {$oldVar!=""} {
191  switch [tk_messageBox -message "Do you wish to overwrite $oldVar?" -type okcancel] {
192  ok {$id.popup.importStockVar $var $x}
193  cancel {}
194  }
195  } else {$id.popup.importStockVar $var $x}
196  $id.popup.requestRedraw
197 }
198 
199 proc setStartVar {cmd x var max} {
200  switch $cmd {
201  moveto {
202  if {$x<0} return
203  $var [expr int($x*$max)]
204  if {[$var]<1} {$var 1}
205  }
206  scroll {
207  $var [expr [$var]+$x]
208  if {[$var]<1} {$var 1}
209  if {[$var]>$max} {$var $max}
210  }
211  }
212 }
213 
214 proc scrollGodley {id rowCol cmd num args} {
215  switch $rowCol {
216  row {
217  setStartVar $cmd $num $id.popup.scrollRowStart [$id.table.rows]
218  set f [expr double([$id.popup.scrollRowStart]-1)/[$id.table.rows]]
219  .$id.vscroll set $f [expr $f+0.25]
220  }
221  col {setStartVar $cmd $num $id.popup.scrollColStart [$id.table.cols]
222  set f [expr double([$id.popup.scrollColStart]-1)/[$id.table.cols]]
223  .$id.hscroll set $f [expr $f+0.25]
224  }
225  }
226  $id.popup.requestRedraw
227 }
228 
229 proc motionCursor {w} {
230  if {[tk windowingsystem]=="aqua"} {
231  $w configure -cursor copyarrow
232  } else {
233  $w configure -cursor exchange
234  }
235 }
236 
237 proc defaultCursor {w} {$w configure -cursor {}}
238 
239 proc godleyContext {id x y X Y} {
240  .$id.context delete 0 end
241  .$id.context add command -label Help -command {help GodleyTable}
242  .$id.context add command -label Title -command "textEntryPopup .godleyTitle {[$id.table.title]} {setGodleyTitleOK $id}"
243  switch [$id.popup.clickTypeZoomed $x $y] {
244  background {}
245  row0 {
246  .$id.context add command -label "Add new stock variable" -command "$id.popup.addStockVar $x; $id.popup.requestRedraw"
247  .$id.context add cascade -label "Import variable" -menu .$id.context.import
248  .$id.context add command -label "Delete stock variable" -command "$id.popup.deleteStockVar $x; $id.popup.requestRedraw"
249  .$id.context.import delete 0 end
250  foreach var [matchingTableColumns $id [$id.table.assetClass [$id.colXZoomed $x]]] {
251  .$id.context.import add command -label $var -command "$id.popup.importStockVar $var $x; $id.popup.requestRedraw"
252  }
253  }
254  col0 {
255  .$id.context add command -label "Add flow" -command "$id.popup.addFlow $y; $id.popup.requestRedraw"
256  .$id.context add command -label "Delete flow" -command "$id.popup.deleteFlow $y; $id.popup.requestRedraw"
257  }
258  internal {}
259  }
260  set r [$id.popup.rowYZoomed $y]
261  set c [$id.popup.colXZoomed $x]
262  if {$r>=0 && $c>=0} {
263  # if cell $r,$c not already selected, select it
264  if {$r!=[$id.popup.selectedRow] || $c!=[$id.popup.selectedCol]} {
265  $id.popup.selectedRow $r
266  $id.popup.selectedCol $c
267  $id.popup.insertIdx 0
268  $id.popup.selectIdx 0
269  }
270  if {[string length [$id.table.getCell $r $c]] && ($r!=1 || $c!=0)} { # Cannot Cut cell(1,0). For ticket 1064
271  .$id.context add command -label "Cut" -command "$id.popup.cut; $id.popup.requestRedraw"
272  }
273  if {[string length [$id.table.getCell $r $c]]} {
274  .$id.context add command -label "Copy" -command "$id.popup.copy"
275  }
276  }
277  if {($r!=1 || $c!=0)} { # Cannot Paste into cell(1,0). For ticket 1064
278  .$id.context add command -label "Paste" -command "$id.popup.paste; $id.popup.requestRedraw"
279  if {[getClipboard]==""} {
280  .$id.context entryconfigure end -state disabled
281  }
282  }
283  tk_popup .$id.context $X $Y
284 }
285 
286 proc setGodleyTitleOK id {
287  $id.table.title [.godleyTitle.entry get]
288  wm title .$id "Godley Table:[$id.table.title]"
289 }
290 
291 # sets each individual Godley table displayValue preference
292 proc setGodleyDisplay {} {
293  global preferences
294  setGodleyDisplayValue $preferences(godleyDisplay) $preferences(godleyDisplayStyle)
295  multipleEquities $preferences(multipleEquities)
296  redrawAllGodleyTables
297 }
298 
299 proc exportGodley {id} {
300  global workDir type
301 
302  set fileTypes [imageFileTypes]
303  lappend fileTypes {"LaTeX" .tex TEXT} {"CSV" .csv TEXT}
304  set f [tk_getSaveFile -filetypes $fileTypes -initialdir $workDir -typevariable type]
305  if {$f==""} return
306  if [renderImage $f $type $id.popup] return
307  if {[string match -nocase *.tex "$f"]} {
308  eval $id.table.exportToLaTeX {$f}
309  } elseif {[string match -nocase *.csv "$f"]} {
310  eval $id.table.exportToCSV {$f}
311  } else {
312  switch $type {
313  "LaTeX" {eval $id.table.exportToLaTeX {$f.tex}}
314  "CSV" {eval $id.table.exportToCSV {$f.csv}}
315  }
316  }
317 }
318 
319 # make the table window a black hole for tab traversal
320 rename tk_focusPrev tk_focusPrevOrig
321 rename tk_focusNext tk_focusNextOrig
322 proc tk_focusPrev {w} {
323  if [regexp "^\.godleyWindow\[0-9\]*\.table" $w] {
324  return $w
325  } else {
326  return [tk_focusPrevOrig $w]
327  }
328 }
329 proc tk_focusNext {w} {
330  if [regexp "^\.godleyWindow\[0-9\]*\.table" $w] {
331  return $w
332  } else {
333  return [tk_focusNextOrig $w]
334  }
335 }