-
Notifications
You must be signed in to change notification settings - Fork 1
/
rebgui-ctx.r
1146 lines (1069 loc) · 25.8 KB
/
rebgui-ctx.r
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
REBOL [
Title: "RebGUI system"
Owner: "Ashley G. Trüter"
Version: 0.4.17
Date: 2-Jun-2006
Purpose: "Creates the RebGUI context and associated global functions."
Acknowledgements: {
The following people have contributed code and / or coding suggestions to this project:
Allen Kamp
Alphe Salas-Schuman (shadwolf)
Anton Rolls
Ashley G. Trüter
Carl Sassenrath
Christian Ensel
Christopher Ross-Gill
David Oliver (Oldes)
Gabriele Santilli
Graham Chiu
Gregg Irwin
Henrik Mikael Kristensen
Pascal Lefevre
Richard (Cyphre)
Robert M. Müench
Romano Paolo Tenca
Vincent Ecuyer
Volker Nitsch
...
and the many others who have taken the time to look at RebGUI and discuss it on AltME.
}
Globals: [
ctx-rebgui
display
request-color
request-date
request-dir
request-file
show-focus
show-color
show-data
show-text
show-title
splash
]
History: {
0.3.0 Merged RebGUI contexts into a single context named ctx-rebgui
Removed many words from global namespace
Replaced slm, sld, slc and slw with locale*
Removed pre View 1.3 code such as construct, as-pair, etc
Added check for View version
Renamed face to rebface
Added show-color accessor function
Added init as a standard attribute
Added rebfocus synonym for ctx-rebgui/edit/focus
Set old-size on span-resize
0.3.1 Widget color changed
Check for View 1.3 or higher
0.3.2 Added %rebgui-layout.r
0.3.3 Minor changes for SDK 1.3.1 compatibility
0.3.4 span-resize now protects against negative sizes
0.3.5 Swapped splash parameters around (Graham)
rebface/options now defaults to []
Renamed rebfocus to show-focus
Added clear-text function
Added /focus refinement to show-text
0.3.6 Extended rebface definition by adding alt-action & dbl-action attributes
Added clear-widget accessor
0.3.7 Added unview-keep function
0.3.8 clear-widget now accepts block of faces as well
Extended rebface definition with focus-action and unfocus-action facets
Added app-on-focus / app-on-unfocus handlers
0.3.9 Fixed bug in unview-keep
Added true and false colors
0.4.0 Added set-locale function (for Robert)
0.4.1 Added set-locale to global context
Removed old reference to offset-cache
Added new sizes context
Replaced context with make object!
Replaced func/function/does/has with make function!
Added global error handler
Added font [name] to effects
0.4.2 Added face/line-list: none to 'show-text and 'clear-text
16 Added words block for layout function
17 Added set-attribute & set-attributes accessor functions
18 Added enable-show and disable-show to override nested uses of SHOW
19 Added rebgui-view-patch.r to patch certain View functions
}
]
if system/version < 1.3.1 [make error! "RebGUI requires View 1.3.1 or greater"]
; change these paths to suit your local dir structure
;#include %/c/rebol/rebol-sdk/source/gfx-colors.r
;#include %/c/rebol/rebol-sdk/source/gfx-funcs.r
#include-check %rebgui-view-patch.r
;query/clear system/words
; system/locale (colors are given in descending order of brightness)
system/locale: make system/locale [
colors: [
black
navy
blue
violet
forest
maroon
coffee
purple
coal
oldrab
red
brick
crimson
leaf
brown
aqua
teal
magenta
sienna
water
olive
papaya
mint
gray
green
orange
pewter
khaki
cyan
tan
silver
pink
sky
gold
wheat
yellow
beige
snow
linen
ivory
white
]
words: []
language: "English"
dictionary: none
dict: []
]
; Generic mezz funcs
;BEG fixed by Cyphre, sponsored by Robert
find-face: func [
"Finds face under mouse cursor"
pnt [pair!] "mouse coordinate"
f [object! block!] "pane from where to start search"
widgets [block! none!] "block of 'sensitive widgets' or none"
/only "return the face only if the condition is true"
condition [function!]
/local p result w
][
if all [
object? :f
any [
not only
all [
only
condition f
any [
not get in f 'pane
not apply :find-face [pnt f/pane widgets only :condition]
]
]
]
any [
all [
none? widgets
w: within? pnt win-offset? f f/size
any [only not get in f 'pane]
]
all [
widgets
in f 'type
find widgets f/type
w: within? pnt win-offset? f f/size
]
]
][
return f
]
p: either object? :f [get in f 'pane][:f]
any [
either block? :p [
result: none
foreach fac head reverse copy p [
if all [object? :fac fac: apply :find-face [pnt fac widgets only :condition]][
result: fac
break
]
]
result
][
if object? :p [
apply :find-face [pnt :p widgets only :condition]
]
]
all [w f]
]
]
resize-face: make function! [
face [object!]
/size
new-size [pair!]
/no-show
/local
span
][
unless new-size [
new-size: face/parent-face/size
]
unless face/init-size [
face/init-size: face/size
]
ctx-rebgui/span-resize face new-size - face/size face/size/x / face/init-size/x face/size/y / face/init-size/y
all [
block? face/pane
span: span? face/pane
face/size: span/1 + span/2
]
unless no-show [
show face
]
]
reset-widgets: make function! [
f [object! block!] "pane from where to start search"
/types widget-types [block! none!] "block of 'sensitive widgets' or none"
/local p
][
if all [
object? :f
any [
all [
none? widget-types
find first f 'type
]
all [
widget-types
find first f 'type
find widget-types f/type
]
]
][
if find first f 'reset-action [
f/reset-action f
]
]
p: either object? :f [get in f 'pane][:f]
either block? :p [
foreach fac head reverse copy p [
if object? :fac [
reset-widgets/types :fac widget-types
]
]
][
if object? :p [
reset-widgets/types :p widget-types
]
]
]
;END fixed by Cyphre, sponsored by Robert
distance?: make function! [
"Returns the distance between two points."
p1 [pair!] "First point"
p2 [pair!] "Second point"
][
square-root abs p1/x - p2/x ** 2 + abs p1/y - p2/y ** 2
]
; Accessor functions
show-color: make function! [
"Sets a widget's color attribute."
face [object!]
color [tuple! word! none!]
/no-show
][
face/color: either word? color [get color] [color]
unless no-show [
show face
]
]
show-panel: make function! [
"Sets a panel widget's data content."
panel [object!]
data [object! block!]
/no-show
] [
panel/pane: either object? data [data/pane][data]
resize-face/no-show/size panel panel/size
unless no-show [
show panel
]
]
show-data: make function! [
"Sets a widget's data attribute."
face [object!]
data [any-type!]
/no-show
][
face/data: either series? data [copy data] [data]
unless no-show [
show face
]
]
show-text: make function! [
"Sets a widget's text attribute."
face [object!] "Widget"
text [any-type!] "Text"
/no-show
/focus
][
face/line-list: none
insert clear face/text form text
attempt [insert clear face/loc/text form text]
all [face/type = 'area face/para face/para/scroll: 0x0 face/pane/data: 0]
unless no-show [
either focus [ctx-rebgui/edit/focus face] [show face]
]
]
clear-text: make function! [
"Clears a widget's text attribute."
face [object!]
/no-show "Don't show"
/focus
][
face/line-list: none
clear face/text
attempt [clear face/loc/text]
all [face/type = 'area face/para face/para/scroll: 0x0 face/pane/data: 0]
unless no-show [
either focus [ctx-rebgui/edit/focus face] [show face]
]
]
clear-widget: make function! [
"Clears an iterated widget's data attribute(s)."
face [object! block!]
/default value [integer! logic! block!] "Reset to other value(s)"
][
foreach f reduce either object? face [[face]] [face] [
unless default [value: none]
switch/default f/type [
check-group [ ; none! true! false!
foreach item f/pane [item/data: value]
]
led-group [ ; none! true! false!
foreach item f/pane [item/data: value]
]
radio-group [ ; none! integer!
if value = 0 [value: none] ; handle zero case
either value [
f/pane/:value/feel/engage f/pane/:value 'down none
][
if f/data [
value: f/data
clear skip f/pane/:value/effect/draw 7
f/data: none ; 0.3.8
]
]
]
table [ ; none! integer! block!
clear f/picked
if value [insert f/picked value]
f/redraw
]
text-list [ ; none! integer! block!
clear f/picked
if value [insert f/picked value]
f/redraw
]
][
gui-error reform [f/type "not supported by show-widget"]
]
]
show face
]
set-attribute: make function! [
face [object!] "Window dialog face"
attribute [word!] "Attribute to set"
value [any-type!]
/no-show "Don't show"
/focus
] [
face/:attribute: case [
string? value [
face/line-list: none
all [face/type = 'area face/para face/para/scroll: 0x0 face/pane/data: 0]
form value
]
series? value [copy value]
attribute = 'color [either word? value [get value] [value]]
true [value]
]
unless no-show [
either focus [ctx-rebgui/edit/focus face] [show face]
]
]
set-attributes: make function! [
face [object!] "Window dialog face"
attributes [block!] "Block of attribute/value pairs to set"
/no-show "Don't show"
] [
foreach [attribute value] attributes [
set-attribute/no-show face attribute value
]
any [no-show show face]
]
show-title: make function! [
"Sets window title"
face [object!] "Window dialog face"
title [string!] "Window bar title"
][
face/text: title
all [face/loc face/loc/text: face/text]
face/changes: 'text
show face
]
get-state: make function! [
"Retrieves face state as a state value block."
face [object!] "Face to get state for"
/local b w out
] [
any [in face 'state-words return none]
out: make block! length? face/state-words
parse face/state-words [
any [
[set w word! set b block! (insert/only tail out do b)]
| [set w word! (insert/only tail out get w)]
]
]
out
]
set-state: make function! [
"Sets face state from a state value block."
face [object!] "Face to set state for"
state "State value block"
/local words
] [
any [in face 'state-action return false]
words: remove-each value copy face/state-words [not word? value]
repeat i length? words [
face/state-action pick words i pick state i
]
if in face 'redraw [face/redraw]
]
truncate-face: make function! [
"Truncates the text in a face to one line and adds '...' or defined ending. Modifies face text."
face [object!] "The face object to use (without paragraph wrapping)"
/width w [integer!] "Maximum width of text in pixels"
/ending end-string [char! string!] "Suitable for numeric and percent formatting"
/no-show "Don't show"
/local end-pos end-size font text text-size trunc-size
][
if none? face/text [exit]
font: face/font
face/font: make face/font [align: 'left]
text-size: first size-text face
text: face/text
end-string: any [end-string "..."]
face/text: end-string
end-size: first size-text face
trunc-size: any [w face/size/x - either face/para [face/para/margin/x + face/para/origin/x][0]]
face/text: text
end-pos: offset-to-caret face as-pair trunc-size - end-size face/font/size / 2
unless trunc-size > text-size [
face/text: copy face/text
face/text: head append clear at face/text index? end-pos end-string
]
face/font: font
any [no-show show face] ; do not show, when using this in an iterated face while also using locale
]
set-help-mode: make function! [
"Sets the help mode and changes the cursor for all windows. Word! for a help mode. NONE to deactivate help mode."
mode [word! none!]
][
ctx-rebgui/help-mode: mode
]
get-help-mode: make function! [
"Returns the current help mode."
] [
ctx-rebgui/help-mode
]
set-help-function: make function! [
"Sets the help mode callback function."
function [function!]
] [
ctx-rebgui/help-function: :function
]
set-help-face-function: make function! [
"Sets the help face callback function."
function [function!]
] [
ctx-rebgui/help-face-function: :function
]
splash: make function! [
"Displays a centered splash screen for one or more seconds."
face [object!] "The face object to display"
seconds [integer!] "Number of seconds to display splash"
][
face/type: 'splash
face/offset: max 0x0 system/view/screen-face/size - face/size / 2
view/new/options face 'no-title
wait seconds
]
watermark: make function! [
src [image! block! object!]
watermark [image! block! object!]
/transparency
alpha [integer!]
/padding
pad [pair!]
/rotate
rot [number!]
/local
dr s c lx ly
][
src: to-image either block? src [ctx-rebgui/layout src][src]
pad: any [pad 20x20]
watermark: to-image make face [
image: either image? watermark [
rot: any [rot -30]
watermark
][
rot: any [rot 0]
to-image either block? watermark [ctx-rebgui/layout watermark][watermark]
]
edge: none
size: image/size
effect: [grayscale]
]
watermark/alpha: any [alpha 240]
s: watermark/size + pad
lx: to-integer (src/size/x / s/x + 1) * 2
ly: to-integer (src/size/y / s/y + 1) * 2
c: as-pair lx * s/x / 2 ly * s/y / 2
dr: compose [
translate (c / 2)
rotate (rot)
translate (negate c)
image-filter nearest
]
repeat y ly [
repeat x lx [
insert tail dr compose [image (as-pair x - 1 * s/x + either even? y [pad/x][- pad/x] y - 1 * s/y) watermark]
]
]
to-image make face [
image: src
edge: none
size: image/size
effect: [draw dr]
]
]
;
; --- RebGUI context ---
;
ctx-rebgui: make object! [
view*: system/view
update?: true
level: 0
mouse-offset: 0x0
context-menus: copy []
menu-open?: false
key-shortcuts: copy []
active-win: none
help-mode: none
help-function: none
help-face-function: none
debug: make object! [
redraws: false ;show faces region when they are redrawn
]
set 'enable-show func [face /force] [
level: max 0 either force [0][level - 1]
if zero? level [
update?: true
;if face [show-native face]
if face [show face]
]
face
]
set 'disable-show does [
level: level + 1
update?: false
]
; global error handler
gui-error: make function! [
error [string!]
][
write/append/lines %rebgui.log reform [now error]
make error! error
]
; unview-keep
unview-keep: make function! [num [integer!] /local pane] [
pane: head view*/screen-face/pane
while [(length? pane) > num] [remove back tail pane]
show view*/screen-face
]
; Localization
locale*: system/locale
set 'set-locale make function! [language [string! none!] /local dat-file] [
clear locale*/words
clear locale*/dict
if exists? dat-file: join what-dir either language [rejoin [%language/ language %.dat]] [%locale.dat] [
locale*: construct/with load dat-file locale*
]
if exists? locale*/dictionary: rejoin [what-dir %dictionary/ locale*/language %.dat] [
locale*/dict: load locale*/dictionary
]
]
set-locale none
set 'load-locale make function! [file [file! block!]][
clear locale*/words
clear locale*/dict
either file? file [
locale*: construct/with load file locale*
][
locale*: construct/with copy/deep file locale*
]
]
show-native: get in system/words 'show
system/words/show: func [
[catch]
face [object! block!]
/local err
][
ctx-rebgui/show-wrapper face
if update? [ctx-rebgui/show-native face]
]
alpha: to-bitset [#"A" - #"Z" #"a" - #"z"]
show-wrapper: func [
face [object! block!]
][
either object? :face [
trans face
][
if block? :face [
foreach f face [
unless function? :f [
all [word? f f: get f]
trans f
]
]
]
]
]
trans: func [
f [object!]
/local
fac bl s
][
either found? get in f 'translate-action [
f/translate-action f
][
if found? get in f 'loc [ ; changed by Robert
if none? f/loc/text [
f/loc/text: f/text
]
f/text: translate f/loc/text
all [string? f/text not find f/text alpha f/loc/text: none]
if block? f/effect [
either any [
none? f/loc/effect
all [
f/loc/last-effect
f/loc/last-effect <> f/effect
]
][
f/loc/effect: copy/deep f/effect
][
f/effect: copy/deep f/loc/effect
]
parse f/effect [
some [
'draw set bl block! (
parse bl [
some [
s: string! (
s/1: translate s/1
)
| skip
]
]
)
| skip
]
]
f/loc/last-effect: copy/deep f/effect
]
]
]
all [
debug/redraws
f/edge: make ctx-rebgui/widgets/default-edge [color: random 255.255.255 size: 2x2]
]
switch type?/word get in f 'pane [
block! [
foreach fac f/pane [
all [
word? fac
fac: get fac
]
all [
object? fac
trans fac
]
]
]
object! [
trans f/pane
]
]
]
set 'translate make function! [
"Dynamically translate a string or block of strings"
text "String (or block or strings) to translate"
/reverse "do reverse lookup"
/local match txt loc?
] [
; note that if text is not a string! or block! then no error will be raised
; this is an optimization so code that calls translate does not have to be wrapped
; in an "if string? text ..." type construct
if all [series? text locale*/words] [
txt: copy/deep any [loc?: find/match text "<loc>" text]
all [
string? txt
any [
; 1st try normal direction: from -> to
match: select/skip/case locale*/words txt 2
; 2nd try reverse direction: to -> from
either reverse
[attempt [match: first back find/case locale*/words txt]]
[false]
]
insert clear txt match
return txt
]
if block? txt [
foreach word txt [
all [
string? word
match: select/skip/case locale*/words word 2
insert clear word match
]
]
return txt
]
]
either loc? [txt][text]
]
; App-level event definitions
on-focus: make function! [face] [true]
on-unfocus: make function! [face] [true]
; Base face definition
system/words/face: system/standard/face: make system/standard/face [
loc: reduce ['data none 'text none 'effect none 'last-effect none]
]
rebface: make system/standard/face [
init-offset: init-size: tool-tip: tool-tip-delay: cursor: color: edge: help: para: font: feel: alt-action: dbl-action: state-words: init: none
dirty: false
unfocus-action: focus-action: custom-action: true ; <<< Henrik added CUSTOM-ACTION, STATE-WORDS, HELP and DIRTY
options: []
]
; Base effect defintions
effects: construct/with either exists? %effects.dat [load %effects.dat] [[]] make object! [
window: none
font: "Verdana"
]
; Base sizes
sizes: construct/with either exists? %sizes.dat [load %sizes.dat] [[]] make object! [
cell: 4
line: cell * 5
slider: cell * 4
font: 12 ; pt size
font-height: none ; pixel height - set by widget init code
margin: 4
gap: 2
]
; Base color definitions
colors: construct/with either exists? %colors.dat [load %colors.dat] [[]] make object! [
window: 236.233.216 ; used by display.r
widget: 244.243.238
edge: 127.157.185
edit: white ; area, field, password, etc
over: gold ; active button, tab, splitter, etc
menu: 49.106.197 ; menu, popup highlight
menu-item: black
menu-item-hilite: white
menu-item-ghosted: 140.140.140
btn-up: 200.214.251
btn-down: 216.232.255
btn-text: 77.97.133
true: leaf ; radio-group, LED, check-box
false: red ; LED, check-box
;BEG fixed by Cyphre, sponsored by Robert
tooltip-bkg: 255.255.225
tooltip-text: 0.0.0
tooltip-edge: 0.0.0
grid-hilite-row: 255.255.0
grid-hilite-cell: 255.0.0
grid-focus: 248.180.53
grid-header: 200.214.251
grid-header-over: 216.232.255
;END fixed by Cyphre, sponsored by Robert
]
; dialect words
words: [
after
at
button-size
cursor
data
do
edge
effect
feel
field-size
font
help
indent
label-size
margin
on-focus
on-unfocus
on-reset
on-resize
on-translate
options
pad
para
rate
return
reverse
space
text-size
tight
;BEG by Cyphre, sponsored by Robert
tool-tip
tooltip-action
text-align
user-data
left
right
center
;END by Cyphre, sponsored by Robert
]
;widget names
widget-names: none
;BEG fixed by Cyphre, sponsored by Robert
; list of tooltip sensitive widgets
tooltip-sensitive: [
anim
area
arrow
bar
box
button
chart-new
check
check-group
chevron
drop-list
drop-tree
edit-list
field
gauge
help
image
input-grid
label
led
led-group
number-field
password
pie-chart
progress
radio-group
slider
spider
splitter
table
text
text-list
title-group
tool-bar
xyplot
warn
]
tool-tip-delay: 0:0:1
set 'add-key-shortcut func [
ctrl [logic!]
shift [logic!]
key [issue!]
action [block!]
/local f
][
either f: find/skip key-shortcuts reduce [ctrl shift key] 4 [
change/only skip f 3 action
][
insert tail key-shortcuts reduce [ctrl shift key action]
]
]
set 'remove-key-shortcut func [
ctrl [logic!]
shift [logic!]
key [issue!]
][
remove/part find/skip key-shortcuts reduce [ctrl shift key] 4 4
]
os-win-metrics: switch/default fourth system/version [
3 [8x27] ; Windows - XP theme height is 34px, Classic theme 27px. Better to use smaller value to avoid 'height jump'.
][
4x30 ; Others
]
set 'resize-window make function! [
"Force window to change its size."
win-face [object!]
new-size [pair!]
][
win-face/size: any [
all [select win-face/options 'min-size max win-face/options/min-size - os-win-metrics new-size]
new-size
]
show win-face
]
;END fixed by Cyphre, sponsored by Robert
; funcs
span-resize: make function! [face [object!] delta [pair!] ratio-x [number!] ratio-y [number!] /local tmp] [
if face/span = 'no-resize [exit]
if face/span [
tmp: face/old-size
face/old-size: face/size
any [face/init-size face/init-size: face/size]