-
Notifications
You must be signed in to change notification settings - Fork 4
/
prima.pd
3609 lines (2908 loc) · 113 KB
/
prima.pd
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
use strict;
use warnings;
our $VERSION = '0.19';
pp_setversion($VERSION);
use Carp qw(croak confess);
#our $PP_VERBOSE = 1;
pp_addpm({At=>'Top'},<<'ModuleMaterial');
use strict;
use warnings;
use PDL;
use PDL::Char;
use Scalar::Util 'blessed';
use Carp 'croak';
use PDL::Drawing::Prima::Utils;
use Prima::noX11;
=head1 NAME
PDL::Drawing::Prima - PDL-aware drawing functions for Prima widgets
=head1 SYNOPSIS
=for podview <img src="PDL/Drawing/Prima/pod/sin.png">
=for html <p><img src="https://raw.githubusercontent.com/dk/PDL-Drawing-Prima/master/pod/sin.png">
Each of the methods comes with a small sample snippet. To see how it
looks, copy this synopsis and replace the code in the
C<Example code goes here> block with the example code.
use strict;
use warnings;
use PDL;
use PDL::Drawing::Prima;
use Prima qw(Application);
my $window = Prima::MainWindow->create(
text => 'PDL::Drawing::Prima Test',
antialias => 1,
onPaint => sub {
my ( $self, $canvas) = @_;
# wipe the canvas:
$canvas->clear;
### Example code goes here ###
# Draw a sine curve on the widget:
my ($width, $height) = $canvas->size;
my $x = sequence($width);
my $y = ( sin($x / 20) + 1 ) * $height/2;
$canvas->pdl_polylines($x, $y, lineWidths => 2);
### Example code ends here ###
},
backColor => cl::White,
);
run Prima;
=head1 DESCRIPTION
This module provides a number of PDL-threaded functions and bindings for use
with the Prima toolkit. Many of the functions are PDL bindings for the
standard Prima drawing functions. Others are useful functions for color
manipulation, or getting data into a form that PDL knows how to handle.
I generally divide the subroutines of this module into two categories:
B<methods> and B<functions>. The methods are subroutines that operate on a
Prima widget; the functions are subroutines that act on or return piddles.
Most of the methods given here are PDLified versions of the Prima drawing API
functions, which are documented under L<Prima::Drawable>. In general, where the
Prima API uses singular nouns, I here use plural nouns. A few of the methods
are only available in this module, mostly added to accomodate the needs of
L<PDL::Graphics::Prima>, the plotting library built on these bindings.
This bindings can be applied to B<any> object whose class is derived from
L<Prima::Drawable>, including displayed widgets and abstract canvases such
as L<Prima::PS::Printer>. If you create your own derived canvas, these
methods should Just Work. (I wish I could take credit for this, but it's
really due to the fact that Prima's internals are very well engineered.)
=head1 COORDINATE ORIGIN
The Prima image coordinate origin is located in lower left corner, which is
where you would expect to find it when creating plots. However, it is different
from the way that many graphics libraries do their coordinates.
=head1 FUNCTIONS
=head2 piddle_of_patterns_for
If you want PDL to thread over line patterns, but you want to use the standard
Prima line patterns, you'll need to convert them line patterns to a piddle.
This works very simply like this:
my $patterns = piddle_of_patterns_for(lp::Solid, lp::Dash);
This creates a piddle with the two patterns so that you could have PDL thread
over them.
You can also create your own line pattern piddles by hand. I recommend you use
byte array, since otherwise it will be converted to byte arrays for you.
The first element of a row in your byte array
specifies the number of pixels to be "on", the second specifies the number to be
"off", the third specifies the number to be "on" again, the fourth "off", the
fifth "on", etc. If that doesn't make sense, hopefully a couple of examples will
help clarify.
This example creates the equivalent of lp::Dash:
my $dash_pattern = byte (9, 3);
This example creates a piddle with four line types: lp::Solid, lp::Dash,
lp::ShortDash, and lp::DashDot:
my $patterns = byte q[ 1; 9 3; 3 3; 9 3 1 3];
and should be identical to
my $patterns = piddle_of_patterns_for(
lp::Solid, lp::Dash, lp::ShortDash, lp::DashDot);
When you create a byte piddle, all of the patterns must have the same number of
bytes in their specification. Of course, different patterns have different
lengths, so in that case simply pad the shorter specifications with zeroes.
=cut
# Builds a piddle of patterns with the appropriate sizes, etc.
sub piddle_of_patterns_for {
# Make sure they're not being stupid:
croak("You must supply at least one pattern to make a pattern piddle")
if @_ == 0;
# First get the longest pattern:
my $length = 0;
foreach(@_) {
$length = length($_) if $length < length($_);
}
use PDL::NiceSlice;
# Create the new byte array with the appropriate dimensions:
my $to_return = zeroes(byte, $length, scalar(@_));
$to_return .= $to_return->sequence;
for (my $i = 0; $i < @_; $i++) {
# Get a slice and update it:
my $slice = $to_return(:,$i);
substr ${$slice->get_dataref}, 0, length($_[$i]), $_[$i];
# Make sure the modifications propogate back to the original:
$slice->upd_data;
}
no PDL::NiceSlice;
return $to_return;
}
ModuleMaterial
#=head2 piddle_of_fillPatterns_for
#
#This function is not yet implemented, but some day it will return piddles
#for any Prima named fill pattern.
#
# It should be able to operate either by calling the fillPattern setter and
# immediately retrieving the resulting fill pattern, or by accessing the
# fill pattern collection directly. Don't know why that didn't work when I
# tried it earlier. Maybe I didn't de-reference the SV double-pointer?
pp_addpm({At=>'Top'},<<'ModuleMaterial');
=head1 METHODS
The methods described below are a bit unusual for PDL functions. First, they are
not actually PDL functions at all but are methods for C<Prima::Drawable>
objects. Second, their signatures will look a bit funny. Don't worry too much
about that, though, because they will resemble normal signatures close enough
that you should be able to understand them, I hope.
=cut
ModuleMaterial
=for details
As far as I can tell, PDL::PP only defines the '_<func>_int' form of a function
when you specify a PMCode in the pp_def. I can't figure out where this happens
in PP.pm, but that appears to be the output behavior.
=cut
pp_add_boot q{
PRIMA_VERSION_BOOTCHECK;
/* Initialize the Drawable virtual method table pointer, which is declared
* below and used to detect if the widget supports direct calls using the
* apricot graphics drawing functions. */
CDrawable = (PDrawable_vmt)gimme_the_vmt( "Prima::Drawable");
};
pp_addhdr(pp_line_numbers(__LINE__ + 1, <<'HEADER'));
/* apricot is the (strangely named) header file that contains all of the
* cross-platform functions. */
#undef WORD
#include <apricot.h>
#include <math.h>
/* Set up the isnan and isinf functions for cross-platform work */
#ifdef _MSC_VER
#include <float.h>
#define isnan(x) _isnan(x)
#define isinf(x) (!_finite(x))
#endif
/* working here - is this cross-platform? */
#define my CDrawable(widget_handle)
#include <generic/Drawable.h>
/* The virtual method table for Drawable objects, which I need for the
* introspection in the POINT methods below. This is set to the actual
* method table pointer in the BOOT section. */
PDrawable_vmt CDrawable;
/* dummy variables for getter/setter functions called in getter mode */
Point Point_buffer;
Rect Rect_buffer;
#define DECLARE_POINT_DATA \
SV * points_to_plot; \
SV * points_tied; \
NPoint * points_storage
#define INIT_POINT_DATA \
points_to_plot = 0; \
points_tied = 0; \
points_storage = 0
#define ENSURE_POINT_STORAGE(n_points) \
if (( points_to_plot = prima_array_new( n_points * sizeof(NPoint))) != NULL) { \
points_storage = (NPoint*) prima_array_get_storage( points_to_plot ); \
points_tied = prima_array_tie( points_to_plot, sizeof(double), "d");\
}
#define FREE_POINT_STORAGE \
if ( points_to_plot ) { \
if ( points_tied ) { \
sv_free( points_tied ); \
} else { \
sv_free( points_to_plot ); \
} \
points_to_plot = 0; \
points_storage = 0; \
points_tied = 0; \
}
#define ADD_POINT(i, a, b) \
if ( points_storage ) { \
points_storage[i].x = a; \
points_storage[i].y = b; \
}
#define DRAW_POINTS(function, n_to_plot) \
if ( points_tied ) { \
/* Trim the array, in case any values were nan and thus skipped */ \
prima_array_truncate( points_to_plot, n_to_plot * sizeof(NPoint)); \
my->function( widget_handle, points_tied ); \
}
/* This is based on Prima's maximum coordinate size, which is 16383. I have
* reduced it in order to accomodate certain coordinate transforms that Prima
* performs: */
#define MY_BIG_NUMBER 16000
/* Apricot uses some pretty dumb methods for correcting values that are too big.
* The way it handles values clashes with the sheer range of values that I want
* to be able to display, so I need to adjust those values somehow. The next
* struct and 250 lines of code examines pairs of values for nan, inf, and
* exceedingly large values. If the data cannot be drawn as-is, it calculates
* values that can be drawn instead or indicates if the calling routine should
* simply skip the values. */
typedef struct {
/* two pairs under consideration */
double x1;
double x2;
double y1;
double y2;
/* Temporary storage */
double tmp_xs[2];
double tmp_ys[2];
int offset;
/* Dimensions of the widget */
int width;
int height;
} big_number_container;
/* I use these functions within the real function, which is the first one that
* is actually defined below. */
int is_inf(double val);
int is_nan(double val);
int _too_many_bad_values(big_number_container * d);
int _is_drawable_as_is(big_number_container * d);
void _check_start_within_bounding_box(big_number_container * d);
void _handle_horizontal_line(big_number_container * d);
void _handle_vertical_line(big_number_container * d);
void _check_crosses_left_edge(big_number_container * d, double y0, double slope);
void _check_crosses_bottom_edge(big_number_container * d, double y0, double slope);
void _check_crosses_right_edge(big_number_container * d, double y0, double slope);
void _check_crosses_top_edge(big_number_container * d, double y0, double slope);
void _check_cross_error (big_number_container * d);
void _set_returns_preserving_order (big_number_container * d);
/* Name : _check_for_big_numbers
* Expects : a pointer to the just-defined struct in which (x1, y1) and (x2, y2)
* : are the pars of points under consideration.
* Returns : 0 when line should not be drawn
* : 1 when points are good as-is
* : 2 when points within the struct have been updated
*/
int _check_for_big_numbers(big_number_container * d) {
/* Sanity check, make sure the width and height are reasonable */
if (d->width > MY_BIG_NUMBER) {
PerlIO_printf(PerlIO_stderr(), "Internal error in _check_for_big_numbers:\n");
PerlIO_printf(PerlIO_stderr(), " Found impossibly large width %d\n"
, d->width);
d->width = MY_BIG_NUMBER;
}
if (d->height > MY_BIG_NUMBER) {
PerlIO_printf(PerlIO_stderr(), "Internal error in _check_for_big_numbers:\n");
PerlIO_printf(PerlIO_stderr(), " Found impossibly large height %d\n"
, d->height);
d->height = MY_BIG_NUMBER;
}
/* This line cannot be drawn if it is strictly above, below, to the left, or
* to the right of the view box */
if (
(d->x1 < 0 && d->x2 < 0) ||
(d->x1 > d->width && d->x2 > d->width) ||
(d->y1 < 0 && d->y2 < 0) ||
(d->y1 > d->height && d->y2 > d->height)
)
return 0;
if (_too_many_bad_values(d)) return 0;
if (_is_drawable_as_is(d)) return 1;
/* If we are here, we must take corrective measures. Find if any part of the
* line actually falls within the box, and figure out where it enters or
* leaves. */
d->offset = 0;
_check_start_within_bounding_box(d);
/* Before we go further, check for horizontal or vertical lines. */
if (d->y1 == d->y2 || is_inf(d->x1) || is_inf(d->x2))
_handle_horizontal_line(d);
else if (d->x1 == d->x2 || is_inf(d->y1) || is_inf(d->y2))
_handle_vertical_line(d);
else {
/* We have a line with a slope. See which boundaries it crosses, if any.
* Note that the order of the checks is very important as some of the
* inequalities are strict and others are not. */
double slope = (d->y2 - d->y1) / (d->x2 - d->x1);
double y0 = d->y1 - slope * (d->x1);
_check_crosses_left_edge(d, y0, slope);
_check_crosses_bottom_edge(d, y0, slope);
_check_crosses_right_edge(d, y0, slope);
_check_crosses_top_edge(d, y0, slope);
_check_cross_error(d);
/* At this point, if the offset is not 2, the line does not intersect
* the view box, so the line will not be drawn and we can return 0 to
* indicate that. */
if (d->offset != 2) return 0;
}
_set_returns_preserving_order(d);
return 2;
}
/* Determines if a number of infinite; assumes it is *not* nan */
int is_inf(double v) {
return (v * 0.0 != 0.0);
}
int is_nan(double v) {
return v != v;
}
/* checks for nan and inf. */
int _too_many_bad_values(big_number_container * d) {
/* One nan is one too many */
if (d->x1 != d->x1 || d->x2 != d->x2 || d->y1 != d->y1 || d->y2 != d->y2)
return 1;
/* This line should be skipped if two or more of its values are inf */
int inf_count = 0;
if (is_inf(d->x1)) inf_count++;
if (is_inf(d->x2)) inf_count++;
if (is_inf(d->y1)) inf_count++;
if (is_inf(d->y2)) inf_count++;
if (inf_count > 1) return 1;
return 0;
}
/* Checks if the values are within Prima's limits. This *MUST* not be called
* before _too_many_bad_values!!! */
int _is_drawable_as_is(big_number_container * d) {
if ( -MY_BIG_NUMBER <= d->x1 && d->x1 <= MY_BIG_NUMBER
&& -MY_BIG_NUMBER <= d->y1 && d->y1 <= MY_BIG_NUMBER
&& -MY_BIG_NUMBER <= d->x2 && d->x2 <= MY_BIG_NUMBER
&& -MY_BIG_NUMBER <= d->y2 && d->y2 <= MY_BIG_NUMBER)
return 1;
return 0;
}
void _check_start_within_bounding_box(big_number_container * d) {
/* Does this line start within the bounding box? */
if (d->x1 >= 0 && d->x1 <= d->width && d->y1 >= 0 && d->y1 <= d->height) {
d->tmp_xs[0] = d->x1;
d->tmp_ys[0] = d->y1;
d->offset++;
}
/* or does it end within the bouding box? */
else if (d->x2 >= 0 && d->x2 <= d->width && d->y2 >= 0 && d->y2 <= d->height) {
d->tmp_xs[0] = d->x2;
d->tmp_ys[0] = d->y2;
d->offset++;
}
}
void _handle_horizontal_line(big_number_container * d) {
/* Did the line start or end in the box? */
if (d->offset == 1) {
/* Yes, so replace the other coordinate with the box's bound. */
d->tmp_ys[1] = is_inf(d->x1) ? d->y2 : d->y1;
if (d->x1 < 0 || d->x2 < 0) d->tmp_xs[1] = 0;
if (d->x1 > d->width || d->x2 > d->width) d->tmp_xs[1] = d->width;
d->offset++;
}
else {
/* No, so set the coordinates to the box's bound at the same y */
d->tmp_xs[0] = 0;
d->tmp_xs[1] = d->width;
d->tmp_ys[0] = d->tmp_ys[1] = is_inf(d->x1) ? d->y2 : d->y1;
d->offset += 2;
}
}
void _handle_vertical_line(big_number_container * d) {
/* Did the line start or end in the box? */
if (d->offset == 1) {
/* Yes, so replace the other coordinate with the box's bound */
d->tmp_xs[1] = is_inf(d->y1) ? d->x2 : d->x1;
if (d->y1 < 0 || d->y2 < 0) d->tmp_ys[1] = 0;
if (d->y1 > d->height || d->y2 > d->height) d->tmp_ys[1] = d->height;
d->offset++;
}
else {
/* No, so set the coordinates to the box's bound at the same x */
d->tmp_xs[0] = d->tmp_xs[1] = is_inf(d->y1) ? d->x2 : d->x1;
d->tmp_ys[0] = 0;
d->tmp_ys[1] = d->height;
d->offset += 2;
}
}
void _check_crosses_left_edge(big_number_container * d, double y0, double slope) {
/* Does this line cross the vertical line x = 0? */
if ((d->x1 < 0 || d->x2 < 0) && y0 >= 0 && y0 <= d->height) {
d->tmp_xs[d->offset] = 0;
d->tmp_ys[d->offset] = y0;
d->offset++;
}
}
void _check_crosses_bottom_edge(big_number_container * d, double y0, double slope) {
/* Can't cross bottom if both positive */
if (d->y1 > 0 && d->y2 > 0) return;
double x0 = -y0 / slope;
/* x == 0 was handled by the left edge check, so this only succeeds if x0 is
* strictly greater than zero. */
if (x0 > 0 && x0 <= d->width) {
d->tmp_xs[d->offset] = x0;
d->tmp_ys[d->offset] = 0;
d->offset++;
}
}
void _check_crosses_right_edge(big_number_container * d, double y0, double slope) {
/* Can't cross right edge if both x values are less than it */
if (d->x1 < d->width && d->x2 < d->width) return;
double y_r = y0 + slope * d->width;
/* Note, y == 0 was handled by the bottom edge check, so this only succeeds
* if yr is strictly greater than zero. */
if (y_r > 0 && y_r <= d->height) {
d->tmp_xs[d->offset] = d->width;
d->tmp_ys[d->offset] = y_r;
d->offset++;
}
}
void _check_crosses_top_edge(big_number_container * d, double y0, double slope) {
/* Can't cross the top edge if both y values are less than it */
if (d->y1 > d->height && d->y2 > d->height) return;
double x_t = (d->height - y0) / slope;
/* Note, x == 0 and x == width were handled above, so this checks for
* strict inequality */
if (x_t > 0 && x_t < d->width) {
d->tmp_xs[d->offset] = x_t;
d->tmp_ys[d->offset] = d->height;
d->offset++;
}
}
void _check_cross_error (big_number_container * d) {
/* Spew a message if there is one or three intersection points, as that
* should never occurr and indicates an internal error. */
if (d->offset == 1 || d->offset > 2) {
PerlIO_printf(PerlIO_stderr(), "Internal error in _check_for_big_numbers:\n");
PerlIO_printf(PerlIO_stderr(), " offset should be 0 or 2, but it is %d\n"
, d->offset);
PerlIO_printf(PerlIO_stderr(), " x1=%f, y1=%f, x2=%f, y2=%f, width=%d, height=%d\n"
, d->x1, d->y1, d->x2, d->y2, d->width, d->height);
}
}
void _set_returns_preserving_order (big_number_container * d) {
/* This only gets called when it's time to change x1, x2, y1, and y2.
* Set them to the values in the temporary array, but take care to
* preserve the original ordering. */
if (
(
(d->x1 != d->x2) &&
((d->x1 < d->x2) == (d->tmp_xs[0] < d->tmp_xs[1]))
) || (
(d->y1 != d->y2) &&
((d->y1 < d->y2) == (d->tmp_ys[0] < d->tmp_ys[1]))
)
) {
d->x1 = d->tmp_xs[0];
d->x2 = d->tmp_xs[1];
d->y1 = d->tmp_ys[0];
d->y2 = d->tmp_ys[1];
} else {
d->x1 = d->tmp_xs[1];
d->x2 = d->tmp_xs[0];
d->y1 = d->tmp_ys[1];
d->y2 = d->tmp_ys[0];
}
}
HEADER
#######################################################################
# Machinery #
#######################################################################
=begin details
=head1 Complex parameter handling
Each of the functions in this module wrap a PDL function around the
Prima API. The goal of the PDL functions is to allow the caller to
provide as many or as few tweaks to their drawing as they wish, so if
they want to draw three different polylines with three different line
styles (as demonstrated in test.pl), they should be able to do this:
$widget->pdl_polylines($xs, $ys,
linePatterns => $patterns,
color => cl::Red
);
and it will DWIM. That means that the PP functions have to (1) get all
the possible preferences---both singular and plural varieties---in as
piddle parameters, (2) the PP functions have to call the appropriate
functions from the widget handles virtual method table to do their work, and
(3) the PP functions have to package their piddles in a form that the method
from the method table knows how to handle. To make matters even more
complicated, different API functions pay attention to different properties,
so not every property is allowed for every function!
To deal with all of this, the next 400 or so lines of code create some
machinery that greatly assists in building the pp_defs that follow. A
great deal of this code is used in THIS script (.pd files are actually
scripts that generate .xs and .pm files) to assist in generating code.
Anything that needs to end up in the *output* files will be quoted, so
hopefully your syntax highlighter will help you pick them apart.
=end details
=cut
###################################################
# Creating the look-up table for the Pars section #
###################################################
=begin details
This hash translates from a simple parameter name to a PDL signature.
Without this hash, if I wanted to write a function that allows the user
to draw lines with different colors, I would write the following Pars:
Pars => 'int x(n); int y(n); int colors()'
So in the hash below, the property C<colors> is associated with the
arg string C<int colors()>.
=end details
=cut
my %pars_args_for = (colors => 'int colors()');
=begin details
At the moment, I only have the colors property. If you know the Prima
Drawable API, you'll know I'm missing a lot! This is because I will
build up a number of structures over this discourse and I would
like to keep the code and specifications for each property in one place.
Scroll down to the 'Building the machinery' portion of this code, about
400 lines below, and you'll see all the parts for each of the Drawable
properties defined in one place.
=end details
=cut
#########################
# Generating Pars lists #
#########################
=begin details
This function creates a string with the low-level PDL function's argument
list, given a list of properties for the function. This makes it very
easy to manage long parameter lists, and long parameter lists are nicely
handled by the in-pm function C<get_sorted_args_with_defaults>. To expand
on the previous example, in this code:
pp_def('my_func',
Pars => 'int x(n); int y(n); ' . generate_pars_args_for( 'colors', 'rops'),
...
);
pp_def sees a parameter list that looks like this:
'int x(n); int y(n); int colors(); int rops()'
To use this, I will create a list of properties that the to-be-defined
function takes, and use that together with generate_pars_args_for like
so:
my @clear_properties = qw(backColors rop2s);
pp_def('prima_clear',
Pars => 'int x1(); int y1(); int x2(); int y2(); '
. generate_pars_args_for(@clear_properites),
PMCode => ...
);
It may seem silly to use such an array for only two additional arguments
(as shown in this example), but other parts of the pp_def call will make
use of that array, as we will see, and most of the functions use many
more properties.
=end details
=cut
sub generate_pars_args_for {
foreach (@_) {
croak("Bad args; should be plural") unless /s$/;
}
return join('; ', @pars_args_for{@_});
}
######################################
# Property-dependent local variables #
######################################
=begin details
In order to determine if properties need to be changed in the middle of the
threadloop and at the end of the threadloop, we need to keep track of the
original and the current values of the different properties. By default I
assume that a copy of the property name with the same type as from the pars
args works. If this is not the case (such as for clipRects), I need to
provide values for C<%declare_args_for>. I also provide the simple
C<%cast_for> table in case the autogenerated code needs a cast to work
properly.
Functions that do not care about these properties will not need these
variables, so they should only be included in functions that actually
use them. C<generate_property_declarations_for> handles this code
generation, taking the same array of properties used by
C<generate_pars_args_for>. See the next section for an example of use.
Note that entries in C<%declare_args_for> should be semi-colon seperated,
since they are C declarations, but the last entry should not have a
semi-colon. One will be appended. This is to keep consistency with
C<%pars_args_for>, which has the same format.
For the colors, almost all the auto-generated code goes through cleanly,
except that I wish to cast the integer values to type Color. To handle this,
I have the following list as well.
=end details
=cut
# Colors has no special args declaration, but it does have special casting
my %declare_args_for = ();
my %cast_for = (colors => '(Color)');
# this will be automatically generated from the pars data.
my %uncast_for = ();
sub generate_property_declarations_for {
my $to_return = pp_line_numbers(__LINE__, "\t\t/* Declare the property variables */\n");
# Build the list:
for my $property (@_) {
if (exists $declare_args_for{$property}) {
$to_return .= "\t\t$declare_args_for{$property};\n";
}
else {
# Make sure that the pars args for this property don't have
# multiple args:
croak("pars_args has multiple values but not init_args for property $property")
if $pars_args_for{$property} =~ /;/;
# extract the type
$pars_args_for{$property} =~ /(\w+)\s+\w+s\(\)/
or croak("Unable to extract type for property $property");
# All good; cook up the declarations
my $type = $1;
(my $singular = $property) =~ s/s$//;
$to_return .= "\t\t$type orig_$singular, curr_$singular;\n";
$uncast_for{$property} = "($type)" if exists $cast_for{$property};
}
}
return $to_return;
}
##########################################
# Tracking which properties need setting #
##########################################
=begin details
The only way to determine from within PP code whether an optional parameter
was passed in or not is to pass an additional structure to the PP code with
that information. The structure I use for this is the original hash passed
in as an argument to the Perl-level function. If the user specified a value
for a property, it will be present in the hash. If they did not, it will not
be there.
For each of the graphics properties that the user can supply for a given
function, I need code in the PP Code section that looks something like this:
/* Set these to zero, in case neither singular nor plural are defined */
curr_rop = orig_rop = 0;
if (hv_exists(arg_hash_hv, "rops", 4)) {
prop_list[n_props++] = rops_prop_id;
curr_rop = orig_rop = my->get_rop(widget_handle);
}
if (hv_exists(arg_hash_hv, "rop", 3)) {
orig_rop = my->get_rop(widget_handle);
curr_rop = SvIV(*(hv_fetch(arg_hash_hv, "rop", 3, 0)));
my->set_rop(widget_handle, curr_rop);
}
This code has three important parts. First, it sets both the current and the
original rop values to zero. If the user didn't pass in any either key,
these values will pass through the whole loop unchanged. At the end, all of
the properties are checked to see if their current and original values
differ and if so their original values are restored. As both the current
and original values are zero in the case of no associated keys, restoration
will not be necessary, and will not wastefully be performed.
The second important part is the plural key check. If the plural key exists,
its property id is added to the property list. The property list is consulted
on each pass through the threadloop and this value indicates that the rop
value needs to be checked. It also retrieves and stores the original rop
value. Notice that it stores the original rop value in the current rop value.
If somehow this is called on empty piddles, the threadloop will never execute
and then curr_rop will have the same value it had before entering the loop.
Setting the current to the original value helps prevent mayhem.
The third important part is the singular key check. If the singular key
exists, the original value is retrieved (as with the plural key). The value
associated with the singular key is also retrieved and set.
Some of the more complicated properties will need more complex initialization
code, in which case they will have to provide a value for the
C<%init_args_for> hash. It should follow the basic form provided above.
=end details
=cut
my %init_args_for = ();
sub generate_property_initializations_for {
# Make sure I handle an empty list correctly. I can't imagine
# calling this function with an empty list, but let's be safe:
return '' unless @_;
# This is the string I will build up for my return value:
my $to_return = "\t\t/* Property initialization code */\n";
# Set the variables:
for my $property (@_) {
if (exists $init_args_for{$property}) {
$to_return .= $init_args_for{$property};
}
else {
(my $singular = $property) =~ s/s$//;
my $sing_length = length($singular);
my $plural_length = length($property);
my ($cast, $uncast) = ('', '');
if (exists $cast_for{$property}) {
$cast = $cast_for{$property};
$uncast = $uncast_for{$property};
}
$to_return .= pp_line_numbers(__LINE__, "
curr_$singular = orig_$singular = 0;
if (hv_exists(arg_hash_hv, \"$property\", $plural_length)) {
prop_list[n_props++] = ${property}_prop_id;
curr_$singular = orig_$singular = $uncast my->get_$singular(widget_handle);
}
if (hv_exists(arg_hash_hv, \"$singular\", $sing_length)) {
orig_$singular = $uncast my->get_$singular(widget_handle);
curr_$singular = SvIV(*(hv_fetch(arg_hash_hv, \"$singular\", $sing_length, 0)));
my->set_$singular(widget_handle, $cast curr_$singular);
}\n");
}
}
return $to_return;
}
####################################
# Creating the initialization code #
####################################
=begin details
I've built up a lot of machinery to handle the various required arguments
and optional properties. This next chunk of code gives a single function
that will call everything in the proper order to declare and initialize
the necessary variables, early within the Code section.
=end details
=cut
sub initialize_for {
my @properties = @_;
return pp_line_numbers(__LINE__, '
/* BEGIN AUTOGENERATED INITIALIZATION */
HV* arg_hash_hv = (HV*)SvRV($COMP(arg_ref_sv));
/* get the widget handle */
SV ** widget_sv_p = hv_fetch(arg_hash_hv, "widget", 6, 0);
if (widget_sv_p == NULL) {
croak("INTERNAL ERROR: widget key was not set!");
}
Handle widget_handle = gimme_the_mate(*(widget_sv_p));
/* array of plural properties to check each iteration. The number
* of properties for any given function cannot exceed the number
* of properties available to all functions, so just allocate
* an array large enough to hold everything, even if most functions
* will never use this much. It canno be more than 20, I imagine. */
property_id_t prop_list [NUMBER_OF_PROPERTIES_PLUS_ONE];
/* Create a counting variable, and track the number of active
* properties that will change during the threadloop for *this*
* invocation of the function. */
int prop_counter, n_props = 0;
') . generate_property_declarations_for(@properties)
. generate_property_initializations_for(@properties) . '
/* END AUTOGENERATED INITIALIZATION */
';
}
my $default_other_pars = 'SV * arg_ref_sv';
#######################
# Calling the setters #
#######################
=begin details
Once in the threadloop, each of the properties needs to be able to check if
a new value differs from the current value, and effect a change if so. This
is easy but repetitive code, so once again I generate it from the same list
of arguments as everything else. In what follows, I create a function that
generates these code fragments for me, or looks them up in a hash if they're
complicated. Note that the function wraps the looked-up code in its own
curly-braced block; all you need to write is the code itself like the
following colors example shows:
The auto-generated code for this section is inserted directly into the
Code key in the pp_def function call, within the threadloop, before the
actual drawing function is called. For example:
q[
...
threadloop %{
/* Apply any per-threadloop tweaks */
] . generate_switch_loop_for(@func_pars)
. q[
/* Call the apricot function */
my->draw_func(args);
%}
]
=end details
=cut
# Thanks to casting, colors doesn't have any special setting code
my %set_code_for = ();
sub generate_switch_case_for {
my $property = shift;
# Make the singular name from the plural:
(my $singular = $property) =~ s/s$//;
# Build the return string:
my $to_return = "\t\t\t\t\tcase (${property}_prop_id):\n";
if (exists $set_code_for{$property}) {
# Insert special handling code:
$to_return .= $set_code_for{$property};
}
else {
# Most other properties are direct sets:
my $cast = $cast_for{$property} || '';
$to_return .=
" if (curr_$singular != \$$property()) {
curr_$singular = \$$property();
my->set_$singular(widget_handle, $cast curr_$singular);
}\n";
}
$to_return .= "\t\t\t\t\t\tbreak;";
}
# working here - consider creating a hash like %bad_check_code_for
# to handle per-property bad checking code
sub generating_bad_single_setter_code_for {
}
sub generate_switch_loop_for {
return "
/* BEGIN PROPERTY SWITCH LOOP */
prop_counter = 0;
while(prop_counter < n_props) {
switch(prop_list[prop_counter++]) {\n"
. join("\n", (map {generate_switch_case_for($_)} @_)) . "
default: break;
}
}
/* END PROPERTY SWITCH LOOP */\n";
}
#############################
# Per-Property Cleanup Code #
#############################
=begin details
At least one of the properties allocates memory that must be freed when
we're done. All the properties need to check if their values have changed
from their originals, and if so they need to be restored.
=end details
=cut
# standard cleanup code works for colors