summaryrefslogtreecommitdiff
path: root/graphics/sam2p/contrib/sam2p.tk
blob: 99350f9d687a436db5c3ac4ba0703963c181a71e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
#!/usr/bin/wish -f
#
# sam2p.tk
# by pts@fazekas.hu at Sat Apr  6 13:14:37 CEST 2002
#
# OK:  confirm quit
# Imp: don't update widgets when error in job file
# Imp: newline mangling when loading/saving files
# Imp: /DCT, ability to type literal MiniPS code to an `entry'
# Imp: Perl parser should signal error on <hex123> etc.
# Imp: B2Press + Move + B2Release; inserts twice
# Imp: initial `focus'
# Imp: default values
# Imp: tk-start with sh
# Imp: to center of the resized window
# Imp: tooltips (mouse button 2, 3)
# Imp: less vertical padding
# Imp: really detect what kind of -*-fixed fonts we have
# Dat: TCL 8.0 doesn't have `string equal'
# Dat: never do `.text mark set sel.first 1.5', beacuse this will override tag `sel'
# Dat: `entry' widgets don't accept "insert + 1 chars" as a character index
# Dat: tag-parser treats comments as legal tokens
# Dat: <Insert> matches <Shift-Insert>, <Key-Insert> does not.
# Dat: <Motion> is mouse motion event over the sub-window
# Dat: <Enter> and <Leave> is an event sent when
# SUXX: Tcl: 8.0 doesn't have [string map ...]
# SUXX: Tk: radio and checkbuttons cannot be made smaller or larger
# SUXX: Tk: color for -relief cannot be specified
# SUXX: Tk: on UNIX, Tk converts "Times New Roman" to "times" unless specified as "-*-times new roman-*-*-*-*-*-*-*-*-*-*-iso8859-1"
# SUXX: Tk: .text cursor width cannot be extended to the right only (not to the left)
# SUXX: Tk: .text cannot show the last line on the top unless first==last
# SUXX: Tk bug: echo `bind . <ButtonRelease-2> {put got}' | wish
#       Test: 1. press button2 2. move mouse 3. release button 4. move mouse
#       `got' is printed twice. Strange: works fine with button 1 and 3.
#       Even the following doesn't help:
#       echo `bind . <B2-ButtonRelease-2> {put got}' | wish
#       Even event parameters are useless to distinguish normal and duplicate
#       events. This is a bug even on all other X11 clients. May be a GPM bug
#       or an xlib bug??

# puts [file type alma]

proc pts_PATH_sep {} {
  global tcl_platform
  if {0==[string compare windows $tcl_platform(platform)]} {return ;}
  return :
  # Imp: `macintosh'
}

proc pts_read_ok {filename} {
  if {0==[string length $filename]} {return 0}
  if {[catch {set t [file type $filename]}]} {
    if {[catch {set t [file type [file dirname $filename]]}]} {return !d}
    return !e
  }
  if {0!=[string compare $t file]} {return !f}
  if {![file readable $filename]} {return !r}
  return OK
}

proc pts_write_ok {filename} {
  if {0==[string length $filename]} {return 0}
  if {[catch {set t [file type $filename]}]} {
    if {[catch {set t [file type [set dir [file dirname $filename]]]}]} {return !d}
    if {0==[string compare $t directory] && [file writable $dir]} {return ++}
    return !dw
  }
  if {0!=[string compare $t file]} {return !f}
  if {![file writable $filename]} {return !w}
  return OK
}

proc pts_direct_bindtags {w} {
  #** Moves all binds associated with widget $w to directly widget itself.
  ## Half idea: bindtags $w "$w [bindtags $w]"
  # Dat: this assumes [lindex [bindtags $w] 0] == $w
  foreach tag [bindtags $w] {
    if {0!=[string compare $tag $w]} {
      foreach evtseq [bind $tag] {
        bind $w $evtseq [bind $w $evtseq]\n[bind $tag $evtseq]
      }
    }
  }
  bindtags $w $w
}

proc pts_readonly {w} {
  #** @param $w text or entry
  #** Makes the specified widget read-only. [$w configure -state disabled]
  #** is not OK, because it makes the insertion cursor invisible.
  pts_direct_bindtags $w
  # SUXX: cannot be avoided. Example: we must disable <Key> (typing letters),
  # but allow <Key-Left>
  bind $w <Meta-Key-d> break
  bind $w <Meta-Key-f> break
  bind $w <Meta-Key-Delete> break
  bind $w <Meta-Key-BackSpace> break
  bind $w <Control-Key-d> break
  bind $w <Control-Key-i> break
  bind $w <Control-Key-k> break
  bind $w <Control-Key-h> break
  bind $w <Control-Key-t> break
  bind $w <Key-BackSpace> break
  bind $w <Key-Delete> break
  bind $w <Key-Return> break
  bind $w <Key-KP_Enter> break
  bind $w <Key> break
  bind $w <<PasteSelection>> break
  bind $w <<Paste>> break
  bind $w <<Cut>> break
  bind $w <<Clear>> break
}

proc pts_readonly_color {w} {
  #** Calls [pts_readonly $w], and sets widget colors etc. to make the user
  #** see that it's a read-only widget.
  pts_readonly $w
  $w configure -background [[winfo toplevel $w] cget -background] -relief sunken
}

proc pts_listrev {list} {
  # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
  set i [llength $list]
  set ret {}
  while {$i>0} {incr i -1; lappend ret [lindex $list $i]}
  return $ret
}

proc pts_listrev1 {list} {
  #** Chops the 1st element of list, and returns the reverse of the rest.
  # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
  set i [llength $list]
  set ret {}
  while {$i>1} {incr i -1; lappend ret [lindex $list $i]}
  return $ret
}

## puts [pts_listrev {1 2 {3 4}}]; exit

set pts_unknown_font [font actual ..unknown..]
proc pts_has_font {f} {
  # by pts@fazekas.hu at Sat Apr  6 16:26:24 CEST 2002
  # This is rather dirty, because there is no clean way to test whether a font
  # exists in Tk.
  #** return 1 or 0
  global pts_unknown_font
  if {0==[string compare fixed $f]} {return 1}
  if {[string match -*-fixed-* $f]} {return 1} ;# Imp: first `*' shouldn't contain `-'
  # Dat: pts_unknown_font is `fixed' on UNIX systems...
  if {0==[string compare $pts_unknown_font [font actual $f]]} {return 0}
  return 1
}

proc pts_last_font {first args} {
  #** @param first,args list of font names (suitable arg for `-font' of widgets)
  #** @return the last font name that is available
  for {set i [llength $args]} {$i>0} {} {
    incr i -1
    if {[pts_has_font [set f [lindex $args $i]]]} {return $f}
  }
  return $first
}

proc pts_fix_shift_tab {} {
  # by pts@fazekas.hu at Sat Apr  6 15:22:58 CEST 2002
  set tmp [bind all <Shift-Key-Tab>]
  ## puts $tmp
  if {[string length $tmp]==0} {set tmp {tkTabToWindow [tk_focusPrev %]}}
  bind all <Shift-Key-Tab> $tmp
  catch {bind all <Key-ISO_Left_Tab> $tmp}
  # ^^^ Dat: catch is here because some systems don't have ISO_Left_Tab
}

