-
Notifications
You must be signed in to change notification settings - Fork 0
/
auxi.red
1333 lines (1186 loc) · 40.9 KB
/
auxi.red
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
Red [
title: "Auxiliary helper funcs for Draw-based widgets"
author: @hiiamboris
license: BSD-3
]
; #include %../common/assert.red
;@@ not sure if infxinf should be exported, but it's used by custom styles, e.g. spiral
exports: [by thru . abs half skip? linear! linear? planar! planar? range! range? make-range .. using when only trigger impose clip ortho boxes-overlap? infxinf opaque blend batch]
; ;; readability helper instead of reduce/into [] clear [] ugliness
; #macro [#reduce-in-place block!] func [[manual] s e] [
; change/only s 'reduce/into
; insert/only insert e 'clear copy []
; s
; ]
; ;@@ watch out for #5009 for a better way to specify refinements
; #macro [#compose-in-place any refinement! block!] func [[manual] s e /local path] [
; path: copy 'compose/into
; e: next s
; while [refinement? :e/1] [append path to word! take e]
; change/only s path
; insert/only insert e 'clear copy []
; s
; ]
by: thru: make op! :as-pair
.: make op! :as-point2D ;@@ unfortunately, comma is not for the taking :(
abs: :absolute
svf: system/view/fonts
svm: system/view/metrics
svmc: system/view/metrics/colors
digit!: charset [#"0" - #"9"] ;@@ add typical charsets to /common repo
INFxINF: (1.#inf, 1.#inf) ;-- used too often to always type it numerically
;@@ consider: OxINF Ox-INF INFxO -INFxO (so far they don't seem useful)
skip?: func [series [series!]] [-1 + index? series]
half: func [x] [x / 2]
round-down: func [x] [round/to/floor x 1]
round-up: func [x] [round/to/ceiling x 1]
planar!: make typeset! [pair! point2D!]
linear!: make typeset! [integer! float!] ;@@ or real! ? real is more like single datatype, while linear is a typeset
planar?: func [value [any-type!]] [find planar! type? :value]
linear?: func [value [any-type!]] [find linear! type? :value]
along: make op! function [
"Pick PAIR's dimension along AXIS (integer is treated as a square)"
pair [planar! linear!]
axis [word!] (find [x y] axis)
][
pick pair * 1x1 axis
]
block-of?: make op! func [
"Test if all of BLOCK's values are of type TYPE"
block [block!] type [datatype!]
][
parse block [any type]
]
using: function [
"Return CODE bound to a context with WORDS local to it"
words [block!] "List of words" (words block-of? word!)
code [block!]
][
words: construct map-each w words [to set-word! w]
with words code
]
get-safe: function [path [path! word!]] [ ;@@ REP 113; this in case of error is 10x slower than 'get'
try [return x: get path] none ;@@ workaround for #5300 here
]
; set-many: function [
; "Set each target to a result of the corresponding expression evaluation"
; targets [block!] exprs [block!]
; ][
; forall targets [set :targets/1 do/next exprs 'exprs]
; exprs
; ]
;@@ copy/deep does not copy inner maps (#2167), clone tries to encode system/words, so this kludge is still must have
copy-deep-map: function [m [map!]] [
m: make map! copy/deep to [] m ;@@ workaround for copy/deep #(map) not copying nested strings/blocks
foreach [k v] m [if map? :v [m/:k: copy-deep-map v]]
m
]
clone: function [ ;@@ should space cloning be based on this?
"Obtain a complete deep copy of the data"
data [any-object! map! series!]
/flat "Make a shallow copy (unlike native copy, keeps items before head)"
] with system/codecs/redbin reshape [
either flat [
switch type?/word :data [
@(to [] series!) [
at append (clear copy head data) head data
index? data
]
map! @(to [] any-object!) [copy data]
]
][
decode encode data none
]
]
;; ranges support needed by layout, until such datatype is introduced, have to do with this
;; since it's for layout usage only, I don't care about a few allocated objects, no need to optimize it
;; ranges are used by spaces to constrain their size, but those are read-only
;; object = 468 B, block = 92 B, map = 272 B (cannot be reacted to)
;; space with draw=[] = 512 B, rectangle = 1196 B, timer does not need this at all
range!: object [min: max: none]
range?: func [x [any-type!]] [all [object? :x (class-of x) = class-of range!]]
..: make op! make-range: function [ ;-- name `to` cannot be used as it's a native
"Make a range from A to B"
a [scalar! none!]
b [scalar! none!]
][
#assert [any [not a not b b >= a] "Reversed limits detected!"]
make range! [min: a max: b]
]
;; kludges for very limited bitset functionality
nonzero-byte: charset [1 - 255]
lowest-bit: function [bs [bitset!]] [
if bs/0 [return 0] ;-- negated bitset?
bin: to #{} bs
unless p: find bin nonzero-byte [return none]
base: 8 * skip? p
repeat i 8 [if find bs bit: base + i - 1 [break]]
bit
]
highest-bit: function [bs [bitset!]] [
if bs/2'147'483'647 [return none] ;-- negated bitset
bin: to #{} bs
unless p: find/last bin nonzero-byte [return none]
base: 8 * skip? p
repeat i 8 [if find bs bit: base + 8 - i [break]]
bit
]
#assert [
none? lowest-bit charset []
none? highest-bit charset []
none? highest-bit make bitset! 100
0 = lowest-bit charset [0 - 20]
3 = lowest-bit charset [3 - 20]
18 = lowest-bit charset [18 - 20]
20 = highest-bit charset [0 - 20]
17 = highest-bit charset [3 - 17]
4 = highest-bit charset [3 - 4]
]
unroll-bitset: function [bs [bitset!]] [
result: clear []
if lo: lowest-bit bs [
hi: highest-bit bs
for i: lo hi [if bs/:i [append result i]] ;@@ this is really dumb
]
copy result
]
{
useful pair invariants to test in which quadrant a point is located
points: a, b
a = min a b <=> 0x0 = min 0x0 b - a <=> B is in Q1 to A, axis-inclusive <=> A is in Q3 to B, axis-inclusive
a = max a b <=> 0x0 = max 0x0 b - a <=> B is in Q3 to A, axis-inclusive <=> A is in Q1 to B, axis-inclusive
1x1 = min 1x1 b - a <=> B is in Q1 to A, axis-exclusive <=> A is in Q3 to B, axis-exclusive
-1x-1 = max -1x-1 b - a <=> B is in Q3 to A, axis-exclusive <=> A is in Q1 to B, axis-exclusive
a = min a b <=> b = max a b
}
;; chainable pair comparison - instead of `within?` monstrosity
; >> 1x1 +< 2x2 +<= 3x3 +< 4x4
; == 4x4
;; very hard to find a sigil for these ops
;; + resembles intersecting coordinate axes, so can be read as "2D comparison"
+<=: make op! func [
"Chainable pair comparison (non-strict)"
a [planar! none!] b [planar!]
][
all [a a == min a b b] ;-- strict equality, otherwise 0 <= -1e30 will pass
; all [a a/x <= b/x a/y <= b/y b]
]
+<: make op! func [
"Chainable pair comparison (strict)"
a [planar! none!] b [planar!]
][
all [a a/x < b/x a/y < b/y b]
]
;+>: make op! func [a b] [a = max a b + 1]
;+>=: make op! func [a b] [a = max a b]
inside?: make op! function [
"Test if POINT is inside the SPACE"
point [planar!] space [object!]
][
within? point 0x0 space/size
]
above: function [ ;-- a replacement for space/parent/parent/parent/parent shit
"Get parent space of specific type (or none)"
child [object!]
type [word!]
][
while [space? child: child/parent] [if child/type = type [return child]] ;@@ use locate + tree iterator
child
]
host-of: function [space [object!]] [
all [path: get-host-path space path/1]
]
host-box-of: function [ ;@@ temporary until REP #144
"Get host coordinates of a space (kludge! not scaling aware!)"
space [object!] (space? space)
][
box: reduce [(0,0) space/size]
while [parent: space/parent] [
if host? parent [return box]
#assert [select parent 'map]
geom: select/same parent/map space
#assert [geom]
forall box [box/1: box/1 + geom/offset]
space: parent
]
none
]
boxes-overlap?: function [
"Get nonzero intersection size of boxes A1-A2 and B1-B2, or none if they don't intersect"
A1 [planar!] A2 [planar!]
B1 [planar!] B2 [planar!]
][
(0,0) +< ((min A2 B2) - max A1 B1) ;-- 0x0 +< intersection size
]
#assert [
not boxes-overlap? -2x-2 -1x-1 1x1 2x2
not boxes-overlap? -2x1 -1x2 1x-2 2x-1
not boxes-overlap? -2x-2 0x0 0x0 2x2
2x2 = boxes-overlap? -2x-2 1x1 -1x-1 2x2
2x2 = boxes-overlap? -2x-1 1x2 -1x-2 2x1
]
segments-overlap?: function [
"Get nonzero intersection size of segments A1-A2 and B1-B2, or none if they don't intersect"
A1 [linear!] A2 [linear!]
B1 [linear!] B2 [linear!]
][
sec: (min A2 B2) - max A1 B1
all [sec > 0 sec] ;-- 0 < intersection size
]
vec-length?: function [v [planar!]] [ ;-- this is still 2x faster than compiled `distance? 0x0 v`
v/x ** 2 + (v/y ** 2) ** 0.5
]
closest-box-point?: function [
"Get coordinates of the point on box B1-B2 closest to ORIGIN"
B1 [planar!] "inclusive" B2 [planar!] "inclusive"
/to origin: (0,0) [planar!] "defaults to 0x0"
][
clip origin B1 B2
]
box-distance?: function [
"Get distance between closest points of box A1-A2 and box B1-B2 (negative if overlap)"
A1 [planar!] "inclusive" A2 [planar!] "non-inclusive"
B1 [planar!] "inclusive" B2 [planar!] "non-inclusive"
][
either isec: boxes-overlap? A1 A2 B1 B2 [ ;-- case needed by box arrangement algo
negate min isec/x isec/y
][
AC: A1 + A2 / 2
BC: B1 + B2 / 2
AP: closest-box-point?/to A1 A2 BC
BP: closest-box-point?/to B1 B2 AP
vec-length? BP - AP
]
]
; test for it:
; view [a: base 100x20 loose b: base 20x100 loose return t: text 100 react [t/text: form box-distance? a/offset a/offset + a/size b/offset b/offset + b/size]]
~=: make op! function [a [number!] b [number!]] [
to logic! any [
a = b
(abs a - b) < 1e-6
]
]
; slope?: function [
; "Get the slope of the line (X1,Y1)-(X2,Y2)"
; x1 [float!] y1 [float!]
; x2 [float!] y2 [float!]
; ][
; (y2 - y1) / (x2 - x1)
; ]
;@@ move into common?
make-stack: function [
"Create a stack of given row size"
size [pair!] (size/1 > 0) "row size X row count"
][
context [
data: make [] size/1 * size/2
push: func [values [block!]] [data: tail reduce/into values data]
pop: does compose [clear data: skip data (negate size/1)]
top: does compose [skip data (negate size/1)]
empty: does [data: clear head data]
]
]
; block-buffers: make hash! 100
; buffer-for: function [block [block!]] [
; any [
; clear buf: select/only/same/skip buffers block 2 ;@@ unfortunately #4466 - search is linear
; repend buffers [buf: copy []]
; ]
; buf
; ]
; cached-reduce: function [block [block!]] [
; reduce/into block buffer-for block
; ]
; cached-compose: function [block [block!]] [
; compose/into block buffer-for block
; ]
;; MEMO: requires `function` scope or `~~p` will leak out
#macro [#expect skip] func [[manual] bgn end /local quote? rule error name] [
quote?: all [word? bgn/2 bgn/2 = 'quote remove next bgn]
rule: reduce [bgn/2]
if quote? [insert rule 'quote] ;-- sometimes need to match block literally
name: either string? bgn/2 [bgn/2][mold/flat bgn/2]
error: compose/deep [
do make error! rejoin [
(rejoin ["Expected "name" at: "]) mold/part ~~p 100
]
]
change/only remove bgn compose [(rule) | ~~p: (to paren! error)]
bgn
]
;@@ move this into /common once debugged
in-out-func: function [spec [block!] body [block!]] [
lit-words: keep-type spec lit-word!
block-rule: [any [
ahead set w get-word! if (find lit-words w)
change only skip (as paren! reduce ['get/any to word! w])
| ahead set w word! if (find lit-words w)
change only skip (as paren! reduce ['get to word! w])
| ahead set w set-word! if (find lit-words w)
insert ('set) change skip (to word! w)
| ahead any-list! into block-rule
| ahead any-path! into path-rule
| ahead word! 'quote skip
| skip
]]
path-rule: [any [
ahead set w get-word! if (find lit-words w) change only skip (as paren! reduce ['get/any to word! w])
| ahead any-list! into block-rule
| skip
]]
parse body: copy/deep body block-rule
function spec body
]
include-into: function [
"Include flag into series if it's not there"
series [series!] flag [any-type!]
][
unless find/only series :flag [append/only series :flag]
series
]
exclude-from: function [
"Exclude flag into series if it's there"
series [series!] flag [any-type!]
][
remove find/only series :flag
series
]
set-flag: function [
"Include or exclude flag from series depending on present? value"
series [series!] flag [any-type!] present? [logic! none!]
][
either present? [include-into series :flag][exclude-from series :flag]
]
has-flag?: function [ ;-- used in popups
"Test if FLAGS is a block and contains FLAG"
flags [any-type!]
flag [word!]
][
none <> all [block? :flags find flags flag]
]
toggle: function [
"Flip the value of a boolean flag"
flag [path!]
][
set flag not get flag
]
trigger: function [
"Trigger on-change reaction on the target"
target [word! path!]
][
set/any target get/any target
]
flush: function [
"Grab a copy of SERIES, clearing the original"
series [series!]
][
also copy series clear series
]
before: function [
"Set PATH to VALUE, but return the previous value of PATH"
'path [any-path! any-word!] value
][
also get path set path :value
]
explode: function [ ;@@ use map-each when fast; split produces strings not chars :(
"Split string into a block of characters"
string [string!]
/into buffer [any-list!]
][
unless buffer [buffer: make [] length? string]
parse string [collect after buffer keep pick to end]
buffer
]
zip: function [
"Interleave a list with another list or scalar"
list1 [series!]
list2 [any-type!]
/into result: (make list1 2 * length? list1) [series!]
][
#assert [any [not series? :list2 equal? length? list1 length? list2]]
repeat i length? list1 pick [
[append/only append/only result :list1/:i :list2/:i]
[append/only append/only result :list1/:i :list2]
] series? :list2
result
]
#assert [
"" = zip "" []
[] = zip [] []
[1 2 3 4] = zip [1 3] [2 4]
[1 #"2" 3 #"4"] = zip [1 3] "24"
"1234" = zip "13" [2 4]
"1-3-" = zip "13" #"-"
]
;@@ make a REP with this? (need use cases)
;@@ this is no good, because it treats paths as series
native-swap: :system/words/swap
swap: function [a [word! series!] b [word! series!]] [
either series? a [
native-swap a b
][
set a before (b) get a
]
]
only: function [
"Turn falsy values into empty block (useful for composing Draw code)"
value [any-type!] "Any truthy value is passed through"
][
any [:value []] ;-- block is better than unset here because can be used in set-word assignments
]
;-- `compose` readability helper variant 2
; when: func [test value] [only if :test [do :value]]
;-- `compose` readability helper variant 3
;-- by the way, works in rejoin/composite as empty block results in empty string!!!
when: func [
"If TEST is truthy, return VALUE, otherwise an empty block"
test [any-type!]
:value [any-type!] "Paren is evaluated, block or other value is returned as is"
][
only if :test [either paren? :value [do value][:value]]
]
;-- simple shortcut for `compose` to produce blocks only where needed
wrap: func [
"Put VALUE into a block"
value [any-type!]
][
reduce [:value]
]
remake: function [proto [object! datatype!] spec [block!]] [
construct/only/with compose/only spec proto
]
area?: function [xy [planar!]] [
either nan? area: xy/x * 1.0 * xy/y [0.0][area] ;-- 1.0 to support infxinf here (overflows otherwise)
]
#assert [
zero? area? (0,0)
zero? area? (0,1.#inf) ;-- for the purposes of having a tangible area to draw on, INFx0 is empty
1.#inf = area? (1.#inf,1.#inf)
]
span?: func [xy [planar!]] [abs xy/y - xy/x] ;@@ or range? but range? tests for range! class
order-pair: function [xy [planar!]] [either xy/1 <= xy/2 [xy][reverse xy]]
order: function [a [word! path!] b [word! path!]] [ ;@@ should this receive a block of any number of paths?
if greater? get a get b [set a before (b) get a]
]
bit-range: func [range [pair!]] [
range: order-pair range
charset reduce [range/1 '- range/2]
]
;@@ this should be just `clip` but min/max have no vector support
clip-vector: function [v1 [vector!] v2 [vector!] v3 [vector!]] [
repeat i length? r: copy v1 [r/:i: clip v1/:i v2/:i v3/:i]
r
]
resolve-color: function [color [tuple! word! issue!]] [
case [
word? color [svmc/:color]
issue? color [hex-to-rgb color]
'else [color]
]
]
impose: function [
"Impose COLOR onto BGND and return the resulting color"
bgnd [tuple! word!] "Alpha channel ignored"
color [tuple! word!] "Alpha channel determines blending amount"
][
c3: c4: (resolve-color color) + 0.0.0.0
c3/4: none
bg-amnt: c4/4 / 255
(resolve-color bgnd) * bg-amnt + (1 - bg-amnt * c3)
]
#assert [
0.0.0 = impose 0.0.0 0.0.0
0.0.0 = impose 100.50.10 0.0.0
50.25.5 = impose 100.50.10 0.0.0.128
]
HSL2XYZ: function [
"Transform HSL cylindrical coordinate into cartesian XYZ"
HSL [point3D!]
][
as-point3D
HSL/2 * cosine HSL/1
HSL/2 * sine HSL/1
HSL/3
]
XYZ2HSL: function [
"Transform cartesian XYZ coordinate into HSL cylindrical"
XYZ [point3D!]
][
as-point3D
(arctangent2 XYZ/2 XYZ/1) + 360 % 360 ;-- map [-180,180] into [0,360)
vec-length? XYZ/1 . XYZ/2 ;-- this doesn't check if it's >1, assumes correct
XYZ/3
]
blend: function [
"Get new color from a projection of BGND->COLOR vector scaled by AMNT (alpha channels ignored)"
bgnd [tuple! word!]
color [tuple! word!]
amnt [number!] "< 100% to pull color closer to bgnd, > 100% to push further"
][
;; in XYZ space it's possible to e.g. push red->green towards cyan
bg-xyz: HSL2XYZ RGB2HSL resolve-color bgnd
fg-xyz: HSL2XYZ RGB2HSL resolve-color color
hsl: XYZ2HSL fg-xyz - bg-xyz * (clip -1e10 1e10 amnt) + bg-xyz ;-- avoid 1.#inf - leads to unwanted NaNs
HSL2RGB/tuple clip (0,0,0) (360,1,1) hsl
]
#assert [
255.0.0 = blend red green 0
0.255.0 = blend red green 1
191.191.63 = blend red green 0.5
255.0.81 = blend red green -1
0.255.81 = blend red green 2
255.0.127 = blend red green -1.#inf
0.255.127 = blend red green 1.#inf
]
enhance: function [
"Push COLOR further from BGND (alpha channels ignored)"
bgnd [tuple! word!]
color [tuple! word!]
amnt [number!] "Should be over 100%" (amnt >= 100%)
][
bg-hsl: RGB2HSL resolve-color bgnd
fg-hsl: RGB2HSL resolve-color color
sign: pick [1 -1] fg-hsl/3 >= bg-hsl/3
fg-hsl/3: clip 0 1 fg-hsl/3 + (amnt - 1 / 2 * sign)
HSL2RGB/tuple fg-hsl
]
;@@ any better name?
opaque: function [
"Add alpha channel to the COLOR"
color [tuple! word! issue!] "If a word, looked up in system/view/metrics/colors"
alpha [percent! float!] (all [0 <= alpha alpha <= 1])
][
color: 0.0.0.0 + resolve-color color
color/4: to integer! 255 - (255 - color/4 * alpha)
color
]
list-range: function [a [integer!] b [integer!]] [ ;-- directional by design (used by list-view selection)
step: sign? range: b - a
result: make [] 1 + abs range
append result a
while [a <> b] [append result a: a + step] ;@@ use map-each
result
]
min-safe: function [a [scalar! none!] b [scalar! none!]] [
any [all [a b min a b] a b]
]
max-safe: function [a [scalar! none!] b [scalar! none!]] [
any [all [a b max a b] a b]
]
update-EMA: function [
"Update exponential moving average with new parameter measurements"
estimate [word! path!] "Current EMA"
measurement [number!] "New measurement result"
period [integer!] "Averaging period"
/batch num: 1 [integer!] "Apply a whole batch of identical measurements"
][
weight: 1 - (1 / period) ** num
set estimate
to type? get estimate ;-- required when modifying component of a pair
add (get estimate) * weight measurement * (1 - weight)
]
interpolate: function [
"Interpolate a value between V1 and V2"
v1 [number!]
v2 [number!]
t [number!] "[0..1] corresponds to [V1..V2]"
/clip "Force T within [0..1], making outside regions constant"
/reverse "Treat T as a point on [V1..V2], return a point on [0..1]"
][
case/all [
reverse [t: t - v1 / (v2 - v1)]
clip [t: max 0.0 min 1.0 t]
not reverse [t: add v1 * (1.0 - t) v2 * t]
]
t
]
#assert [
50% = interpolate -100% 200% 0.5
]
build-index: reproject: reproject-range: none ;-- don't make these global, keep in spaces/ctx
context [
;@@ can parts of this context be generalized and put into /common?
;@@ maybe indexed search can be included into %search.red?
set 'build-index function [
"Build an index of given length for fast search over points"
points [block! vector!] (4 <= length? points)
length [integer!] (length >= 1)
][
#assert [all [points/1 = 0 points/2 = 0]] ;@@ I may want to generalize it later, but no need yet
yindex: copy xindex: make vector! length
clear xindex clear yindex
top: skip tail points -2
xrange: max 1e-10 top/1 - points/1 ;-- 1e-10 to avoid zero division by step
yrange: max 1e-10 top/2 - points/2
dx: xrange * 1.000001 / length ;-- stretch a bit to ensure never picking at the tail
dy: yrange * 1.000001 / length
ix: iy: 1
ipoint: -1 foreach [xi yi] next next points [ ;@@ use for-each/reverse?
ipoint: ipoint + 2
ix: 1 + to integer! xi / dx
iy: 1 + to integer! yi / dy
append/dup xindex ipoint ix - length? xindex
append/dup yindex ipoint + 1 iy - length? yindex
]
obj: construct [points: xstep: ystep: xindex: yindex:]
set obj reduce [points dx dy xindex yindex]
obj
]
#assert [
[1] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 1 'xindex
[2] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 1 'yindex
[1 3] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 2 'xindex
[2 4] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 2 'yindex
[1 3 5] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 3 'xindex
[2 4 6] = to [] select build-index [0 0 2 2 6 6 8 8 10 10] 3 'yindex
[1 3 5] = to [] select build-index [0 0 2 2 6 6 10 10] 3 'xindex
[2 4 6] = to [] select build-index [0 0 2 2 6 6 10 10] 3 'yindex
[1 1 5] = to [] select build-index [0 0 4 4 6 6 10 10] 3 'xindex
[2 2 6] = to [] select build-index [0 0 4 4 6 6 10 10] 3 'yindex
[1 1 3] = to [] select build-index [0 0 5 5 10 10] 3 'xindex
[2 2 4] = to [] select build-index [0 0 5 5 10 10] 3 'yindex
]
locate: function [
points [block!]
index [vector!]
step [number!] (step > 0)
value [number!]
][
#assert [value / step < length? index "value out of the function's domain"]
pos: at points pick index 1 + to integer! value / step
;; find *first* segment that contains the value
while [all [pos/5 value > pos/3]] [pos: skip pos 2] ;@@ use general locate when fast
#assert [all [pos/1 <= value value <= (pos/3 + 0.1)]] ;-- 0.1 to account for rounding error
pos
]
find-x: function [fun [object!] x [number!]] [
locate fun/points fun/xindex fun/xstep x
]
find-y: function [fun [object!] y [number!]] [
locate fun/points fun/yindex fun/ystep y
]
#hide [#assert [
f: build-index [0 0 1 2 2 4 2 5 4 8] 3
[1 1 3 3 7 7 7] = map-each x [0 1 1.1 2 2.1 3.9 4] [index? find-x f x]
[2 2 4 4 6 8 8] = map-each y [0 2 2.1 4 4.1 5.1 8] [index? find-y f y]
]]
;; 'reproject' meaning get inverse projection from X to function line and then project into Y
;@@ maybe there's a better name I don't see yet... X2Y and Y2X func pair?
set 'reproject function [
"Find value Y=F(X) given X on a non-decreasing function"
fun [object!] "Indexed function as a sequence of points [X1 Y1 ... Xn Yn]"
x [number!] "X value"
/up "If Y is not unique, return highest corresponding value (default: lowest)"
/inverse "Given Y find an X"
/truncate "Convert result to integer"
][
xs: either inverse [find-y fun x][find-x fun x]
;; find *last* segment that contains the value
if up [while [all [xs/5 xs/3 <= x]] [xs: skip xs 2]] ;@@ use for-each
ys: either inverse [back xs][next xs]
t: either xs/1 == xs/3 [ ;-- avoid zero-division
either up [1][0]
][
clip 0 1 x - xs/1 / (xs/3 - xs/1) ;-- clip to work around rounding issues
]
y: interpolate ys/1 ys/3 t
if truncate [y: to integer! y]
y
]
comment [ ;-- interactive test
f: build-index [0 0 1 2 2 4 2 5 4 5 7 8]
sc: 400 / 8
view [
base white 400x400 all-over on-over [try [
trace: map-each [x y] f/points [as-point2D sc * x sc * y]
x: event/offset/x / sc
y: event/offset/y / sc
y1: sc * reproject f x
y2: sc * reproject/up f x
x1: sc * reproject/inverse f y
x2: sc * reproject/inverse/up f y
face/draw: compose/deep [
pen magenta line (trace)
pen cyan
shape [
move (event/offset) vline (y1)
move (event/offset) hline (x1)
move (0 by y1) 'hline (event/offset/x)
move (0 by y2) 'hline (event/offset/x)
move (x1 by 0) 'vline (event/offset/y)
move (x2 by 0) 'vline (event/offset/y)
]
]
]]
]
]
set 'reproject-range function [
"Return segment [Y1 Y2] projected by function FUN from segment [X1 X2]"
fun [object!] "Indexed function as a sequence of points [X1 Y1 ... Xn Yn]"
x1 [number!]
x2 [number!] (x2 >= x1)
/inverse "Given Ys find Xs"
/truncate "Convert result to integers"
][
reduce [
reproject/:inverse/:truncate fun x1
reproject/:inverse/:truncate/up fun x2
]
]
]
;; constraining is used by `render` to impose soft limits on space sizes
constrain: function [
"Clip SIZE within LIMITS"
size [planar!] "use infxinf for unlimited; negative size will become zero"
limits [object! (range? limits) none!] "none if no limits"
][
unless limits [return size] ;-- most common case optimization
;@@ NOTE: always use type?/word, not type? here, otherwise construction syntax is lost during 'inline' call
;@@ see #5387
min: switch/default type?/word limits/min [
pair! point2D! [limits/min]
integer! float! [limits/min . 0] ;-- numeric limits only affect /x
] [0x0] ;-- none and invalid treated as 0x0
max: switch/default type?/word limits/max [
pair! point2D! [limits/max]
integer! float! [limits/max . 1.#inf] ;-- numeric limits only affect /x
] [infxinf] ;-- none and invalid treated as infinity
clip size min max
]
#assert [
infxinf = constrain infxinf none
(20,16) = constrain 8x16 20 .. none
]
;@@ rewrite this using inoutfunc?
for: function ['word [word! set-word!] i1 [integer! pair!] i2 [integer! pair!] (same? type? i1 type? i2) code [block!]] [
either integer? i1 [
if i2 < i1 [exit] ;@@ return none or unset? `while` return value is buggy anyway
set word i1 - 1
while [i2 >= set word 1 + get word] code
][
range: i2 - i1 + 1
unless 1x1 +<= range [exit] ;-- empty range
xyloop i: range [
set word i - 1 + i1 ;@@ does not allow index changes within the code, but allows in integer part above
do code
]
]
]
closest-number: function [n [number!] list [block!]] [
p: remove find/case (sort append list n) n
case [
head? p [p/1]
tail? p [p/-1]
(n - p/-1) < (p/1 - n) [p/-1]
'else [p/1]
]
]
#assert [
3 = closest-number 3 [1 2 3]
3 = closest-number 3 [3 4 5]
3 = closest-number 1 [3 4 5]
3 = closest-number 3 [1 4 5 3 2]
4 = closest-number 3 [1 4 5 0]
]
polar2cartesian: func [radius [linear!] angle [linear!]] [
as-point2D (radius * cosine angle) (radius * sine angle)
]
ortho: func [
"Get axis orthogonal to a given one"
xy [word! pair!] "One of [x y 0x1 1x0]"
][
;; switch here is ~20% faster than select/skip
; select/skip [x y y x 0x1 1x0 1x0 0x1] xy 2
switch xy [x ['y] y ['x] 0x1 [1x0] 1x0 [0x1]]
]
set-pair: function [
"Set words to components of a pair value"
words [block!]
pair [planar! block!] "Can be a block (works same as set native then)"
][
set words/1 pair/1
set words/2 pair/2
]
#hide [#assert [
a: b: 0
set-pair [a b] 2x3
a = 2
b = 3
set-pair [a b] [4 5]
a = 4
b = 5
]]
set-axis: function [
"Change VALUE of a given AXIS of an anonymous POINT"
point [planar!]
axis [word!] (find [x y] axis)
value [linear!]
][
point/:axis: value
point
]
#assert [2x3 = set-axis set-axis 0x0 'y 3 'x 2]
axis2pair: func [xy [word!]] [
switch xy [x [1x0] y [0x1]]
]
anchor2axis: func [nesw [word!]] [
; switch nesw [n s ['y] w e ['x]];
switch nesw [n s ↑ ↓ ['y] w e → ← ['x]] ;-- arrows are way more readable, if harder to type (ascii 24-27)
]
anchor2pair: func [nesw [word!]] [
; switch nesw [n [0x-1] s [0x1] w [-1x0] e [1x0]]
switch nesw [e → [1x0] s ↓ [0x1] n ↑ [0x-1] w ← [-1x0]]
]
normalize-alignment: function [
"Turn block alignment into a -1x-1 to 1x1 pair along provided Ox and Oy axes"
align [block! pair!] "Pair is just passed through"
ox [pair!] oy [pair!]
][
either pair? align [
align
][
;; center/middle are the default and do not need to be specified, but double arrows are still supported ;@@ should be?
dict: [n ↑ [0x-1] s ↓ [0x1] e → [1x0] w ← [-1x0] #(none) ↔ ↕ [0x0]]
align: ox + oy * add switch align/1 dict switch align/2 dict
either ox/x =? 0 [reverse align][align]
]
]
#assert [
-1x-1 = normalize-alignment -1x-1 0x1 1x0
1x1 = normalize-alignment 1x1 0x1 1x0
0x0 = normalize-alignment 0x0 0x1 1x0
1x1 = normalize-alignment 1x1 1x0 0x1
1x1 = normalize-alignment [n w] -1x0 0x-1
1x1 = normalize-alignment [w n] -1x0 0x-1 ;-- unordered
-1x-1 = normalize-alignment [n w] 0x1 1x0
1x-1 = normalize-alignment [n w] 0x-1 1x0 ;-- swapped vertical X => change in /1
1x1 = normalize-alignment [n w] 0x-1 -1x0 ;-- swapped horizontal Y => change in /2
-1x1 = normalize-alignment [n w] 0x1 -1x0
-1x-1 = normalize-alignment [n e] 0x1 -1x0
-1x-1 = normalize-alignment [↑ →] 0x1 -1x0 ;-- arrows support
0x-1 = normalize-alignment [e] 0x1 -1x0 ;-- no vertical alignment => no vertical X => no /1
1x0 = normalize-alignment [s] 0x1 -1x0 ;-- no horizontal alignment => no horizontal Y => no /2
0x0 = normalize-alignment [] 0x1 -1x0 ;-- no alignment => no axes => no /1 or /2
]
decode-canvas: function [
"Turn pair canvas into positive value and fill flags"
canvas [point2D!] "can be positive or infinite (no fill), negative (fill)"
][
reduce/into [
abs canvas
canvas/x < 0 ;-- only true if strictly negative, not zero
canvas/y < 0
] clear []
]
#assert [
(reduce [infxinf no no]) = decode-canvas infxinf
(reduce [(10, 20) no no]) = decode-canvas ( 10, 20)
(reduce [(10, 20) yes yes]) = decode-canvas (-10, -20)
(reduce [(10, 0) no no]) = decode-canvas ( 10, 0) ;-- zero is fill=false
]
encode-canvas: function [
|canvas| [point2D!] (0x0 +<= |canvas|)
fill-x [logic!]
fill-y [logic!]
][
x-sign: any [all [fill-x |canvas|/x < 1.#inf -1] 1] ;-- finite part may flip sign
y-sign: any [all [fill-y |canvas|/y < 1.#inf -1] 1] ;-- infinite part stays positive
x-sign . y-sign * |canvas|
]