proc pts_fix_one_tab {wPath} {
  # by pts@fazekas.hu at Sat Apr  6 15:38:43 CEST 2002
  # pts_fix_shift_tab() should be called.
  bind $wPath <Key-Tab> "[bind all <Key-Tab>]; break"
  bind $wPath <Shift-Key-Tab> "[bind all <Shift-Key-Tab>]; break"
  bind $wPath <Key-ISO_Left_Tab> "[bind all <Shift-Key-Tab>]; break"
}

proc pts_tag_set_first {w tagName index} {
  if {[$w tag nextrange $tagName 1.0 end] != ""} {
    if {[$w compare $index < $tagName.last]} {
      if {[$w compare $index < $tagName.first]} \
        {$w tag add    $tagName $index $tagName.first} \
        {$w tag remove $tagName $tagName.first $index}
    } {
      set tmp [$w index $tagName.last]
      $w tag remove $tagName 1.0 end
      $w tag add $tagName $tmp $index
    }
  }
}
proc pts_tag_set_last {w tagName index} {
  if {[$w tag nextrange $tagName 1.0 end] != ""} {
    if {[$w compare $index > $tagName.first]} {
      if {[$w compare $index > $tagName.last]} \
        {$w tag add    $tagName $tagName.last $index} \
        {$w tag remove $tagName $index $tagName.last}
    } {
      set tmp [$w index $tagName.first]
      $w tag remove $tagName 1.0 end
      $w tag add $tagName $index $tmp
    }
  }
}

proc pts_paste {w} {catch {
  set tmp [$w index insert]
  $w insert insert [selection get -displayof $w -selection CLIPBOARD]
  $w tag remove sel 0.1 end
  $w tag add sel $tmp insert
}}

proc pts_text_insert_newline {w autoindent} {
  #** Doesn't respect overstrike mode (neither does Turbo Pascal).
  #** Does auto-indenting of spaces and tabs.
  if {[$w cget -state] == "disabled"} {return}
  if $autoindent {
    if {![string length [set tmp [$w search -regexp "\[^ \t]" {insert linestart} {insert lineend}]]]} {set tmp "insert lineend"}
    $w insert insert \n[$w get {insert linestart} $tmp]
  } {$w insert insert \n}
  $w see insert
}
proc pts_text_autoindent {w bool} {
  if $bool {} ;# early error message if bool is malformed
  bind $w <Return> "pts_text_insert_newline %W $bool; break"
}

# vvv Overriding text.tcl, so we won't clobber the visible selection.
proc tkTextInsert {w s} {
  if {($s == "") || ([$w cget -state] == "disabled")} {return}
  if {[string match "* 1" [bind $w <Insert>]]} {
    # vvv in overstrike mode, overstrike only in the middle of the line
    if {[$w compare insert != "insert lineend"]} {$w delete insert}
  }
  $w insert insert $s; $w see insert
}

#proc pts_text_insert {w s overstrike} {
#  if {($s == "") || ([$w cget -state] == "disabled")} {return}
#  set tmp [$w index insert]
#  # vvv in overstrike mode, overstrike only in the middle of the line
#  if {$overstrike && [$w compare insert != "insert lineend"]} {$w delete insert}
#  $w insert insert $s; $w see insert
#}
proc pts_text_overstrike {w bool} {
  #puts [$w configure -insertontime]
  #puts [$w configure -insertofftime]
  if {$bool} {$w configure -insertofftime 0} \
             {$w configure -insertofftime [lindex [$w configure -insertofftime] 3]}
  # Dat: we cannot override the widget's <KeyPress> method here, because then
  #      we won't be able to receive cursor movement etc. events, see docs in
  #      bindtags(n) and bind(n). So support must be built into tkTextInsert,
  #      since `bind Text <KeyPress> {tkTextInsert %W %A}' is the default.
  # bind Text <KeyPress> "pts_text_insert %W %A $bool; break ;#alma"
  focus .; focus $w ;# trick to avoid non-reblinking bug in Tk8.0 Linux.
}
proc pts_text_toggle_overstrike {w bool} {
  if {$bool} {set bool 0} {set bool 1}
  pts_text_overstrike $w $bool
  bind $w <Insert> "pts_text_toggle_overstrike %W $bool"
}
proc pts_text_auto_overstrike {w bool} {
  #** Sets overstrike mode, and binds Insert to do the switching. A
  #** non-blinking cursor indicates overstrike mode. (Tk is too stupid to draw
  #** a block cursor.)
  #** @param w a text widget
  pts_text_overstrike $w $bool
  bind $w <Key-Insert> "pts_text_toggle_overstrike %W $bool"
}

# redefine tkScrollButtonDown, so it won't `sunken' the slider
# (se tcl8.2/scrlbar.tcl)
proc tkScrollButtonDown {w x y} {
  global tkPriv
  set tkPriv(relief) [$w cget -activerelief]
  if {0==[string compare slider [set element [$w identify $x $y]]]} {
    tkScrollStartDrag $w $x $y
  } else {
    $w configure -activerelief sunken
    tkScrollSelect $w $element initial
  }
}
proc tkScrollButton2Down {w x y} {
  global tkPriv
  set element [$w identify $x $y]
  if {0==[string compare $element arrow1]||0==[string compare $element arrow2]} {
    tkScrollButtonDown $w $x $y
    return
  }
  tkScrollToPos $w [$w fraction $x $y]
  set tkPriv(relief) [$w cget -activerelief]
  update idletasks
  # $w configure -activerelief sunken
  $w activate slider
  tkScrollStartDrag $w $x $y
}

option add *Dialog.msg.wrapLength 3i widgetDefault
proc pts_message_box {args} {
    global sa_normfont
    #** similar to tkMessageBox; ignores platform's native MessageBox support.
    global tkPriv tcl_platform

    set w tkPrivMsgBox
    upvar #0 $w data

    #
    # The default value of the title is space (" ") not the empty string
    # because for some window managers, a
    #		wm title .foo ""
    # causes the window title to be "foo" instead of the empty string.
    #
    set specs {
	{-default "" "" ""}
        {-icon "" "" "info"}
        {-message "" "" ""}
        {-parent "" "" .}
        {-title "" "" " "}
        {-type "" "" "ok"}
    }

    tclParseConfigSpec $w $specs "" $args

    if {[lsearch {info warning error question} $data(-icon)] == -1} {
	error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
    }
    if {$tcl_platform(platform) == "macintosh"} {
	if {$data(-icon) == "error"} {
	    set data(-icon) "stop"
	} elseif {$data(-icon) == "warning"} {
	    set data(-icon) "caution"
	} elseif {$data(-icon) == "info"} {
	    set data(-icon) "note"
	}
    }

    if {![winfo exists $data(-parent)]} {
	error "bad window path name \"$data(-parent)\""
    }

    switch -- $data(-type) {
	abortretryignore {
	    set buttons {
		{abort  -width 6 -text Abort -under 0}
		{retry  -width 6 -text Retry -under 0}
		{ignore -width 6 -text Ignore -under 0}
	    }
	}
	ok {
	    set buttons {
		{ok -width 6 -text OK -under 0}
	    }
	    if {$data(-default) == ""} {
		set data(-default) "ok"
	    }
	}
	okcancel {
	    set buttons {
		{ok     -width 6 -text OK     -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	retrycancel {
	    set buttons {
		{retry  -width 6 -text Retry  -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	yesno {
	    set buttons {
		{yes    -width 6 -text Yes -under 0}
		{no     -width 6 -text No  -under 0}
	    }
	}
	yesnocancel {
	    set buttons {
		{yes    -width 6 -text Yes -under 0}
		{no     -width 6 -text No  -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	default {
	    error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
	}
    }

    if {[string compare $data(-default) ""]} {
	set valid 0
	foreach btn $buttons {
	    if {![string compare [lindex $btn 0] $data(-default)]} {
		set valid 1
		break
	    }
	}
	if {!$valid} {
	    error "invalid default button \"$data(-default)\""
	}
    }

    # 2. Set the dialog to be a child window of $parent
    #
    #
    if {[string compare $data(-parent) .]} {
	set w $data(-parent).__tk__messagebox
    } else {
	set w .__tk__messagebox
    }

    # 3. Create the top-level window and divide it into top
    # and bottom parts.

    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w $data(-title)
    wm iconname $w Dialog
    wm protocol $w WM_DELETE_WINDOW { }
    wm transient $w $data(-parent)
    if {$tcl_platform(platform) == "macintosh"} {
	unsupported1 style $w dBoxProc
    }

    frame $w.bot
    pack $w.bot -side bottom -fill both
    frame $w.top
    pack $w.top -side top -fill both -expand 1
    if {$tcl_platform(platform) != "macintosh"} {
	$w.bot configure -relief raised -bd 1
	$w.top configure -relief raised -bd 1
    }

    # 4. Fill the top part with bitmap and message (use the option
    # database for -wraplength so that it can be overridden by
    # the caller).

    label $w.msg -justify left -text $data(-message)
    #catch {$w.msg configure -font \
    #		-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
    #}
    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
    if {$data(-icon) != ""} {
	label $w.bitmap -bitmap $data(-icon)
	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
    }

    # 5. Create a row of buttons at the bottom of the dialog.

    set i 0
    foreach but $buttons {
	set name [lindex $but 0]
	set opts [lrange $but 1 end]
	if {![string compare $opts {}]} {
	    # Capitalize the first letter of $name
	    set capName \
		[string toupper \
		    [string index $name 0]][string range $name 1 end]
	    set opts [list -text $capName]
	}

	eval button $w.$name $opts -font $sa_normfont -borderwidth 1 -pady 2 -underline 0  -command [list "set tkPriv(button) $name"]

	if {![string compare $name $data(-default)]} {
	    $w.$name configure -default active
	}
	pack $w.$name -in $w.bot -side left -expand 1 \
	    -padx 3m -pady 2m

	# create the binding for the key accelerator, based on the underline
	#
	set underIdx [$w.$name cget -under]
	if {$underIdx >= 0} {
	    set key [string index [$w.$name cget -text] $underIdx]
	    bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
	    bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
	}
	incr i
    }

    # 6. Create a binding for <Return> on the dialog if there is a
    # default button.

    if {[string compare $data(-default) ""]} {
	bind $w <Return> "tkButtonInvoke $w.$data(-default)"
    }

    # 7. Withdraw the window, then update all the geometry information
    # so we know how big it wants to be, then center the window in the
    # display and de-iconify it.

    wm withdraw $w
    update idletasks
    set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx [winfo parent $w]]}]
    set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
	    - [winfo vrooty [winfo parent $w]]}]
    wm geom $w +$x+$y
    wm deiconify $w

    # 8. Set a grab and claim the focus too.

    set oldFocus [focus]
    set oldGrab [grab current $w]
    if {$oldGrab != ""} {
	set grabStatus [grab status $oldGrab]
    }
    grab $w
    if {[string compare $data(-default) ""]} {
	focus $w.$data(-default)
    } else {
	focus $w
    }

    # 9. Wait for the user to respond, then restore the focus and
    # return the index of the selected button.  Restore the focus
    # before deleting the window, since otherwise the window manager
    # may take the focus away so we can't redirect it.  Finally,
    # restore any grab that was in effect.

    tkwait variable tkPriv(button)
    catch {focus $oldFocus}
    destroy $w
    if {$oldGrab != ""} {
	if {$grabStatus == "global"} {
	    grab -global $oldGrab
	} else {
	    grab $oldGrab
	}
    }
    return $tkPriv(button)
}


# ---

proc sa_radio {framePath variable value labelCaption args} {
  global $variable sa_normfont
  # Imp: use -text
  set $variable ""
  frame $framePath
  lappend args -variable $variable -value $value -indicatoron true -borderwidth 1
  # lappend args -value $value -indicatoron true -borderwidth 1
  eval "radiobutton $framePath.r $args"

  $framePath.r configure -activebackground [$framePath.r cget -background]
  label $framePath.l -text $labelCaption -font $sa_normfont ;# Imp: Why doesn't -anchor work??
  bind $framePath.l <ButtonRelease-1> "$framePath.r invoke"
  pack $framePath.r $framePath.l -side left
  # bind $framePath.r <Key-ISO_Left_Tab> {tkTabToWindow [tk_focusPrev %W]}
}
#proc sa_radio_pack {framePath} {}
proc sa_check {wPath variable labelCaption args} {
  global sa_boldfont
  # Imp: clicking to the right from the caption shouldn't have effect
  lappend args -font $sa_boldfont -text $labelCaption -anchor w -borderwidth 1 -variable $variable
  eval "checkbutton $wPath $args"
  $wPath configure -activebackground [$wPath cget -background]
}

proc sa_check_update {wPath variable labelCaption} {
  sa_check $wPath $variable $labelCaption -command "update_check $variable $wPath"
}

proc sa_int {framePath variable labelCaption entryWidth args} {
  # Imp: clicking to the right from the caption shouldn't have effect
  # Imp: check for int...
  global sa_normfont sa_boldfont
  frame $framePath ;# may already exist??
  label $framePath.l -text $labelCaption -font $sa_boldfont
  lappend args -relief sunken -width $entryWidth -font $sa_normfont \
    -borderwidth 1 -foreground black -background white \
    -selectbackground yellow -selectforeground black -selectborderwidth 0
  eval "entry $framePath.i $args"
  pack $framePath.l $framePath.i -side left
  # $framePath configure -activebackground [$framePath cget -background]
}

proc sa_w_text {args} {
  lappend args -relief solid -highlightcolor gray30 \
    -borderwidth 1 -foreground black -background white \
    -selectbackground gray85 -selectforeground black -selectborderwidth 0
  eval "text $args"
}

proc sa_w_entry {args} {
  lappend args -relief sunken -borderwidth 1 -foreground black -background white \
    -selectbackground yellow -selectforeground black -selectborderwidth 0
  eval "entry $args"
}

set sa_frame 0
proc sa_vframe {parentPath} {
  #** Creates and packs vertical frame, which is 5 pixel high
  global sa_frame
  set w $parentPath.saf[incr sa_frame]
  frame $w -height 5 -width 1
  pack $w -fill x
}

# vvv The mouse must be used to insert visible selection (of other apps)
bind Text <Insert> {}

bind Text <B2-Motion> {}
bind Text <Button-2> {}
# puts T[bind Text]T


# vvv allow the well-known (almost indrustry standard) Windows/Borland/GTK
#     cliboard key bindings on all platforms
event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
# event add <<PasteSelection>> <ButtonRelease-2>
# Dat: <<Paste>> is normal, <Control-Key-v> paste, which requires prior
#      <Control-Key-c>. Works across applications.
# Dat: <<PasteSelection>> is xterm/netscape-like paste, which does not
#      require <Control-Key-c>. Also works across applications.

# vvv this <<Paste>> deletes current selection even on UNIX; but we don't like that
# bind Text <<Paste>> {catch {%W delete sel.first sel.last}; catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
# vvv this <<Paste>> leaves visible selection intact
# bind Text <<Paste>> {catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
# vvv this <<Paste>> sets visible selection to the newly pasted data
bind Text <<Paste>> {pts_paste %W}

# vvv our <<PasteSelection>> doesn't move the cursor (like xterm, unlike Motif)
bind Text <<PasteSelection>> {pts_text_paste_selection %W %x %y}

bind Text <B2-Motion> {}
bind Text <Button-2> {}

# bind Text <ButtonRelease-2> {puts evt; pts_text_paste_selection %W %x %y}
#catch {
#event delete <<PasteSelection>> <ButtonRelease-2>
#}
#catch {
#event add <<PasteSelection>> <B2-ButtonRelease-2>
#event add <<PasteSelection>> <Button-2>
#}

# puts EI[event info <<PasteSelection>>]
# puts A[event info <<PasteSelection>>]BN

proc pts_text_paste_selection {w x y} {
  #** If has focus, than pastes visible selection to the unchanged cursor
  #** position; otherwise claims focus and sets cursor position to mouse.
  if {0==[string compare $w [focus -displayof $w]]} {
    catch {$w insert insert [selection get -displayof $w]}
    if {0==[string compare normal [$w cget -state]]} {focus $w}
  } {$w mark set insert [tkTextClosestGap $w $x $y]; focus $w}
}


# vvv overrides text.tcl, doesn't clobber the selection.
bind Text <1> {tkTextButton1 %W %x %y}

proc ptsTextDelLn W {
  # puts [%W index {insert linestart}]..[%W index {insert lineend + 1 chars}]
  if {[$W compare {insert lineend + 1 chars} == end]} {
    # <Control-y> in the last line must not move the cursor
    $W delete {insert linestart} {insert lineend}
  } {
    $W delete {insert linestart} {insert lineend + 1 chars}
  }
}

# vvv Overriding text.tcl, so we won't clobber the visible selection when moving
#     the cursor or just inserting
proc tkTextSetCursor {w pos} {
  if {[$w compare $pos == end]} {set pos {end - 1 chars}}
  $w mark set insert $pos
  # $w tag remove sel 1.0 end
  $w see insert
}

# vvv Overriding text.tcl, so PageUp and PageDown will jump within the page.
proc tkTextScrollPages {w count} {
  set tmp [expr {([$w cget -height]-1)*$count}]
  $w yview scroll $tmp units
  return "insert + $tmp lines"
}

# vvv Overrides text.tcl with Turbo Pascal-style Shift+Arrow selection:
#     Shift+Movement-key, when moved _from_ either end of the selection,
#     updates that end appropriately. Otherwise, it clobbers the selection,
#     and creates a new selection from the current `insert' position to the
#     position the cursor is moved to.
proc tkTextKeySelect {w newIndex} {
  # puts "[$w index insert] -> [$w index $newIndex] ([$w index end])"
  if {[$w compare end == $newIndex]} {set newIndex "end - 1 char"}
  $w mark set anchor insert
  if {[$w tag nextrange sel 1.0 end] == ""} {
    if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
  } { # already have a selection
    # puts "a=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
    if {[$w compare insert == sel.first]} {pts_tag_set_first $w sel $newIndex} \
    elseif {[$w compare insert == sel.last]} {pts_tag_set_last $w sel $newIndex} \
    { $w tag remove sel 1.0 end
      if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
    }
  }
  $w mark set insert $newIndex; $w see insert
  update idletasks
  # puts "[$w tag ranges sel]"
  # puts "b=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
}

# Imp: ^K B: Control-Space, ^K K: Control-Shift-Space

bind Text <Control-Key-y> {ptsTextDelLn %W}
bind Text <Control-Key-Y> [bind Text <Control-Key-y>]
bind Text <Control-Key-d> {if {[%W compare {insert + 1 chars} != end]} {%W delete insert}}
# ^^^ ensures that pressing `Delete' on the last empty line is a no-op
bind Text <Key-Delete> [bind Text <Control-Key-d>]
# ^^^ don't clobber visible selection
bind Text <Key-BackSpace> {if {[%W compare insert != 1.0]} {%W delete insert-1c; %W see insert}}
# ^^^ don't clobber visible selection

proc pts_entry_Delete {w} {
  set i 0
  set j -1
  set k -1
  set i [$w index insert]
  catch {set j [$w index sel.first]}
  catch {set k [$w index sel.last]}
  if {0==[string compare $i $j] || 0==[string compare $i $k]} \
    {$w delete sel.first sel.last} \
    {$w delete insert}
}

bind Entry <B2-Motion> {}
bind Entry <Button-2> {}

# vvv Overrides entry.tcl, so it won't clobber the selection.
bind Entry <Key-Delete> {pts_entry_Delete %W}
# vvv Overrides entry.tcl, so it won't clobber the selection.
bind Entry <Control-Key-d> {pts_entry_Delete %W}
bind Entry <Control-Key-i> {%W insert insert \t}

# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntrySetCursor {w pos} {$w icursor $pos; tkEntrySeeInsert $w}
# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntryInsert {w s} {if {[string length $s]} {
  $w insert insert $s
  tkEntrySeeInsert $w
}}
# vvv Overrides entry.tcl with Turbo Pascal look and feel.
proc tkEntryKeySelect {w new} {
  if {[$w selection present]} {
    set i [$w index insert]
    if {[$w index sel.first]==$i}    {$w selection from sel.last} \
    elseif {[$w index sel.last]==$i} {$w selection from sel.first} \
    {$w selection from insert}
  } {$w selection from insert}
  $w selection to $new
  $w icursor $new
  # tkEntrySeeInsert will be called by our caller.
}
# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntryBackspace w {
  set x [expr {[$w index insert] - 1}]
  if {$x >= 0} {$w delete $x}
  if {[$w index @0] >= [$w index insert]} {
    set range [$w xview]
    set left [lindex $range 0]
    set right [lindex $range 1]
    $w xview moveto [expr {$left - ($right - $left)/2.0}]
  }
}

proc pts_entry_paste_selection {w x y} {
  #** If has focus, than pastes visible selection to the unchanged cursor
  #** position; otherwise claims focus and sets cursor position to mouse.
  if {0==[string compare $w [focus -displayof $w]]} {
    catch {$w insert insert [selection get -displayof $w]}
    if {0==[string compare normal [$w cget -state]]} {focus $w}
  } {$w icursor [tkEntryClosestGap $w $x]; focus $w}
}
bind Entry <<PasteSelection>> {pts_entry_paste_selection %W %x %y}
bind Entry <Insert> {} ;# <Shift-Insert> already OK.


# vvv override tk.tcl, so it won't select the whole Entry when tab is pressed}
proc tkTabToWindow w {focus $w}

# ---

# vvv Imp: improve this on Windows
set sa_normfont [pts_last_font \
  system variable helvetica \
  arial {arial -12 normal} \
  -adobe-helvetica-medium-r-normal--11-*-100-100-*-*-iso8859-* \
  -adobe-helvetica-medium-r-normal--12-*-75-75-*-*-iso8859-* \
  sansserif dialog}]
set sa_boldfont [pts_last_font \
  sansserif system variable helvetica \
  arial {arial -12 bold} \
  -adobe-helvetica-bold-r-normal--12-*-75-75-*-*-iso8859-1 \
  -adobe-helvetica-bold-r-normal--11-80-100-100-p-60-iso8859-1 \
  dialogb]
set sa_fixfont [pts_last_font \
  fixed systemfixed fixsedsys monospaced monospace \
  -*-fixed-*-*-*--13-*-*-*-*-*-iso8859-1 \
  -misc-fixed-medium-r-semicondensed--13-*-75-75-*-*-iso8859-1 \
  6x13]
# puts sa_normfont=$sa_normfont; puts sa_boldfont=$sa_boldfont
# Dat: 100 DPI, 14-point Helvetica is too large, 11-point is somewhat small

option add *Dialog.msg.font $sa_normfont ;# respected
option add *Dialog.Button*font $sa_boldfont ;# respected

wm title . {sam2p Job Editor}
set tk_StrictMotif 0
pts_fix_shift_tab
# . configure -bg red


frame .gtop

set g .gtop.g0
frame $g

label $g.lFileFormat -text FileFormat -anchor w -font $sa_boldfont
sa_radio $g.fPSL1 FileFormat PSL1 "PS L1" -command {update_radio FileFormat PSL1}
sa_radio $g.fPSLC FileFormat PSLC "PS LC" -command {update_radio FileFormat PSLC}
sa_radio $g.fPSL2 FileFormat PSL2 "PS L2" -command {update_radio FileFormat PSL2}
sa_radio $g.fPSL3 FileFormat PSL3 "PS L3" -command {update_radio FileFormat PSL3}
sa_radio $g.fPDFB10 FileFormat PDFB1.0 "PDF B 1.0" -command {update_radio FileFormat PDFB1.0}
sa_radio $g.fPDFB12 FileFormat PDFB1.2 "PDF B 1.2" -command {update_radio FileFormat PDFB1.2}
sa_radio $g.fPDF10 FileFormat PDF1.0 "PDF 1.0" -command {update_radio FileFormat PDF1.0}
sa_radio $g.fPDF12 FileFormat PDF1.2 "PDF 1.2" -command {update_radio FileFormat PDF1.2}
sa_radio $g.fGIF89a FileFormat GIF89a "GIF 89a" -command {update_radio FileFormat GIF89a}
sa_radio $g.fEmpty FileFormat Empty Empty -command {update_radio FileFormat Empty}
sa_radio $g.fMeta FileFormat Meta Meta -command {update_radio FileFormat Meta}
sa_radio $g.fPNM FileFormat PNM PNM -command {update_radio FileFormat PNM}
sa_radio $g.fPAM FileFormat PAM PAM -command {update_radio FileFormat PAM}
sa_radio $g.fPIP FileFormat PIP PIP -command {update_radio FileFormat PIP}
sa_radio $g.fJPEG FileFormat JPEG JPEG -command {update_radio FileFormat JPEG}
sa_radio $g.fTIFF FileFormat TIFF TIFF -command {update_radio FileFormat TIFF}
sa_radio $g.fPNG FileFormat PNG PNG -command {update_radio FileFormat PNG}

pack $g.lFileFormat -fill x
pack $g.fPSL1 $g.fPSLC $g.fPSL2 $g.fPSL3 $g.fPDFB10 $g.fPDFB12 $g.fPDF10 $g.fPDF12 $g.fGIF89a \
 $g.fEmpty $g.fMeta $g.fPNM $g.fPAM $g.fPIP $g.fJPEG $g.fTIFF $g.fPNG -fill x
frame $g.pFileFormat -height 5 -width 1
pack $g.pFileFormat -fill x


set g .gtop.g1
frame $g

label $g.lSampleFormat -text SampleFormat -anchor w -font $sa_boldfont
sa_radio $g.fOpaque SampleFormat Opaque Opaque -command {update_radio SampleFormat Opaque}
sa_radio $g.fTransparent SampleFormat Transparent Transparent -command {update_radio SampleFormat Transparent}
sa_radio $g.fGray1 SampleFormat Gray1 "Gray 1" -command {update_radio SampleFormat Gray1}
sa_radio $g.fIndexed1 SampleFormat Indexed1 "Indexed 1" -command {update_radio SampleFormat Indexed1}
sa_radio $g.fMask SampleFormat Mask Mask -command {update_radio SampleFormat Mask}
sa_radio $g.fTransparent2 SampleFormat Transparent2 "Transparent 2" -command {update_radio SampleFormat Transparent2}
sa_radio $g.fGray2 SampleFormat Gray2 "Gray 2" -command {update_radio SampleFormat Gray2}
sa_radio $g.fIndexed2 SampleFormat Indexed2 "Indexed 2" -command {update_radio SampleFormat Indexed2}
sa_radio $g.fTransparent4 SampleFormat Transparent4 "Transparent 4" -command {update_radio SampleFormat Transparent4}
sa_radio $g.fRGB1 SampleFormat RGB1 "RGB 1" -command {update_radio SampleFormat Rgb1}
sa_radio $g.fGray4 SampleFormat Gray4 "Gray 4" -command {update_radio SampleFormat Gray4}
sa_radio $g.fIndexed4 SampleFormat Indexed4 "Indexed 4" -command {update_radio SampleFormat Indexed4}
sa_radio $g.fTransparent8 SampleFormat Transparent8 "Transparent 8" -command {update_radio SampleFormat Transparent8}
sa_radio $g.fRgb2 SampleFormat Rgb2 "RGB 2" -command {update_radio SampleFormat Rgb2}
sa_radio $g.fGray8 SampleFormat Gray8 "Gray 8" -command {update_radio SampleFormat Gray8}
sa_radio $g.fIndexed8 SampleFormat Indexed8 "Indexed 8" -command {update_radio SampleFormat Indexed8}
sa_radio $g.fRgb4 SampleFormat Rgb4 "RGB 4" -command {update_radio SampleFormat Rgb4}
sa_radio $g.fRgb8 SampleFormat Rgb8 "RGB 8" -command {update_radio SampleFormat Rgb8}
pack $g.lSampleFormat -fill x
pack $g.fOpaque $g.fTransparent $g.fGray1 $g.fIndexed1 $g.fMask $g.fTransparent2 $g.fGray2 $g.fIndexed2 $g.fTransparent4 \
 $g.fRGB1 $g.fGray4 $g.fIndexed4 $g.fTransparent8 $g.fRgb2 $g.fGray8 \
 $g.fIndexed8 $g.fRgb4 $g.fRgb8 -fill x
frame $g.pSampleFormat -height 5 -width 1
pack $g.pSampleFormat -fill x

set g .gtop.g2
frame $g

proc find_val_range {key} {
  #** @param key for example "/Compression", "/InputFile", of type tKey
  #** @return "" or [beg end] abs.index of the value associated with that key
  #**   (may span multiple tokens)
  global jtw ;# text widget containing the tagged job file
  set end 1.0
  while {[llength [set lst [$jtw tag nextrange tKey $end]]]} {
    set beg [lindex $lst 0]
    set end [lindex $lst 1]
    ##puts "key=<[$jtw get $beg $end]>"
    set ikey [$jtw get $beg $end]
    if {0==[string compare $ikey $key]} {

      ## puts prev=[$jtw tag prevrange tAny $end]
      set lst [$jtw tag prevrange tAny $end]
      if {0!=[llength $lst] && [$jtw compare [lindex $lst 0] < $end]
                            && [$jtw compare $end < [lindex $lst 1]]} {
        set lst [list $end [lindex $lst 1]]
      } {
        if {![llength [set lst [$jtw tag nextrange tAny $end]]]} return ""
        # ^^^ Imp: show error: found, but no value
      }
      ##puts "lst=$lst end=$end."
      ##eval "puts \[$jtw get $lst\]"
      if {2!=[llength [set tns [$jtw tag names [lindex $lst 0]]]]} return ""
      # ^^^ Imp: show error: found, but untagged value
      ##puts LT=[lindex $tns 1]:$tns:
      if {![llength [set lst [$jtw tag nextrange [lindex $tns 1] $end]]]} return ""
      # ^^^ This trick is used to find only a single tag. A single tag often
      #     means a single PostScript token, but -- for example `(a)(b)' and
      #     `[]' contain a single tag, but two tokens.
      # Imp: show better error message
      set white [$jtw get $end [lindex $lst 0]]
      ##puts aaa($white)
      if {[regexp "\[^\\000\011-\015 ]" $white]} return ""
      # ^^^ Imp: show error: key and value separated by non-whitespace
      ##puts bbb
      set beg [lindex $lst 0]
      set end [lindex $lst 1]
      set val [$jtw get $beg $end]
      set openc [expr {2*[string match <<* $val]+[string match \\\[* $val]}] ;# ]
      ## puts "openc=$openc; val=<$val>"
      if {$openc} {
        set end "$beg + $openc chars"
        set openc 1
        while {1} {
          if {![llength [set lst [$jtw tag nextrange tBrac $end]]]} return ""
          # ^^^ Imp: show error: unclosed >>
          set val [$jtw get [lindex $lst 0] [lindex $lst 1]]
          if {[string match <<* $val]} {incr openc; set end 2} \
          elseif {[string match \\\[* $val]} {incr openc; set end 1} \
          elseif {[string match >>* $val]} {incr openc -1; set end 2} \
          elseif {[string match \]* $val]} {incr openc -1; set end 1} \
          {return ""}
          # ^^^ Imp: show error: invalid tBrac
          set end "[lindex $lst 0] + $end chars"
          if {!$openc} {return "$beg [$jtw index $end]"}
        }
      }
      # puts "val=<$val>"
      # return [$jtw get $beg $end]
      return $lst
    }
  }
  return ""
}

proc update_psval {key newval} {
  #** return oldval or ""
  global jtw
  if {![llength [set found [find_val_range $key]]]} {return ""}
  set oldval [eval "$jtw get $found"]
  eval "$jtw delete $found"
  set found [lindex $found 0]
  if {[string match /* $newval]} {$jtw insert $found $newval {tAny tNameval}} \
  elseif {[string match (* $newval]} {$jtw insert $found $newval {tAny tString}} \
  elseif {[string match \[-0-9\]* $newval]} {$jtw insert $found $newval {tAny tInt}} \
  {$jtw insert $found $newval {tAny tSing}}
  $jtw mark set insert "$found + 1 chars"; $jtw see insert
  return $oldval
}

proc update_radio {key newval} {
  global jtw
  # puts "got=([find_val_range /Compression])"
  #set found [find_val_range /Hints]
  # set found [find_val_range /Profile]
  #puts "found=$found."
  #puts "is=([$jtw get [lindex $found 0] [lindex $found 1]])."
  if {![string length [update_psval /$key /$newval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc update_check {key wPath} {
  set varname [$wPath cget -variable]
  global $varname
  if {[set $varname]} {update_psval /$key true} {update_psval /$key false}
}

#set psstr_map ""
#proc psstr_map_init {} {
#  for {set i 0} {$i<32} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
#  for {set i 127} {$i<256} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
#}
#(\\)'
#psstr_map_init
#regexp {^[] -'+-[^]+} str

proc pts_psstr_q {str} {
  #** This would be <60 chars in Perl. TCL is stupid, lame and sloow.
  set ret ""
  while {1} {
    regexp {^[] -'+-[^-~]*} $str head
    # ^^^ rejects low-unprintable, >=127, backslash, lparen and rparen
    set ret $ret$head
    if {[string length $str]==[set headlen [string length $head]]} break
    scan [string index $str $headlen] %c charcode
    set ret $ret[format \\%03o [expr {$charcode&255}]]
    set str [string range $str [expr {1+$headlen}] end]
  }
  return $ret
}

proc update_str {key newval empty} {
  # Imp: regsub...
  # set newval [string map $psstr_map $newval]
  if {[string length $newval]} {set newval ([pts_psstr_q $newval])} {set newval $empty}
  if {![string length [update_psval /$key $newval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc update_int {key newval empty} {
  if {[catch {set intval [expr {0+$newval}]}] || [string compare $intval $newval]} {set intval $empty}
  if {![string length [update_psval /$key $intval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc but_save {} {
  global jtw jfn
  set f [open [$jfn get] w]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  puts -nonewline $f [$jtw get 1.0 end]
  close $f
  # bell
}

set tmpfnb "sam2p_tmp_[pid]"

proc but_relight {} {
  # Imp: error checks
  # Imp: \n transl
  # set f [open |[list tr a-z A-Z >tmp.tmp] w]
  global jtw tmpfnb
  set f [open "|perl -I. -Msam2ptol -e sam2ptol::highlight $jtw >$tmpfnb.tjb" w]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  puts -nonewline $f [$jtw get 1.0 end]
  close $f
  set f [open $tmpfnb.tjb r]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  # puts [read $f]
  eval [read $f]
  close $f
  file delete -- $tmpfnb.tjb
}

proc but_load {} {
  global jtw jfn tmpfnb
  if {[catch {set f [open [$jfn get] r]} err]} {
    pts_message_box -message "Load failed: $err"
  } {
    catch {fconfigure $f -encoding binary} ;# TCL 8.2
    fconfigure $f -translation binary
    $jtw delete 1.0 end
    $jtw insert end [read $f]
    close $f
    but_relight
    # bell

    global InputFile InputFileOK
    set InputFile ""
    if {[llength [set found [find_val_range /InputFile]]]} {
      set val [eval "$jtw get $found"]
      if {[string match (*) $val]} {
        # vvv Imp: real PS backslash interpolation, not TCL
        set InputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
      }
    }
    set InputFileOK [pts_read_ok $InputFile]

    global OutputFile OutputFileOK
    set OutputFile ""
    if {[llength [set found [find_val_range /OutputFile]]]} {
      set val [eval "$jtw get $found"]
      if {[string match (*) $val]} {
        # vvv Imp: real PS backslash interpolation, not TCL
        set OutputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
      }
    }
    set OutputFileOK [pts_write_ok $OutputFile]

    global FileFormat
    set FileFormat ""
    if {[llength [set found [find_val_range /FileFormat]]]} {
      set FileFormat [string range [eval "$jtw get $found"] 1 end]
    }

    global SampleFormat
    set SampleFormat ""
    if {[llength [set found [find_val_range /SampleFormat]]]} {
      set SampleFormat [string range [eval "$jtw get $found"] 1 end]
    }

    global Compression
    set Compression ""
    if {[llength [set found [find_val_range /Compression]]]} {
      set Compression [string range [eval "$jtw get $found"] 1 end]
    }

    global TransferEncoding
    set TransferEncoding ""
    if {[llength [set found [find_val_range /TransferEncoding]]]} {
      set TransferEncoding [string range [eval "$jtw get $found"] 1 end]
    }

    global Predictor
    set Predictor ""
    if {[llength [set found [find_val_range /Predictor]]]} {
      set Predictor [eval "$jtw get $found"]
    }

    global TransferCPL
    set TransferCPL ""
    if {[llength [set found [find_val_range /TransferCPL]]]} {
      set TransferCPL [eval "$jtw get $found"]
    }

    global Effort
    set Effort ""
    if {[llength [set found [find_val_range /Effort]]]} {
      set Effort [eval "$jtw get $found"]
    }

    global RecordSize
    set RecordSize ""
    if {[llength [set found [find_val_range /RecordSize]]]} {
      set RecordSize [eval "$jtw get $found"]
    }

    global K
    set K ""
    if {[llength [set found [find_val_range /K]]]} {
      set K [eval "$jtw get $found"]
    }

    global Quality
    set Quality ""
    if {[llength [set found [find_val_range /Quality]]]} {
      set Quality [eval "$jtw get $found"]
    }

    global WarningOK
    set WarningOK ""
    if {[llength [set found [find_val_range /WarningOK]]]} {
      if {[string compare true [eval "$jtw get $found"]]} {set WarningOK 1} {set WarningOK 1}
    }

    global TmpRemove
    set TmpRemove ""
    if {[llength [set found [find_val_range /TmpRemove]]]} {
      if {[string compare true [eval "$jtw get $found"]]} {set TmpRemove 1} {set TmpRemove 1}
    }

  }
}

proc but_quit {} {
  if {0==[string compare yes [pts_message_box -type yesno -title {Confirm quit} -message "Quit now, without saving?"]]} exit
}

proc but_run {} {
  # by pts@fazekas.hu at Fri Apr 26 23:43:17 CEST 2002
  global JobFile
  sa_debug_append "exec sam2p $JobFile:\n"
  # if {[catch {set ret [exec sam2p $JobFile 2>@ stdout]} ret]} {}
  if {[catch {set ret [exec sh -c {exec sam2p $1 2>&1} sam2p. $JobFile]} ret]} {
    set ret "Error running sam2p:\n$ret"
  }
  # puts ($ret)
  sa_debug_append $ret\n\n
}

# option add *Dialog*Label*font fixed
# option add *Label*Font times
#option add *font times
#option add *$g*font times
#option add *Dialog.msg.background red

label $g.lCompression -text Compression -anchor w -font $sa_boldfont
sa_radio $g.fNone Compression None None -command {update_radio Compression None}
sa_radio $g.fLZW Compression LZW LZW -command {update_radio Compression LZW}
sa_radio $g.fZIP Compression ZIP ZIP -command {update_radio Compression ZIP}
sa_int $g.fZIP.fEffort Effort Effort 2 -textvariable Effort
bind $g.fZIP.fEffort.i <FocusOut> {update_int Effort [%W get] pop}
pack $g.fZIP.fEffort -side left
sa_radio $g.fRLE Compression RLE RLE -command {update_radio Compression RLE}
sa_int $g.fRLE.fRecordSize RecordSize R.S 3 -textvariable RecordSize
bind $g.fRLE.fRecordSize.i <FocusOut> {update_int RecordSize [%W get] pop}
pack $g.fRLE.fRecordSize -side left
sa_radio $g.fFax Compression Fax Fax -command {update_radio Compression Fax}
sa_int $g.fFax.fK K K 5 -textvariable K
bind $g.fFax.fK.i <FocusOut> {update_int K [%W get] pop}
pack $g.fFax.fK -side left
sa_radio $g.fDCT Compression DCT DCT -command {update_radio Compression DCT}
sa_radio $g.fIJG Compression IJG IJG -command {update_radio Compression IJG}
sa_int $g.fIJG.fQuality Quality Q'lty 3 -textvariable Quality
bind $g.fIJG.fQuality.i <FocusOut> {update_int Quality [%W get] pop}
pack $g.fIJG.fQuality -side left
sa_radio $g.fJAI Compression JAI JAI -command {update_radio Compression JAI}
#label $g.fJAI.haha -text haha
#pack $g.fJAI.haha -side left
pack $g.lCompression -fill x
pack $g.fNone $g.fLZW $g.fZIP $g.fRLE $g.fFax $g.fDCT $g.fIJG $g.fJAI -fill x
sa_vframe $g

sa_int $g.lPredictor Predictor Predictor 3 -textvariable Predictor
bind $g.lPredictor.i <FocusOut> {update_int Predictor [%W get] pop}
pack $g.lPredictor -fill x
sa_vframe $g

sa_check_update $g.cWarningOK WarningOK WarningOK
# -textvariable WarningOK
pack $g.cWarningOK -fill x
sa_vframe $g

label $g.lTransferEncoding -text TransferEncoding -anchor w -font $sa_boldfont
sa_radio $g.fBinary TransferEncoding Binary Binary -command {update_radio TransferEncoding Binary}
sa_radio $g.fASCII TransferEncoding ASCII ASCII -command {update_radio TransferEncoding ASCII}
sa_radio $g.fHex TransferEncoding Hex Hex -command {update_radio TransferEncoding Hex}
sa_radio $g.fA85 TransferEncoding A85 A85 -command {update_radio TransferEncoding A85}
pack $g.lTransferEncoding -fill x
pack $g.fBinary $g.fASCII $g.fHex $g.fA85 -fill x
frame $g.pTransferEncoding -height 5 -width 1
pack $g.pTransferEncoding -fill x

sa_int $g.fTransferCPL TransferCPL TransferCPL 3 -textvariable TransferCPL
bind $g.fTransferCPL.i <FocusOut> {update_int TransferCPL [%W get] pop}

pack $g.fTransferCPL -fill x
sa_vframe $g

sa_check_update $g.cTmpRemove TmpRemove {Tmp Remove}
pack $g.cTmpRemove -fill x
sa_vframe $g


set g .gtop.g3
frame $g

sa_w_text $g.t -width 58 -height 18 -wrap none -font $sa_fixfont
pts_fix_one_tab $g.t
pts_text_autoindent $g.t 1
pts_text_auto_overstrike $g.t 0
# $g.t insert end "<<%sam2p job file\n  /InputFile (alma)\n  /OutputFile (korte)\n  /Profile \[\n    /Compression /LZW/Predictor 13\n    /Hints<</DCT <</a true /b (>>)>> >>\n  ]\n>>\n"
# $g.t insert end [read [open template.job r]]
# Imp: close file...
$g.t mark set insert 1.0; $g.t see insert
$g.t tag configure tAny; $g.t tag lower tAny sel
$g.t tag configure tSing -foreground "#003f7f"; $g.t tag raise tSing sel
$g.t tag configure tString -foreground "#007f7f"; $g.t tag raise tString sel
$g.t tag configure tKey -foreground "#00007f"; $g.t tag raise tKey sel
$g.t tag configure tNameval -foreground "#0000ff"; $g.t tag raise tNameval sel
$g.t tag configure tBrac -foreground "#ff0000"; $g.t tag raise tBrac sel
$g.t tag configure tComment -foreground "#007f00"; $g.t tag raise tComment sel
$g.t tag configure tInt -foreground "#3f0000"; $g.t tag raise tInt sel
$g.t tag configure tError -background "#ffdddd"; $g.t tag lower tError sel

# puts X[bindtags $g.t]X
# puts X[bind $g.t]X
# puts XZ[bind all]X

set jtw $g.t

# Imp: delete tmp.tmp

# -font sansserif
# puts [$g.t tag ranges tSing]
# reground blue

# update idletasks; puts [winfo geometry $g.t] ;# not ready, has to be packed first

frame $g.f
sa_w_text $g.f.td -width 1 -height 13 -wrap char -font $sa_fixfont \
  -yscrollcommand "$g.f.sd set" -spacing3 2
$g.f.td configure -selectbackground yellow ;# override
scrollbar $g.f.sd -command "$g.f.td yview" -width 11 -elementborderwidth 2 \
  -relief flat -borderwidth 1 -takefocus 0 -troughcolor gray65
$g.f.sd configure -activebackground [$g.f.sd cget -background]

# OK: non-editable, but not disabled (we need the cursor!)
# $g.f.td configure -background [lindex [$g.f.td configure -background] 3]
pts_readonly_color $g.f.td
# puts $g.f.td
# puts TD:[bind .gtop.g3.f.td <Key-Return>]

pts_fix_one_tab $g.f.td
$g.f.td insert end "Debug messages, sam2p output:\n\n"
# $g.f.td insert end "0\n1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n"
# $g.f.td insert end "21\n22\n23\n24\n25\n26\n27\n28\n29\n30\n31\n32\n33\n34\n35\n36\n37\n38\n39\n"
$g.f.td mark set insert 1.0; $g.f.td see insert
set debugtext $g.f.td

pack $g.t -expand 0 -fill x
pack $g.f.td -expand 1 -fill both -side left
pack $g.f.sd -fill both -side left
pack $g.f -expand 1 -fill both

pack .gtop.g0 .gtop.g1 .gtop.g2 -side left
pack .gtop.g3 -expand 1 -fill both -side left

frame .gbot
frame .gbot.gbl

set g .gbot.gbl.fCurdir
frame $g
label $g.l -text "Current dir" -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont
# bind $g.e <FocusOut> {update_str e [%W get] pop}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
$g.e insert 0 [pwd]

# puts [bind .gbot.gbl.fCurdir.e]

bind Text <B2-Motion> {}
bind Text <Button-2> {}
# puts T[bind Text]T
# puts [bind Text <Button-2>]
#puts ([bind Entry <Tab>])

#foreach evtseq [bind Entry] {
#  if {[string match <Key-*> $evtseq]
#   || [string match <*-Key-*> $evtseq]
#   || [string match <*-Key> $evtseq]
#     } {
#    bind $g.e $evtseq {break}
#    puts +:$evtseq
#  } {
#    #puts -:$evtseq
#  }
#}

# Dat: this assumes [lindex [bindtags $g.e] 0] == $g.e
#foreach tag [bindtags $g.e] {
#  foreach evtseq [bind $tag] {
#    # if {0==[string length [bind $g.e $evtseq]]} {bind $g.e $evtseq [bind $tag $evtseq]}
#  }
#}

pts_readonly_color $g.e


# event info <<Clear>>
#bind $g.e <Key-Tab> {# nothing}
#bind $g.e <Key-ISO_Left_Tab> {# nothing}
# puts /[bind $g.e]
# puts :[bind $g.e <Key-Return>]

set g .gbot.gbl.fJobFile
frame $g
label $g.l -text JobFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable JobFile
label $g.r -text OK -font $sa_normfont -textvariable JobFileOK -width 2
bind $g.e <FocusOut> {set JobFileOK [pts_write_ok $JobFile]}
set jfn $g.e
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left


set g .gbot.gbl.fInputFile
frame $g
label $g.l -text InputFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable InputFile
label $g.r -text OK -font $sa_normfont -textvariable InputFileOK -width 2
bind $g.e <FocusOut> {update_str InputFile [%W get] pop; set InputFileOK [pts_read_ok $InputFile]}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left
set InputFileOK [pts_read_ok $InputFile]

set g .gbot.gbl.fOutputFile
frame $g
label $g.l -text OutputFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable OutputFile
label $g.r -text OK -font $sa_normfont -textvariable OutputFileOK -width 2
bind $g.e <FocusOut> {update_str OutputFile [%W get] pop; set OutputFileOK [pts_write_ok $OutputFile]}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left

pack .gbot.gbl.fCurdir .gbot.gbl.fJobFile .gbot.gbl.fInputFile .gbot.gbl.fOutputFile -expand 1 -fill x

frame .gbot.ha
button .gbot.ha.bLoad -text {Load Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_load
bind . <Alt-Key-l> but_load
button .gbot.ha.bSave -text {Save Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_save
bind . <Alt-Key-s> but_save

frame .gbot.hb
button .gbot.hb.bRun -text {Run} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_run
bind . <Alt-Key-r> but_run
button .gbot.hb.bQuit -text {Quit} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_quit
bind . <Alt-Key-q> but_quit
pack .gbot.gbl -expand 1 -fill x -side left
pack .gbot.ha.bLoad .gbot.ha.bSave
pack .gbot.hb.bRun .gbot.hb.bQuit
pack .gbot.ha .gbot.hb -side left

pack .gtop -expand 1 -fill both
pack .gbot -expand 0 -fill x
update idletasks ;# a sima [update] helyett, hogy a "geometry" jó legyen
scan [wm geometry .] "%dx%d%s" width height tmp
wm minsize . $width $height


set env(PATH) $env(PATH)[pts_PATH_sep].
#if {[catch {set ret [exec sam2p --help 2>&1]} ret]} {}
if {[catch {set ret [exec sh -c {exec sam2p --help 2>&1}]} ret]} {
  set ret "Error:\n$ret"
}

proc sa_debug_append msg {
  global debugtext
  $debugtext insert end $msg
  $debugtext mark set insert end
  $debugtext see insert
}

sa_debug_append $ret\n\n
# puts ($ret)


$jfn delete 0 end
if {[llength $argv]} {$jfn insert 0 [lindex $argv 0]; but_load} {
  $jfn insert 0 template.job; but_load; $jfn delete 0 end
  set InputFileOK 0
  set OutputFileOK 0
  set JobFileOK 0
}
# set InputFile hello
# but_load
# puts $argv
# puts TD:[bind .gtop.g3.f.td <Key-Return>]


#__END__