diff options
Diffstat (limited to 'source/luametatex/source/mp/mpw/mp.w')
| -rw-r--r-- | source/luametatex/source/mp/mpw/mp.w | 31138 |
1 files changed, 31138 insertions, 0 deletions
diff --git a/source/luametatex/source/mp/mpw/mp.w b/source/luametatex/source/mp/mpw/mp.w new file mode 100644 index 000000000..017cc0fd7 --- /dev/null +++ b/source/luametatex/source/mp/mpw/mp.w @@ -0,0 +1,31138 @@ +% This file is part of MetaPost. The MetaPost program is in the public domain. + +@* Nota bene. + +This is not the official reference library but a version meant for \LUAMETATEX\ +in combination with \METAFUN, which is integrated in \CONTEXT. When the original +gets improved I will diff the progression of the original \CWEB\ files and merge +improvements. + +I'm pretty sure that the \TEX part of this file doesn't process but I'll look into +that later. The comments are kept as they were but there are occasional remakts +because we changes some bits and pieces. The references to properties, variables, +constants etc, are mostly kept. I due time I'll fix it and see if I can render +the file, but for not it's okay to just read the comments. I admit that I check +things in Visual Studio anyway, which is why there are now |enum| used. + +This split is needed because the original library is the one used for \METAPOST\ +the program which is used by DEK, and I don't want to mess up his workflow. At +some point I might emulate \METAPOST\ but I might as well decide to remove the +interaction completely from this variant. It al depends on the outcome of +experiments that Alan and I conduct, and as it's done in free time, it will take +while. Don't push us, don't nag, don't complain. The original library is where +the support is concentrated and you can always use that with the \MKIV\ macros. + +Todo: check typecasts, the halfword and quarterwords are now integers. +Todo: Move more variables into the scope that they're used. +Todo: Remove some (int) cast that are left overs from quarterword. +Todo: Remove unused variables ... postpone more padding till that is done. +Todo: Support color in group objects + +Because we don't want macros to clash with fields in record, setters and getters +are prefixed by |mp_|. In order not clash with typedefs and accessors, in some +cases |mp_get_| and |mp_set_| are used (eventually that might be true for all +these cases). The |mp_free_| functions are complemented by |mp_new_| functions. +In \MPLIB\ 2 |mp_get_| is used instead so keep that in mind when comparing the +sources. I might also pass |mp| to all macros, just for consistency. + +To be considered: use the same record for rgb and cmyk (less code eventually). + +In order to make extensions a bit easier (and also because of consistency in +enumerations, some _token and _sym and similar specifiers have been made _command +(it was already somewhat inconsistent anyway). When something gets compared to +cur_cmd it makes sense to use _command anyway. + +% some (int) can go + +(Hans Hagen, 2019+) + +@* Comment. + +At some point Taco Hoekwater brilliantly converted \MP\ into a library. Since +then usage and integration of \METAPOST\ in \CONTEXT\ went even further than +before. There were some backends added for \SVG\ and \PNG, and several number +systems could be used. This was quite an effort! The \MP\ program became a +wrapper around this library. + +The library is also used in \LUATEX\ but there we don't need the backend code at +all. Also, having the traditional \TFM\ generating code (inherited from \MF) +makes not much sense because we now live in an \OPENTYPE\ universum and the hard +coded 256 limitations were even for \TYPEONE\ not okay. The GUST font team use +their own tools around \MP\ anyway. + +This variant (below) is therefore a stripped down library. Everything related to +loading fonts is gone, and if a \PS\ backend is needed the functionality has to +go into its own module (as with \SVG\ and \PNG). This means that code removed +here has to go there. One problen then is that the output primitives have to be +brought in too, but in good \CWEB\ practices, that then can be done via change +files (basically extending the data structures and such). + +However, a more modern variant could be to just use the library with \LUA, +produce \PDF\ and convert that to any format needed. This is what we do in +\CONTEXT. After a decade of usage I like to change a few interface aspects so +here this happens. + +So: this variant is {\em not} the official \MP\ library but one meant for usage +in \LUAMETATEX\ and experiments by Alan Braslau and Hans Hagen for more advanced +graphics, produced by cooperation between \LUA\ and \MP. This strategy permits +experiments without interference with the full blown version. Of course we can +retrofit interesting extensions into its larger version at some point. It's all a +work of love, done in our own time, so don't push our agenda in this. + +Stripping is easier than adding and the things I added were not at the level of +the language or processing but the interface to \LUA\ as well as some details of +text processing. Some more of that might happen. For instance, all file \IO\ now +goes via \LUA\ so we assume the callbacks being set. + +On my agenda are to delegate printing of messages and errors to the plugin. Also +filenames might be done differently. Messages are already normalized. + +As a start the psout.w file was stripped and turned into a mpcommon.w file. This +means that the old \PS\ output code is no longer there. Because that file got +small it eventually got merged in here which (1) permits some reshuffling and (2) +gives room for optimizing the interface to \LUA\ (do we need the indirectness?). + +Quite some code has been stripped because we assume that \LUA\ can provide these +features: file io, logging, management, error handling, etc. This saves quite a +bit of code and also detangles a bit the mixed program vs. library code. For now +the \quote {terminal} approach is kept. + +In the process I reformatted the source a bit. Sorry. It is no big deal because +it looks like \METAPOST\ is not evolving, but what does evolve is the code here: +scanners and more access, to mention a few. I've added braces so that comments +can go with single statements and there can be no doubt when \WEB\ macros are +used (some braces could go there. More variables will become local (to branches +for instance). Messages are done more directly, etc. etc. One of the reasons for +doing that is that it looks nicer in Visual Studio. There it helps to move some +variables to a more local scope. Of course a side effect is that backporting is +now no longer an option. In some cases redundant braces were removed (when it's +clear in the w file) and some else statements have been added where confusion +takes place because that one doesn't return (so compilers can for instance warn +about uninitialized pointers). I made sure that the resulting code is readable +in visual studio. + +Work in progress: prefix with mp_ so that macros don't clash with fields and we +can get rid of _ hackery. + +Maybe some day: zpair zpath zdraw ztransform: just add an extra z dimension +to the existing data types which makes it compatible too. + +Todo: consider double only +Todo: use documented c +Todo: rework some (more) helpers + +Todo: center +Todo: centerofmass +Todo: ceiling x +Todo: x div y +Todo: x mod y +Todo: dir x +Todo: unitvector + +(Hans Hagen, 2019+) + +@* Introduction. + +This is \MP\ by John Hobby, a graphics-language processor based on D. E. Knuth's +\MF. + +Much of the original Pascal version of this program was copied with permission +from MF.web Version 1.9. It interprets a language very similar to D.E. Knuth's +METAFONT, but with changes designed to make it more suitable for PostScript +output. + +The main purpose of the following program is to explain the algorithms of \MP\ as +clearly as possible. However, the program has been written so that it can be +tuned to run efficiently in a wide variety of operating environments by making +comparatively few changes. Such flexibility is possible because the documentation +that follows is written in the |WEB| language, which is at a higher level than +C. + +A large piece of software like \MP\ has inherent complexity that cannot be +reduced below a certain level of difficulty, although each individual part is +fairly simple by itself. The |WEB| language is intended to make the algorithms +as readable as possible, by reflecting the way the individual program pieces fit +together and by providing the cross-references that connect different parts. +Detailed comments about what is going on, and about why things were done in +certain ways, have been liberally sprinkled throughout the program. These +comments explain features of the implementation, but they rarely attempt to +explain the \MP\ language itself, since the reader is supposed to be familiar +with {\em The \METAFONT\ book} as well as the manual @.WEB@> @:METAFONTbook}{\sl +The {\logos METAFONT}book@> {\em A User's Manual for \METAPOST}, Computing +Science Technical Report 162, AT\AM T Bell Laboratories. + +@ The present implementation is a preliminary version, but the possibilities for +new features are limited by the desire to remain as nearly compatible with \MF\ +as possible. + +On the other hand, the |WEB| description can be extended without changing the +core of the program, and it has been designed so that such extensions are not +extremely difficult to make. The |banner| string defined here should be changed +whenever \MP\ undergoes any modifications, so that it will be clear which version +of \MP\ might be the guilty party when a problem arises. @^extensions to \MP@> +@^system dependencies@> + +At some point I started adding features to the library (think of stacking) but +the more interesting additions came when Mikael Sundqvist and we side tracked from +extending math at the \TEX\ end to more \METAFUN: intersection lists, arctime +lists, path iteration, a few more helpers, some fixes, a bit more control, access +to previously hidden functionality, appended paths, etc. And there is undoubtly +more to come. As with all \LUATEX\ and \LUAMETATEX\ development, most gets +explained in the history documents in the \CONTEXT\ distribution and articles. It +was around version 3.14 (end May 2022). + +@d default_banner "This is MPLIB for LuaMetaTeX, version 3.14" + +@<Metapost version header@>= +# define metapost_version "3.14" + +@ We used to have three header files: common, mpmp and mplib, but there ws some +(growing) dependency on the one hand and we decided to target just \LUAMETATEX\ +on the other. After all, this is a special version. So, we now have one header +file only. The variables from |MP_options| are included inside the |MP_instance| +wholesale. This also permits some further stripping. Actually we can probably +get rid of the intermediate \POSTSCRIPT\ representation or add a little more +abstraction. + +@(mp.h@>= +# ifndef MP_H +# define MP_H 1 + +# include "avl.h" +# include "auxmemory.h" +# include <string.h> +# include <setjmp.h> + +@<Metapost version header@> +typedef struct MP_instance *MP; +@<Exported types@> +typedef struct MP_options { + @<Option variables@> +} MP_options; +@<Exported function headers@> +@<MPlib header stuff@> +@<Declare helpers@> +@<Enumeration types@> +@<Types in the outer block@> +@<Constants in the outer block@> +typedef struct MP_instance { + @<Option variables@> + @<Global variables@> +} MP_instance; +@<Internal library declarations@> +@<MPlib internal header stuff@> +@<MPlib export header stuff@> +# endif + +@ @c +# include "mpconfig.h" +# include "mp.h" +# include "mpmath.h" +# include "mpmathdouble.h" +# include "mpmathbinary.h" +# include "mpmathdecimal.h" +# include "mpstrings.h" + +@h @<Declarations@> +@<Error handling procedures@> + +@ Here are the functions that set up the \MP\ instance. + +@<Declarations@>= +MP_options *mp_options (void); +MP mp_initialize (MP_options * opt); + +@ @c +MP_options *mp_options (void) +{ + MP_options *opt = mp_memory_clear_allocate(sizeof(MP_options)); + return opt; +} + +@ The whole instance structure is initialized with zeroes, this greatly reduces +the number of statements needed in the |Allocate or initialize variables| block. + +@c +static MP mp_do_new (jmp_buf *buf) +{ + MP mp = mp_memory_clear_allocate(sizeof(MP_instance)); + if (mp == NULL) { + mp_memory_free(buf); + return NULL; + } else { + mp->jump_buf = buf; + return mp; + } +} + +static void mp_free (MP mp) +{ + @<Dealloc variables@> + @<Finish non-interactive use@> + mp_memory_free(mp->jump_buf); + @<Free table entries@> + free_math(); + mp_memory_free(mp); +} + +static void mp_do_initialize (MP mp) +{ + @<Set initial values of key variables@> +} + +@ For the retargetable math library, we need to have a pointer, at least. + +@<Global variables@>= +math_data *math; + +@ @<Exported types@>= +typedef enum mp_number_type { + mp_nan_type, + mp_scaled_type, + mp_fraction_type, + mp_angle_type, + mp_double_type, + mp_binary_type, + mp_decimal_type +} mp_number_type; + +typedef union mp_number_store { + void *num; + double dval; + int val; +} mp_number_store; + +typedef struct mp_number_data { + mp_number_store data; + mp_number_type type; +} mp_number_data; + +typedef struct mp_number_data mp_number; + +# define is_number(A) ((A).type != mp_nan_type) + +@ Switching to also passing pointers for the origins made the \LUAMETATEX\ binary +go down from 3061799 bytes to 2960091 bytes (mid May 2022). + +We have a few more helpers for cloning: |negated| and |abs| because these happen +often and it saves some lines of code in already long functions. + +@<Types in the outer block@>= +typedef void (*convert_func) (mp_number *r); +typedef void (*m_log_func) (MP mp, mp_number *r, mp_number *a); +typedef void (*m_exp_func) (MP mp, mp_number *r, mp_number *a); +typedef void (*m_unif_rand_func) (MP mp, mp_number *ret, mp_number *x_orig); +typedef void (*m_norm_rand_func) (MP mp, mp_number *ret); +typedef void (*pyth_add_func) (MP mp, mp_number *r, mp_number *a, mp_number *b); +typedef void (*pyth_sub_func) (MP mp, mp_number *r, mp_number *a, mp_number *b); +typedef void (*power_of_func) (MP mp, mp_number *r, mp_number *a, mp_number *b); +typedef void (*n_arg_func) (MP mp, mp_number *r, mp_number *a, mp_number *b); +typedef void (*velocity_func) (MP mp, mp_number *r, mp_number *a, mp_number *b, mp_number *c, mp_number *d, mp_number *e); +typedef int (*ab_vs_cd_func) (mp_number *a, mp_number *b, mp_number *c, mp_number *d); +typedef void (*crossing_point_func) (MP mp, mp_number *r, mp_number *a, mp_number *b, mp_number *c); +typedef void (*number_from_int_func) (mp_number *A, int B); +typedef void (*number_from_boolean_func) (mp_number *A, int B); +typedef void (*number_from_scaled_func) (mp_number *A, int B); +typedef void (*number_from_double_func) (mp_number *A, double B); +typedef void (*number_from_addition_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_half_from_addition_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_from_subtraction_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_half_from_subtraction_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_from_div_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_from_mul_func) (mp_number *A, mp_number *B, mp_number *C); +typedef void (*number_from_int_div_func) (mp_number *A, mp_number *B, int C); +typedef void (*number_from_int_mul_func) (mp_number *A, mp_number *B, int C); +typedef void (*number_from_oftheway_func) (MP mp, mp_number *A, mp_number *t, mp_number *B, mp_number *C); +typedef void (*number_negate_func) (mp_number *A); +typedef void (*number_add_func) (mp_number *A, mp_number *B); +typedef void (*number_subtract_func) (mp_number *A, mp_number *B); +typedef void (*number_modulo_func) (mp_number *A, mp_number *B); +typedef void (*number_half_func) (mp_number *A); +typedef void (*number_double_func) (mp_number *A); +typedef void (*number_abs_func) (mp_number *A); +typedef void (*number_clone_func) (mp_number *A, mp_number *B); +typedef void (*number_negated_clone_func) (mp_number *A, mp_number *B); +typedef void (*number_abs_clone_func) (mp_number *A, mp_number *B); +typedef void (*number_swap_func) (mp_number *A, mp_number *B); +typedef void (*number_add_scaled_func) (mp_number *A, int b); +typedef void (*number_multiply_int_func) (mp_number *A, int b); +typedef void (*number_divide_int_func) (mp_number *A, int b); +typedef int (*number_to_int_func) (mp_number *A); +typedef int (*number_to_boolean_func) (mp_number *A); +typedef int (*number_to_scaled_func) (mp_number *A); +typedef int (*number_round_func) (mp_number *A); +typedef void (*number_floor_func) (mp_number *A); +typedef double (*number_to_double_func) (mp_number *A); +typedef int (*number_odd_func) (mp_number *A); +typedef int (*number_equal_func) (mp_number *A, mp_number *B); +typedef int (*number_less_func) (mp_number *A, mp_number *B); +typedef int (*number_greater_func) (mp_number *A, mp_number *B); +typedef int (*number_nonequalabs_func) (mp_number *A, mp_number *B); +typedef void (*make_scaled_func) (MP mp, mp_number *ret, mp_number *A, mp_number *B); +typedef void (*make_fraction_func) (MP mp, mp_number *ret, mp_number *A, mp_number *B); +typedef void (*take_fraction_func) (MP mp, mp_number *ret, mp_number *A, mp_number *B); +typedef void (*take_scaled_func) (MP mp, mp_number *ret, mp_number *A, mp_number *B); +typedef void (*sin_cos_func) (MP mp, mp_number *A, mp_number *S, mp_number *C); +typedef void (*slow_add_func) (MP mp, mp_number *A, mp_number *S, mp_number *C); +typedef void (*sqrt_func) (MP mp, mp_number *ret, mp_number *A); +typedef void (*init_randoms_func) (MP mp, int seed); +typedef void (*allocate_number_func) (MP mp, mp_number *A, mp_number_type t); +typedef void (*allocate_number_clone_func) (MP mp, mp_number *A, mp_number_type t, mp_number *B); +typedef void (*allocate_number_abs_func) (MP mp, mp_number *A, mp_number_type t, mp_number *B); +typedef void (*allocate_number_double_func) (MP mp, mp_number *A, double B); +typedef void (*free_number_func) (MP mp, mp_number *n); +typedef void (*fraction_to_round_scaled_func) (mp_number *n); +typedef void (*print_func) (MP mp, mp_number *A); +typedef char *(*tostring_func) (MP mp, mp_number *A); +typedef void (*scan_func) (MP mp, int A); +typedef void (*mp_free_func) (MP mp); +typedef void (*set_precision_func) (MP mp); + +/* + We use a prefix |md_| so that we don't get complaints about recursive macro + definitions. This is cleaner than redefining the macros. +*/ + +typedef struct math_data { + mp_number md_precision_default; + mp_number md_precision_max; + mp_number md_precision_min; + mp_number md_epsilon_t; + mp_number md_inf_t; + mp_number md_negative_inf_t; + mp_number md_one_third_inf_t; + mp_number md_zero_t; + mp_number md_unity_t; + mp_number md_two_t; + mp_number md_three_t; + mp_number md_half_unit_t; + mp_number md_three_quarter_unit_t; + mp_number md_fraction_one_t; + mp_number md_fraction_half_t; + mp_number md_fraction_three_t; + mp_number md_fraction_four_t; + mp_number md_one_eighty_deg_t; + mp_number md_negative_one_eighty_deg_t; + mp_number md_three_sixty_deg_t; + mp_number md_one_k; + mp_number md_sqrt_8_e_k; + mp_number md_twelve_ln_2_k; + mp_number md_coef_bound_k; + mp_number md_coef_bound_minus_1; + mp_number md_twelvebits_3; + mp_number md_arc_tol_k; + mp_number md_twentysixbits_sqrt2_t; + mp_number md_twentyeightbits_d_t; + mp_number md_twentysevenbits_sqrt2_d_t; + mp_number md_fraction_threshold_t; + mp_number md_half_fraction_threshold_t; + mp_number md_scaled_threshold_t; + mp_number md_half_scaled_threshold_t; + mp_number md_near_zero_angle_t; + mp_number md_p_over_v_threshold_t; + mp_number md_equation_threshold_t; + mp_number md_warning_limit_t; + allocate_number_func md_allocate; + allocate_number_clone_func md_allocate_clone; + allocate_number_abs_func md_allocate_abs; + allocate_number_double_func md_allocate_double; + free_number_func md_free; + number_from_int_func md_from_int; + number_from_boolean_func md_from_boolean; + number_from_scaled_func md_from_scaled; + number_from_double_func md_from_double; + number_from_addition_func md_from_addition; + number_half_from_addition_func md_half_from_addition; + number_from_subtraction_func md_from_subtraction; + number_half_from_subtraction_func md_half_from_subtraction; + number_from_div_func md_from_div; + number_from_mul_func md_from_mul; + number_from_int_div_func md_from_int_div; + number_from_int_mul_func md_from_int_mul; + number_from_oftheway_func md_from_oftheway; + number_negate_func md_negate; + number_add_func md_add; + number_subtract_func md_subtract; + number_half_func md_half; + number_modulo_func md_modulo; + number_double_func md_do_double; + number_abs_func md_abs; + number_clone_func md_clone; + number_negated_clone_func md_negated_clone; + number_abs_clone_func md_abs_clone; + number_swap_func md_swap; + number_add_scaled_func md_add_scaled; + number_multiply_int_func md_multiply_int; + number_divide_int_func md_divide_int; + number_to_int_func md_to_int; + number_to_boolean_func md_to_boolean; + number_to_scaled_func md_to_scaled; + number_to_double_func md_to_double; + number_odd_func md_odd; + number_equal_func md_equal; + number_less_func md_less; + number_greater_func md_greater; + number_nonequalabs_func md_nonequalabs; + number_round_func md_round_unscaled; + number_floor_func md_floor_scaled; + make_scaled_func md_make_scaled; + make_fraction_func md_make_fraction; + take_fraction_func md_take_fraction; + take_scaled_func md_take_scaled; + velocity_func md_velocity; + ab_vs_cd_func md_ab_vs_cd; + crossing_point_func md_crossing_point; + n_arg_func md_n_arg; + m_log_func md_m_log; + m_exp_func md_m_exp; + m_unif_rand_func md_m_unif_rand; + m_norm_rand_func md_m_norm_rand; + pyth_add_func md_pyth_add; + pyth_sub_func md_pyth_sub; + power_of_func md_power_of; + fraction_to_round_scaled_func md_fraction_to_round_scaled; + convert_func md_fraction_to_scaled; + convert_func md_scaled_to_fraction; + convert_func md_scaled_to_angle; + convert_func md_angle_to_scaled; + init_randoms_func md_init_randoms; + sin_cos_func md_sin_cos; + sqrt_func md_sqrt; + slow_add_func md_slow_add; + print_func md_print; + tostring_func md_tostring; + scan_func md_scan_numeric; + scan_func md_scan_fractional; + mp_free_func md_free_math; + set_precision_func md_set_precision; +} math_data; + +@ This procedure gets things started properly. + +@c +MP mp_initialize (MP_options * opt) +{ + MP mp; + jmp_buf *buf = mp_memory_allocate(sizeof(jmp_buf)); + if (buf == NULL || setjmp(*buf) != 0) { + return NULL; + } + mp = mp_do_new(buf); + if (mp == NULL) { + return NULL; + } + if (opt->job_name == NULL || ! *(opt->job_name)) { + return NULL; + } + mp->job_name = mp_strdup(opt->job_name); + mp->userdata = opt->userdata; + mp->extensions = opt->extensions; + @<Set default function pointers@> + + mp->find_file = opt->find_file ? opt->find_file : mp_find_file ; + mp->open_file = opt->open_file ? opt->open_file : mp_open_file ; + mp->read_file = opt->read_file ? opt->read_file : mp_read_file ; + mp->close_file = opt->close_file ? opt->close_file : mp_close_file ; + mp->write_file = opt->write_file ? opt->write_file : mp_write_file ; + mp->shipout_backend = opt->shipout_backend ? opt->shipout_backend : mp_shipout_backend; + mp->run_script = opt->run_script ? opt->run_script : mp_run_script ; + mp->run_internal = opt->run_internal ? opt->run_internal : mp_run_internal ; + mp->run_logger = opt->run_logger ? opt->run_logger : mp_run_logger ; + mp->run_overload = opt->run_overload ? opt->run_overload : mp_run_overload ; + mp->run_error = opt->run_error ? opt->run_error : mp_run_error ; + mp->run_warning = opt->run_warning ? opt->run_warning : mp_run_warning ; + mp->make_text = opt->make_text ? opt->make_text : mp_make_text ; + + mp->find_file_id = opt->find_file_id; + mp->run_script_id = opt->run_script_id; + mp->run_internal_id = opt->run_internal_id; + mp->run_logger_id = opt->run_logger_id; + mp->run_overload_id = opt->run_overload_id; + mp->run_error_id = opt->run_error_id; + mp->run_warning_id = opt->run_warning_id; + mp->make_text_id = opt->make_text_id; + mp->open_file_id = opt->open_file_id; + + if (opt->banner && *(opt->banner)) { + mp->banner = mp_strdup(opt->banner); + } else { + mp->banner = mp_strdup(default_banner); + } + switch (opt->math_mode) { + case mp_math_scaled_mode: + mp->math = mp_initialize_scaled_math(mp); + break; + case mp_math_decimal_mode: + mp->math = mp_initialize_decimal_math(mp); + break; + case mp_math_binary_mode: + mp->math = mp_initialize_binary_math(mp); + break; + default: + mp->math = mp_initialize_double_math(mp); + break; + } + @<Allocate or initialize variables@> + mp_reallocate_paths(mp, 1000); + /* in case we quit during initialization: */ + mp->history = mp_fatal_error_stop; + mp_do_initialize(mp); + /* initialize the tables */ + mp_init_tab(mp); + switch (opt->math_mode) { + case mp_math_scaled_mode: + set_internal_string(mp_number_system_internal, mp_intern(mp, "scaled")); + break; + case mp_math_decimal_mode: + set_internal_string(mp_number_system_internal, mp_intern(mp, "decimal")); + break; + case mp_math_binary_mode: + set_internal_string(mp_number_system_internal, mp_intern(mp, "binary")); + break; + default: + set_internal_string(mp_number_system_internal, mp_intern(mp, "double")); + break; + } + /* call |primitive| for each primitive */ + mp_init_prim(mp); + mp_fix_date_and_time(mp); + mp->history = mp_spotless; + set_precision(); + @<Fix up |job_name|@> + return mp; +} + +@ @<Exported function headers@>= +extern MP_options *mp_options (void); +extern MP mp_initialize (MP_options * opt); +extern int mp_status (MP mp); +extern int mp_finished (MP mp); +extern void *mp_userdata (MP mp); + +@ @c +int mp_status (MP mp) { return mp->history; } +int mp_finished (MP mp) { return mp->finished; } +void *mp_userdata (MP mp) { return mp->userdata; } + +@ The overall \MP\ program begins with the heading just shown, after which comes +a bunch of procedure declarations and function declarations. Finally we will get +to the main program, which begins with the comment |start_here|. If you want to +skip down to the main program now, you can look up |start_here| in the index. But +the author suggests that the best way to understand this program is to follow +pretty much the order of \MP's components as they appear in the \CWEB\ +description you are now reading, since the present ordering is intended to +combine the advantages of the \quote {bottom up} and \quote {top down} approaches +to the problem of understanding a somewhat complicated system. + +@ The following parameters can be changed at compile time to extend or reduce +\MP's capacity. @^system dependencies@> + +@<Constants...@>= +# define bistack_size 1500 /* size of stack for bisection algorithms; should + probably be left at this value */ + +@ Like the preceding parameters, the following quantities can be changed to +extend or reduce \MP's capacity. + +@ @<Glob...@>= +int max_in_open; /* maximum number of input files and error insertions that can + be going on simultaneously */ +int param_size; /* maximum number of simultaneous macro parameters */ +int padding_size; /* so that the next array nicely sits in the cache */ + +@ @<Option variables@>= +int halt_on_error; /* do we quit at the first error? */ +void *userdata; /* this allows the calling application to setup local (e.g. L for Lua) */ +char *banner; /* the banner that is printed to the screen and log */ +int utf8_mode; +int text_mode; +int show_mode; + +@ @<Dealloc variables@>= +mp_memory_free(mp->banner); + +@ @<Allocate or ...@>= +mp->param_size = 4; +mp->max_in_open = 0; +mp->halt_on_error = opt->halt_on_error ? 1 : 0; +mp->utf8_mode = opt->utf8_mode ? 1 : 0; +mp->text_mode = opt->text_mode ? 1 : 0; +mp->show_mode = opt->show_mode ? 1 : 0; + +@ Here are some macros for common programming idioms (incr and decr are now +inlined). + +@d odd(A) (abs(A) % 2 == 1) /* replaced by proper number_odd calls, tex has: ((x) & 1) */ + +@* The character set. + +@ We assume proper ASCII codes to be used and likely UTF-8 so we dropped the two +way mapping from input to internal and from internal to to output (actually that +mapping was not that robust because some strings bypassed the conversions). + +@* Input and output. + +The bane of portability is the fact that different operating systems treat input +and output quite differently, perhaps because computer scientists have not given +sufficient attention to this problem. People have felt somehow that input and +output are not part of \quote {real} programming. Well, it is true that some kinds of +programming are more fun than others. With existing input/output conventions +being so diverse and so messy, the only sources of joy in such parts of the code +are the rare occasions when one can find a way to make the program a little less +bad than it might have been. We have two choices, either to attack I/O now and +get it over with, or to postpone I/O until near the end. Neither prospect is very +attractive, so let's get it over with. + +The basic operations we need to do are (1)~inputting and outputting of text, to +or from a file or the user's terminal; (2)~inputting and outputting of eight-bit +bytes, to or from a file; (3)~instructing the operating system to initiate \quote +{open} or to terminate \quote {close} input or output from a specified file; +(4)~testing whether the end of an input file has been reached; (5)~display of +bits on the user's screen. The bit-display operation will be discussed in a later +section; we shall deal here only with more traditional kinds of I/O. + +@ Finding files happens in a slightly roundabout fashion: the \MP\ instance +object contains a field that holds a function pointer that finds a file, and +returns its name, or NULL. For this, it receives three parameters: the +non-qualified name |fname|, the intended |fopen| operation type |fmode|, and the +type of the file |ftype|. + +The file types that are passed on in |ftype| can be used to differentiate file +searches if a library like kpathsea is used, the fopen mode is passed along for +the same reason. + +@ @<Exported types@>= +enum mp_filetype { + mp_filetype_terminal, /* the terminal (input) */ + mp_filetype_program, /* \MP\ language input */ + mp_filetype_text /* first text file for readfrom and writeto primitives */ +}; + +typedef char *(*mp_file_finder) (MP, const char *, const char *, int); +typedef char *(*mp_script_runner) (MP, const char *m, size_t len, int n); +typedef void (*mp_internal_runner) (MP, int action, int n, int type, const char *iname); +typedef void (*mp_log_runner) (MP, int, const char *s, size_t l); +typedef int (*mp_overload_runner) (MP, int, const char *, int); +typedef void (*mp_error_runner) (MP, const char *, const char *, int); +typedef void (*mp_warning_runner) (MP, const char *); +typedef char *(*mp_text_maker) (MP, const char *, size_t, int); +typedef void *(*mp_file_opener) (MP, const char *, const char *, int); +typedef char *(*mp_file_reader) (MP, void *, size_t *); +typedef void (*mp_file_closer) (MP, void *); +typedef int (*mp_file_eoftest) (MP, void *); +typedef void (*mp_file_flush) (MP, void *); +typedef void (*mp_file_writer) (MP, void *, const char *); + +@ @<Option variables@>= +mp_file_finder find_file; +mp_script_runner run_script; +mp_internal_runner run_internal; +mp_log_runner run_logger; +mp_overload_runner run_overload; +mp_error_runner run_error; +mp_warning_runner run_warning; +mp_text_maker make_text; +mp_file_opener open_file; +mp_file_closer close_file; +mp_file_reader read_file; +mp_file_writer write_file; + +int find_file_id; +int run_script_id; +int run_internal_id; +int run_logger_id; +int run_overload_id; +int run_error_id; +int run_warning_id; +int make_text_id; +int open_file_id; + +@ The default function for finding files is |mp_find_file|. It is pretty stupid: +it will only find files in the current directory. + +@c +static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype) +{ + (void) mp; (void) fname; (void) fmode; (void) ftype; + mp_fatal_error(mp, "no 'find_file' callback set"); + return NULL; +} + +static char *mp_run_script (MP mp, const char *str, size_t len, int n) +{ + (void) mp; (void) str; (void) len; (void) n; + mp_fatal_error(mp, "no 'run_script' callback set"); + return NULL; +} + +void mp_run_internal (MP mp, int action, int n, int type, const char *iname) +{ + (void) mp; (void) action; (void) n; (void) type; (void) iname; + mp_fatal_error(mp, "no 'run_internal' callback set"); +} + +@ The logger has to deal with the console and the log file and gets information +about the target. + +@c +static void mp_run_logger (MP mp, int target, const char *s, size_t l) +{ + (void) mp; (void) target; (void) s; (void) l; + mp_fatal_error(mp, "no 'run_logger' callback set"); +} + + +@ The overload catch is responsible for its own reporting and quitting +if needed. The check only happens when the mode is set. + +@c +static int mp_run_overload (MP mp, int property, const char *str, int mode) +{ + (void) mp; (void) property; (void) str; (void) mode; + mp_fatal_error(mp, "no 'run_overload' callback set"); + return 0; +} + +static void mp_check_overload (MP mp, mp_sym p) +{ + /* not the fastest check */ + if (number_nonzero(internal_value(mp_overloadmode_internal))) { + if (mp->run_overload(mp, p->property, (const char *) p->text->str, number_to_int(internal_value(mp_overloadmode_internal)))) { + p->property = 0; + } else { + /* we keep the property */ + } + } else { + /* we reset the mode */ + p->property = 0; + } +} + +@ Error and warning handling can be delegated too. Warnings are not really used yet +but they might show up some day. + +@c +static void mp_run_error (MP mp, const char *msg, const char *hlp, int interaction) +{ + (void) mp; (void) msg; (void) hlp; (void) interaction; + mp_fatal_error(mp, "no 'run_error' callback set"); +} + +static void mp_run_warning (MP mp, const char *msg) +{ + (void) mp; (void) msg; + mp_fatal_error(mp, "no 'run_warning' callback set"); +} + +@ The |btex ... etex| handling is still present and depends on a callback and +some cooperation with the backend. In \CONTEXT\ we implements text objects as +paths with properties (pre- and postscripts). + +@c +static char *mp_make_text (MP mp, const char *str, size_t len, int mode) +{ + (void) mp; (void) mode; (void) str; (void) len; + mp_fatal_error(mp, "no 'make_text' callback set"); + return NULL; +} + +@ Watch out: at this moment we have |mp_find_file| as well as |open_file| and +both need to be set. + +@<Declarations@>= +static char *mp_find_file (MP mp, const char *fname, const char *fmode, int ftype); +static void *mp_open_file (MP mp, const char *fname, const char *fmode, int ftype); +static char *mp_read_file (MP mp, void *f, size_t * size); +static void mp_close_file (MP mp, void *f); +static void mp_write_file (MP mp, void *f, const char *s); +static char *mp_run_script (MP mp, const char *str, size_t len, int n); +static void mp_run_internal (MP mp, int action, int n, int type, const char *iname); +static void mp_run_logger (MP mp, int target, const char *s, size_t l); +static int mp_run_overload (MP mp, int property, const char *, int); +static void mp_run_error (MP mp, const char *, const char *, int); +static void mp_run_warning (MP mp, const char *); +static char *mp_make_text (MP mp, const char *str, size_t len, int mode); + +@ As with the other callbacks, once they are needed and not set an error is +triggered. It made no sense to keep not used code around. + +@c +static void *mp_open_file (MP mp, const char *fname, const char *fmode, int ftype) +{ + (void) mp; (void) fname; (void) fmode; (void) ftype; + mp_fatal_error(mp, "no 'open_file' callback set"); + return NULL; +} + +@ (Almost) all file names pass through |name_of_file|. + +@<Glob...@>= +char *name_of_file; /* the name of a system file */ + +@ If this parameter is true, the terminal and log will report the found file +names for input files instead of the requested ones. It is off by default because +it creates an extra filename lookup. + +@ \MP's file-opening procedures return |false| if no file identified by +|name_of_file| could be opened. + +The |do_open_file| function takes care of the |print_found_names| parameter. The +file helpers are mandate callbacks. Not setting them triggers an error. + +@c +static int mp_do_open_file (MP mp, void **f, int ftype, const char *mode) +{ + /* + For now we keep the two step find and open approach because we get back + the full (found) name but all logic is at the \LUA\ end. Maybe some day + we need the original name. + */ + char *s = (mp->find_file)(mp, mp->name_of_file, mode, ftype); + if (s != NULL) { + mp_memory_free(mp->name_of_file); + mp->name_of_file = mp_strdup(s); + // lmt_generic_free(s); + lmt_memory_free(s); + *f = (mp->open_file)(mp, mp->name_of_file, mode, ftype); + } else { + *f = NULL; + } + return (*f ? 1 : 0); +} + +static int mp_open_in (MP mp, void **f, int ftype) +{ + return mp_do_open_file(mp, f, ftype, "r"); +} + +static int mp_open_out (MP mp, void **f, int ftype) +{ + return mp_do_open_file(mp, f, ftype, "w"); +} + +static char *mp_read_file (MP mp, void *f, size_t *size) +{ + (void) mp; (void) f; (void) size; + mp_fatal_error(mp, "no 'read_file' callback set"); + return NULL; +} + +static void mp_write_file (MP mp, void *f, const char *s) +{ + (void) mp; (void) f; (void) s; + mp_fatal_error(mp, "no 'read_file' callback set"); +} + +static void mp_close_file (MP mp, void *f) +{ + (void) mp; (void) f; + mp_fatal_error(mp, "no 'close_file' callback set"); +} + +@ Input from text files is read one line at a time, using a routine called +|input_ln|. This function is defined in terms of global variables called +|buffer|, |first|, and |last| that will be described in detail later; for now, it +suffices for us to know that |buffer| is an array of |unsigned char| values, and +that |first| and |last| are indices into this array representing the beginning +and ending of a line of text. + +@<Glob...@>= +size_t buf_size; /* maximum number of characters simultaneously present in current lines of open files */ +unsigned char *buffer; /* lines of characters being read */ +size_t first; /* the first unused position in |buffer| */ +size_t last; /* end of the line just input to |buffer| */ +size_t max_buf_stack; /* largest index used in |buffer| */ + +@ @<Allocate or initialize ...@>= +mp->buf_size = 200; +mp->buffer = mp_memory_allocate((size_t) (mp->buf_size + 1) * sizeof(unsigned char)); + +@ @<Dealloc variables@>= +mp_memory_free(mp->buffer); + +@ @c +static void mp_reallocate_buffer (MP mp, size_t l) +{ + if (l > max_halfword) { + mp_confusion(mp, "buffer size"); /* can't happen (I hope) */ + } else { + unsigned char *buffer = mp_memory_allocate((size_t) (l + 1) * sizeof(unsigned char)); + memcpy(buffer, mp->buffer, (mp->buf_size + 1)); + mp_memory_free(mp->buffer); + mp->buffer = buffer; + mp->buf_size = l; + } +} + +@ The |input_ln| function brings the next line of input from the specified field +into available positions of the buffer array and returns the value |true|, unless +the file has already been entirely read, in which case it returns |false| and +sets |last := first|. In general, the |unsigned char| numbers that represent the +next line of the file are input into |buffer [first]|, |buffer [first + 1]|, +\dots, |buffer [last - 1]|; and the global variable |last| is set equal to +|first| plus the length of the line. Trailing blanks are removed from the line; +thus, either |last = first| (in which case the line was entirely blank) or +|buffer [last - 1] <>" "|. @^inner loop@> + +The variable |max_buf_stack|, which is used to keep track of how large the +|buf_size| parameter must be to accommodate the present job, is also kept up to +date by |input_ln|. + +@c +static int mp_input_ln (MP mp, void *f) +{ + /* inputs the next line or returns |false| */ + char *s; + size_t size = 0; + mp->last = mp->first; /* cf.\ Matthew 19\thinspace:\thinspace30 */ + s = (mp->read_file)(mp, f, &size); + if (s == NULL) { + return 0; + } else if (size > 0) { + mp->last = mp->first + size; + if (mp->last >= mp->max_buf_stack) { + mp->max_buf_stack = mp->last + 1; + while (mp->max_buf_stack > mp->buf_size) { + mp_reallocate_buffer(mp, (mp->buf_size + (mp->buf_size >> 2))); + } + } + memcpy((mp->buffer + mp->first), s, size); + } + // lmt_generic_free(s); + lmt_memory_free(s); + return 1; +} + +@ The user's terminal acts essentially like other files of text, except that it +is used both for input and for output. When the terminal is considered an input +file, the file variable is called |term_in|, and when it is considered an output +file the file variable is |term_out|. @^system dependencies@> + +@<Glob...@>= +void *term_in; /* the terminal as an input file */ + +@ Sometimes it is necessary to synchronize the input/output mixture that happens +on the user's terminal, and three system-dependent procedures are used for this +purpose. The first of these, |update_terminal|, is called when we want to make +sure that everything we have output to the terminal so far has actually left the +computer's internal buffers and been sent. The second, |clear_terminal|, is +called when we wish to cancel any input that the user may have typed ahead (since +we are about to issue an unexpected error message). The third, +|wake_up_terminal|, is supposed to revive the terminal if the user has disabled +it by some instruction to the operating system. The following macros show how +these operations can be specified: @^system dependencies@> + +@<MPlib internal header stuff@>= +# define update_terminal() mp_print_nl_only(mp); /* empty the terminal output buffer */ +# define clear_terminal() /* clear the terminal input buffer */ +# define wake_up_terminal() mp_print_nl_only(mp); /* cancel the user's cancellation of output */ + +@ The global variable |loc| should be set so that the character to be read next +by \MP\ is in |buffer [loc]|. This character should not be blank, and we should +have |loc < last|. + +@d loc mp->cur_input.loc_field /* location of first unread character in |buffer| */ + +@* Globals for strings. + +@ Symbolic token names and diagnostic messages are variable-length strings of +eight-bit characters. Many strings \MP\ uses are simply literals in the compiled +source, like the error messages and the names of the internal parameters. Other +strings are used or defined from the \MP\ input language, and these have to be +interned. + +\MP\ uses strings more extensively than \MF\ does, but the necessary operations +can still be handled with a fairly simple data structure. The avl tree |strings| +contains all of the known string structures. + +Each structure contains an |unsigned char| pointer containing the eight-bit data, +a |size_t| that holds the length of that data, and an |int| that indicates how +often this string is referenced (this will be explained below). Such strings are +referred to by structure pointers called |mp_string|. + +Besides the avl tree, there is a set of three variables called |cur_string|, +|cur_length| and |cur_string_size| that are used for strings while they are being +built. + +@<Exported types...@>= +typedef struct mp_lstring { + unsigned char *str; /* the string value */ + size_t len; /* its length */ + int refs; /* number of references */ +} mp_lstring; + +typedef mp_lstring *mp_string; /* for pointers to string values */ + +@ The string handling functions are in |mpstrings.w|, but strings need a bunch +of globals and those are defined here in the main file. + +@<Glob...@>= +avl_tree strings; /* string avl tree */ +unsigned char *cur_string; /* current string buffer */ +size_t cur_length; /* current index in that buffer */ +size_t cur_string_size; /* malloced size of |cur_string| */ + +@ @<Allocate or initialize ...@>= +mp_initialize_strings(mp); + +@ @<Dealloc variables@>= +mp_dealloc_strings(mp); + +@ The next four variables are for keeping track of string memory usage. + +@<Glob...@>= +int pool_in_use; /* total number of string bytes actually in use */ +int max_pl_used; /* maximum |pool_in_use| so far */ +int strs_in_use; /* total number of strings actually in use */ +int max_strs_used; /* maximum |strs_in_use| so far */ + +@* On-line and off-line printing. + +Messages that are sent to a user's terminal and to the transcript-log file are +produced by several |print| procedures. These procedures will direct their +output to a variety of places, based on the setting of the global variable +|selector|, which has the following possible values: + +\yskip + +\hang |term_and_log|, the normal setting, prints on the terminal and on the +transcript file. + +\hang |log_only|, prints only on the transcript file. + +\hang |term_only|, prints only on the terminal. + +\hang |no_print|, doesn't print at all. This is used only in rare cases before +the transcript file is open. + +\hang |pseudo|, puts output into a cyclic buffer that is used by the +|show_context| routine; when we get to that routine we shall discuss the +reasoning behind this curious mode. + +\hang |new_string|, appends the output to the current string in the string pool. + +\hang |>= first_file| prints on one of the files used for the |write| +@:write_}{|write| primitive@> command. + +\yskip + +\noindent The symbolic names |term_and_log|, etc., have been assigned numeric +codes that satisfy the convenient relations |no_print + 1 = term_only|, |no_print ++ 2 = log_only|, |term_only + 2 = log_only + 1 = term_and_log|. These relations +are not used when |selector| could be |pseudo|, or |new_string|. We need not +check for unprintable characters when |selector < pseudo|. We no longer use that +magic and just test the constants. + +Two additional global variables, |term_offset| and |file_offset| record if +characters have been printed since they were most recently cleared. We use +|term_offset|, and |file_offset|, on the other hand, keep track of how many +characters have appeared so far on the current line that has been output to the +terminal, the transcript file, or piped into \LUA. + +@<MPlib internal header stuff@>= +typedef enum mp_selectors { + mp_new_string_selector, /* printing is deflected to the string pool */ + mp_no_print_selector, /* |selector| setting that makes data disappear */ + mp_term_only_selector, /* printing is destined for the terminal only */ + mp_log_only_selector, /* printing is destined for the transcript file only */ + mp_term_and_log_selector, /* normal |selector| setting */ + mp_first_file_selector, /* first write file selector */ +} mp_selectors; + +typedef enum mp_logging_targets { + mp_void_logging_target, + mp_term_logging_target, + mp_file_logging_target, + mp_both_logging_target, + mp_error_logging_target, +} mp_logging_targets; + +@ @<Glob...@>= +unsigned int selector; /* where to print a message */ +unsigned int term_offset; /* the number of characters on the current terminal line */ +unsigned int file_offset; /* the number of characters on the current file line */ + +@ @<Initialize the output routines@>= +mp->term_offset = 0; +mp->file_offset = 0; + +@ Macro abbreviations for output to the terminal and to the log file are defined +here for convenience. Some systems need special conventions for terminal output, +and it is possible to adhere to those conventions by changing |wterm|, +|wterm_ln|, and |wterm_cr| here. @^system dependencies@> + +@<MPlib internal header stuff@>= +# define mp_fputs(b,f) (mp->write_file)(mp, f, b) + +# define mp_log_string(target,s) (mp->run_logger)(mp, target, s, strlen(s)) +# define mp_log_mpstr(target,s,l) (mp->run_logger)(mp, target, s, l) +# define mp_log_cr(target) (mp->run_logger)(mp, target, "\n", 1) +# define mp_log_chr(target,s) { unsigned char ss[2] = { s, 0 }; (mp->run_logger)(mp, target, (const char *) ss, 1); } +# define mp_log_error(s) (mp->run_logger)(mp, mp_error_logging_target, s, strlen(s)) + +@ To end a line of text output, we call |print_ln|. Cases |0..max_write_files| +use an array |wr_file| that will be declared later. + +The names of the print functions are more or less in sync with the ones used +in the \LUAMETATEX\ source code. + +@<Declarations@>= +static void mp_print_str (MP mp, const char *s); +static void mp_print_nl (MP mp, const char *s); +static void mp_print_fmt (MP mp, const char *s, ...); +static void mp_print_ln (MP mp); +static void mp_print_chr (MP mp, unsigned char k); +static void mp_print_mp_str (MP mp, mp_string s); +static void mp_print_nl (MP mp, const char *s); +static void mp_print_two (MP mp, mp_number *x, mp_number *y); + +@ @<Exported function headers@>= +extern void mp_print_e_str (MP mp, const char *s); +extern void mp_print_e_chr (MP mp, unsigned char k); + +@ @c +static void mp_print_ln (MP mp) +{ + switch (mp->selector) { + case mp_term_and_log_selector: + mp_log_cr(mp_both_logging_target); + mp->term_offset = 0; + mp->file_offset = 0; + break; + case mp_log_only_selector: + mp_log_cr(mp_file_logging_target); + mp->file_offset = 0; + break; + case mp_term_only_selector: + mp_log_cr(mp_term_logging_target); + mp->term_offset = 0; + break; + case mp_no_print_selector: + case mp_new_string_selector: + break; + default: + mp_fputs("\n", mp->wr_file[mp->selector - mp_first_file_selector]); + } +} + +@ The |print_char| procedure sends one character to the desired destination. All +printing comes through |print_ln| or |print_char|, hence these routines are the +ones that limit lines to at most |max_print_line| characters. But we must make an +exception for the \POSTSCRIPT\ output file since it is not safe to cut up lines +arbitrarily in \POSTSCRIPT. Anyway, we don't have a backend other than \LUA\ so +we just flush all without checking, so the nicely cleaned up offset code is +now gone too (just a boolean) so we lost |max_print_line|, |error_line| etc. + +@c +static void mp_print_chr (MP mp, unsigned char s) +{ + switch (mp->selector) { + case mp_term_and_log_selector: + mp_log_chr(mp_both_logging_target, s); + mp->term_offset = 1; + mp->file_offset = 1; + break; + case mp_log_only_selector: + mp_log_chr(mp_file_logging_target, s); + mp->file_offset = 1; + break; + case mp_term_only_selector: + mp_log_chr(mp_term_logging_target, s); + mp->term_offset = 1; + break; + case mp_no_print_selector: + break; + case mp_new_string_selector: + mp_str_room(mp, 1); + mp_append_char(mp, s); + break; + default: + { + unsigned char ss[2] = { s, 0 }; + mp_fputs((char *) ss, mp->wr_file[mp->selector - mp_first_file_selector]); + } + } +} + +void mp_print_e_chr (MP mp, unsigned char s) +{ + mp_print_chr(mp, s); +} + +static void mp_do_print (MP mp, const char *s, size_t len) +{ + if (len == 0) { + return; + } else if (mp->selector == mp_new_string_selector) { + mp_str_room(mp, (int) len); + memcpy((mp->cur_string + mp->cur_length), s, len); + mp->cur_length += len; + } else { + switch (mp->selector) { + case mp_term_and_log_selector: + mp_log_mpstr(mp_both_logging_target, s, (int) len); + mp->term_offset = 1; + mp->file_offset = 1; + break; + case mp_log_only_selector: + mp_log_mpstr(mp_file_logging_target, s, (int) len); + mp->file_offset = 1; + break; + case mp_term_only_selector: + mp_log_mpstr(mp_term_logging_target, s, (int) len); + mp->term_offset = 1; + break; + case mp_no_print_selector: + break; + case mp_new_string_selector: + mp_str_room(mp, (int) len); + mp_append_str(mp, s); + break; + default: + mp_fputs(s, mp->wr_file[mp->selector - mp_first_file_selector]); + break; + } + } +} + +static void mp_print_str (MP mp, const char *s) +{ + mp_do_print(mp, s, strlen(s)); +} + +void mp_print_e_str (MP mp, const char *s) +{ + mp_print_str(mp,s); +} + +static void mp_print_fmt (MP mp, const char *s, ...) +{ + va_list ap; + char pval[256]; + va_start(ap, s); + vsnprintf(pval, 256, s, ap); + mp_do_print(mp, pval, strlen(pval)); + va_end(ap); +} + +static void mp_print_mp_str (MP mp, mp_string s) +{ + mp_do_print(mp, (const char *) s->str, s->len); +} + +@ Here is the very first thing that \MP\ prints: a headline that identifies the +version number and base name. + +@<Initialize the output...@>= +mp_log_string(mp_term_logging_target, mp->banner); +mp_log_string(mp_term_logging_target, ", running in "); +mp_log_string(mp_term_logging_target, mp_str(mp, internal_string(mp_number_system_internal))); +mp_log_string(mp_term_logging_target, " mode."); +mp_print_ln(mp); +update_terminal(); + +@ @<Declarations@>= +static void mp_print_nl_only (MP mp); + +@ The procedure |print_nl| is like |print|, but it makes sure that the string +appears at the beginning of a new line. + +@c +static void mp_print_nl_only (MP mp) +{ + switch (mp->selector) { + case mp_term_and_log_selector: + if (mp->file_offset > 0) { + mp_log_cr(mp_file_logging_target); + mp->file_offset = 0; + } + if (mp->term_offset > 0) { + mp_log_cr(mp_term_logging_target); + mp->term_offset = 0; + } + break; + case mp_log_only_selector: + if (mp->file_offset > 0) { + mp_log_cr(mp_file_logging_target); + mp->file_offset = 0; + } + break; + case mp_term_only_selector: + if (mp->term_offset > 0) { + mp_log_cr(mp_term_logging_target); + mp->term_offset = 0; + } + break; + case mp_no_print_selector: + case mp_new_string_selector: + break; + } +} + +static void mp_print_nl (MP mp, const char *s) +{ + mp_print_nl_only(mp); + mp_print_str(mp, s); +} + +@ The following procedure, which prints out the decimal representation of a given +integer |n|, assumes that all integers fit nicely into a |int|. @^system +dependencies@> + +@c +static void mp_print_int (MP mp, int n) +{ + char s[12]; + mp_snprintf(s, 12, "%d", (int) n); + mp_print_str(mp, s); +} + +@ @<Declarations@>= +static void mp_print_int (MP mp, int n); + +@* Reporting errors. + +@ The global variable |interaction| has four settings, representing increasing +amounts of user interaction: + +@<Exported types@>= +enum mp_interaction_mode { + mp_unspecified_mode, /* extra value for command-line switch */ + mp_batch_mode, /* omits all stops and omits terminal output */ + mp_nonstop_mode, /* omits all stops */ + mp_scroll_mode, /* omits error stops */ + mp_error_stop_mode, /* stops at every opportunity to interact */ + mp_silent_mode /* stops at every opportunity to interact but not always*/ +}; + +@ @<Option variables@>= +int interaction; /* current level of interaction */ +int extensions; + +@ Set it here so it can be overwritten by the commandline + +@<Allocate or initialize ...@>= +mp->interaction = opt->interaction; +if (mp->interaction == mp_unspecified_mode || mp->interaction > mp_silent_mode) { + mp->interaction = mp_error_stop_mode; +} +if (mp->interaction < mp_unspecified_mode) { + mp->interaction = mp_batch_mode; +} + +@ \MP\ is careful not to call |error| when the print |selector| setting might be +unusual. The only possible values of |selector| at the time of error messages are + +\yskip + +\hang|no_print| (when |interaction=mp_batch_mode| and |log_file| not yet open); + +\hang|term_only| (when |interaction>mp_batch_mode| and |log_file| not yet open); + +\hang|log_only| (when |interaction=mp_batch_mode| and |log_file| is open); + +\hang|term_and_log| (when |interaction>mp_batch_mode| and |log_file| is open). + +@ The global variable |history| records the worst level of error that has been +detected. It has four possible values: |spotless|, |warning_issued|, +|error_message_issued|, and |fatal_error_stop|. + +Another global variable, |error_count|, is increased by one when an |error| +occurs without an interactive dialog, and it is reset to zero at the end of every +statement. If |error_count| reaches 100, \MP\ decides that there is no point in +continuing further. + +@<Exported types@>= +enum mp_history_state { + mp_spotless, /* |history| value when nothing has been amiss yet */ + mp_warning_issued, /* |history| value when |begin_diagnostic| has been called */ + mp_error_message_issued, /* |history| value when |error| has been called */ + mp_fatal_error_stop, /* |history| value when termination was premature */ + mp_system_error_stop /* |history| value when termination was due to disaster */ +}; + +@ @<Glob...@>= +int history; /* has the source input been clean so far? */ +int error_count; /* the number of scrolled errors since the last statement ended */ + +@ The value of |history| is initially |fatal_error_stop|, but it will be changed +to |spotless| if \MP\ survives the initialization process. + +@ Since errors can be detected almost anywhere in \MP, we want to declare the +error procedures near the beginning of the program. But the error procedures in +turn use some other procedures, which need to be declared |forward| before we get +to |error| itself. + +It is possible for |error| to be called recursively if some error arises when +|get_next| is being used to delete a token, and/or if some fatal error occurs +while \MP\ is trying to fix a non-fatal one. But such recursion @^recursion@> is +never more than two levels deep. + +@<Declarations@>= +static void mp_get_next (MP mp); +static void mp_begin_file_reading (MP mp); + +@ @<Exported function ...@>= +extern void mp_show_context (MP mp); + +@ @<Internal ...@>= +void mp_normalize_selector (MP mp); + +@ @<Glob...@>= +int use_err_help; /* should the |err_help| string be shown? */ +int padding_help; /* well ... why not. */ +mp_string err_help; /* a string set up by |errhelp| */ + +@ @<Allocate or ...@>= +mp->use_err_help = 0; + +@ The |jump_out| procedure just cuts across all active procedure levels and goes +to |end_of_MP|. This is the only nonlocal |goto| statement in the whole program. +It is used when there is no recovery from a particular error. + +The program uses a |jump_buf| to handle this, this is initialized at three spots: +the start of |mp_new|, the start of |mp_initialize|, and the start of |mp_run|. +Those are the only library entry points. @^system dependencies@> + +@<Glob...@>= +jmp_buf *jump_buf; + +@ If the array of internals is still |NULL| when |jump_out| is called, a crash +occured during initialization, and it is not safe to run the normal cleanup +routine. + +@<Error hand...@>= +void mp_jump_out (MP mp) +{ + if (mp->internal != NULL && mp->history < mp_system_error_stop) { + mp_close_files_and_terminate(mp); + } + longjmp(*(mp->jump_buf), 1); +} + +@ @<Internal ...@>= +void mp_jump_out (MP mp); + +@ @<Error hand...@>= +void mp_warn (MP mp, const char *msg) +{ + int selector = mp->selector; + mp_normalize_selector(mp); + mp_print_nl(mp, "Warning: "); + mp_print_str(mp, msg); + mp_print_ln(mp); + mp->selector = selector; +} + +@ Here now is the general |error| routine. + +Individual lines of help are recorded in the array |help_line|, which contains +entries in positions |0 .. (help_ptr - 1)|. They should be printed in reverse +order, i.e., with |help_line [0]| appearing last. + +@c +void mp_error (MP mp, const char *msg, const char *hlp) +{ + int selector = mp->selector; + mp_normalize_selector(mp); + mp->run_error(mp, msg, hlp, mp->interaction); + if (mp->history < mp_error_message_issued) { + mp->history = mp_error_message_issued; + } + if (mp->halt_on_error) { + mp->history = mp_fatal_error_stop; + mp_jump_out(mp); + } + ++mp->error_count; + if (mp->error_count == 100) { + mp_print_nl(mp, "(That makes 100 errors; please try again.)"); + @.That makes 100 errors...@> + mp->history = mp_fatal_error_stop; + mp_jump_out(mp); + } + mp->selector = selector; +} + +@ @<Exported function ...@>= +extern void mp_error (MP mp, const char *msg, const char *hlp); +extern void mp_warn (MP mp, const char *msg); + +@ In anomalous cases, the print selector might be in an unknown state; the +following subroutine is called to fix things just enough to keep running a bit +longer. + +@c +void mp_normalize_selector (MP mp) +{ + mp->selector = mp->interaction == mp_batch_mode ? mp_log_only_selector : mp_term_and_log_selector; +} + +@ The following procedure prints \MP's last words before dying. + +@<Error hand...@>= +void mp_fatal_error (MP mp, const char *s) +{ + /* prints |s|, and that's it */ + mp_normalize_selector(mp); + if (mp->interaction == mp_error_stop_mode) { + /* no more interaction */ + mp->interaction = mp_scroll_mode; + } + mp_error(mp, "Emergency stop", s); + mp->history = mp_fatal_error_stop; + /* irrecoverable error */ + mp_jump_out(mp); +@.Emergency stop@> +} + +@ @<Exported function ...@>= +extern void mp_fatal_error (MP mp, const char *s); + +@ The program might sometime run completely amok, at which point there is no +choice but to stop. If no previous error has been detected, that's bad news; a +message is printed that is really intended for the \MP\ maintenance person +instead of the user (unless the user has been particularly diabolical). The index +entries for \quote {this can't happen} may help to pinpoint the problem. @^dry +rot@> + +@<Internal library ...@>= +void mp_confusion (MP mp, const char *s); + +@ Consistency check violated; |s| tells where. + +@<Error hand...@>= +void mp_confusion (MP mp, const char *s) +{ + char msg[256]; + const char *hlp = NULL; + mp_normalize_selector(mp); + if (mp->history < mp_error_message_issued) { + mp_snprintf(msg, 256, "This can't happen (%s)", s); + hlp = + "I'm broken. Please show this to someone who can fix can fix it and try\n" + "again"; + @.This can't happen@> + } else { + hlp = + "One of your faux pas seems to have wounded me deeply ... in fact, I'm barely\n" + "conscious. Please fix it and try again."; + mp_snprintf(msg, 256, "I can't go on meeting you like this"); + @.I can't go on...@> + } + if (mp->interaction == mp_error_stop_mode) { + /* no more interaction */ + mp->interaction = mp_scroll_mode; + } + mp_error(mp, msg, hlp); + mp->history=mp_fatal_error_stop; + /* irrecoverable error */ + mp_jump_out(mp); +} + +@ A couple of state variables: + +@<Global...@>= +int run_state; /* are we processing input ? */ +int finished; /* set true by |close_files_and_terminate| */ + +@ @<Allocate or ...@>= +mp->finished = 0; + +@* Arithmetic with scaled numbers. + +The principal computations performed by \MP\ are done entirely in terms of +integers less than $2^{31}$ in magnitude; thus, the arithmetic specified in this +program can be carried out in exactly the same way on a wide variety of +computers, including some small ones. @^small computers@> + +But C does not rigidly define the |/| operation in the case of negative +dividends; for example, the result of |(-2 * n - 1) / 2| is |- ( n + 1)| on some +computers and |-n| on others (is this true ?). There are two principal types of +arithmetic: \quotation {translation-preserving,} in which the identity |(a + q * +b) / b = (a / b) + q| is valid; and \quotation {negation-preserving,} in which +|(-a) / b = -(a/b)|. This leads to two \MP s, which can produce different +results, although the differences should be negligible when the language is being +used properly. The \TEX\ processor has been defined carefully so that both +varieties of arithmetic will produce identical output, but it would be too +inefficient to constrain \MP\ in a similar way. + +@d inf_t mp->math->md_inf_t +@d negative_inf_t mp->math->md_negative_inf_t + +@ A single computation might use several subroutine calls, and it is desirable to +avoid producing multiple error messages in case of arithmetic overflow. So the +routines below set the global variable |arith_error| to |true| instead of +reporting errors directly to the user. @^overflow in arithmetic@> + +@<Glob...@>= +int arith_error; + +@ @<Allocate or ...@>= +mp->arith_error = 0; + +@ At crucial points the program will say |check_arith|, to test if an arithmetic +error has been detected. + +@d check_arith() + if (mp->arith_error) { + mp_clear_arith(mp); + } + +@c +static void mp_clear_arith (MP mp) { + mp_error( + mp, + "Arithmetic overflow", + "Uh, oh. A little while ago one of the quantities that I was computing got too\n" + "large, so I'm afraid your answers will be somewhat askew. You'll probably have to\n" + "adopt different tactics next time. But I shall try to carry on anyway." + ); + @.Arithmetic overflow@> + mp->arith_error = 0; +} + +@ The definitions of these are set up by the math initialization. Here +|arc_tol_k| is the criterium to quit when change in arc length +estimate reaches it. + +@d arc_tol_k mp->math->md_arc_tol_k +@d coef_bound_k mp->math->md_coef_bound_k +@d coef_bound_minus_1 mp->math->md_coef_bound_minus_1 +@d sqrt_8_e_k mp->math->md_sqrt_8_e_k +@d twelve_ln_2_k mp->math->md_twelve_ln_2_k +@d twelvebits_3 mp->math->md_twelvebits_3 +@d one_k mp->math->md_one_k +@d epsilon_t mp->math->md_epsilon_t +@d unity_t mp->math->md_unity_t +@d zero_t mp->math->md_zero_t +@d two_t mp->math->md_two_t +@d three_t mp->math->md_three_t +@d half_unit_t mp->math->md_half_unit_t +@d three_quarter_unit_t mp->math->md_three_quarter_unit_t +@d twentysixbits_sqrt2_t mp->math->md_twentysixbits_sqrt2_t +@d twentyeightbits_d_t mp->math->md_twentyeightbits_d_t +@d twentysevenbits_sqrt2_d_t mp->math->md_twentysevenbits_sqrt2_d_t +@d warning_limit_t mp->math->md_warning_limit_t +@d precision_default mp->math->md_precision_default +@d precision_min mp->math->md_precision_min +@d precision_max mp->math->md_precision_max + +@ In fact, the two sorts of scaling discussed above aren't quite sufficient; \MP\ +has yet another, used internally to keep track of angles. + +@ We often want to print two scaled quantities in parentheses, separated by a +comma. + +@c +static void mp_print_two (MP mp, mp_number *x, mp_number *y) +{ + mp_print_chr(mp, '('); + print_number(*x); + mp_print_chr(mp, ','); + print_number(*y); + mp_print_chr(mp, ')'); +} + +@d fraction_one_t mp->math->md_fraction_one_t +@d fraction_half_t mp->math->md_fraction_half_t +@d fraction_three_t mp->math->md_fraction_three_t +@d fraction_four_t mp->math->md_fraction_four_t +@d one_eighty_deg_t mp->math->md_one_eighty_deg_t +@d negative_one_eighty_deg_t mp->math->md_negative_one_eighty_deg_t +@d three_sixty_deg_t mp->math->md_three_sixty_deg_t + +@ And now let's complete our collection of numeric utility routines by +considering random number generation. \MP\ generates pseudo-random numbers with +the additive scheme recommended in Section 3.6 of {\em The Art of Computer +Programming}; however, the results are random fractions between 0 and +|fraction_one-1|, inclusive. + +There's an auxiliary array |randoms| that contains 55 pseudo-random fractions. +Using the recurrence $x_n = (x_{n - 55} - x_{n - 31}) \bmod 2^{28}$, we generate +batches of 55 new $x_n$'s at a time by calling |new_randoms|. The global variable +|j_random| tells which element has most recently been consumed. The global +variable |random_seed| was introduced in version 0.9, for the sole reason of +stressing the fact that the initial value of the random seed is system-dependant. +The initialization code below will initialize this variable to |(internal +[mp_time] div unity) + internal [mp_day]|, but this is not good enough on modern +fast machines that are capable of running multiple \METAPOST\ processes within +the same second. @^system dependencies@> + +@<Glob...@>= +mp_number randoms[55]; /* the last 55 random values generated */ +int j_random; /* the number of unused |randoms| */ +int j_padding; /* the number of unused |randoms| */ + +@ @<Option variables@>= +int random_seed; /* the default random seed */ + +@ @<Allocate or initialize ...@>= +mp->random_seed = opt->random_seed; +for (int i = 0; i < 55; i++) { + new_fraction(mp->randoms[i]); +} + +@ @<Dealloc...@>= +for (int i = 0; i < 55; i++) { + free_number(mp->randoms[i]); +} + +@ @<Internal library ...@>= +void mp_new_randoms (MP mp); + +@ @c +void mp_new_randoms (MP mp) +{ + mp_number x; /* accumulator */ + new_number(x); + for (int k = 0; k <= 23; k++) { + set_number_from_subtraction(x, mp->randoms[k], mp->randoms[k + 31]); + if (number_negative(x)) { + number_add(x, fraction_one_t); + } + number_clone(mp->randoms[k], x); + } + for (int k = 24; k <= 54; k++) { + set_number_from_subtraction(x, mp->randoms[k], mp->randoms[k - 24]); + if (number_negative(x)) { + number_add(x, fraction_one_t); + } + number_clone(mp->randoms[k], x); + } + free_number(x); + mp->j_random = 54; +} + +@ To consume a random fraction, the program below will say |next_random|. Now +each number system has its own implementation, true to the original as much as +possibile. + +@ To produce a uniform random number in the range |0 <= u < x| or |0 >= u > x| or +|0 = u = x|, given a |scaled| value~|x|, we proceed as shown here. + +Note that the call of |take_fraction| will produce the values 0 and~|x| with +about half the probability that it will produce any other particular values +between 0 and~|x|, because it rounds its answers. This is the original one, that +stays as reference: As said before, now each number system has its own +implementation. + +@ Finally, a normal deviate with mean zero and unit standard deviation can +readily be obtained with the ratio method (Algorithm 3.4.1R in {\em The Art of +Computer Programming}). This is the original one, that stays as reference: Now +each number system has its own implementation, true to the original as much as +possibile. + +@ The random related code is in the number system modules. + +@* Packed data. + +@d max_quarterword 0x3FFF /* largest allowable value in a |quarterword| */ +@d max_halfword 0xFFFFFFF /* largest allowable value in a |halfword| */ + +@ The reader should study the following definitions closely: @^system +dependencies@> + +@<Types...@>= +typedef struct mp_value_node_data *mp_value_node; +typedef struct mp_node_data *mp_node; +typedef struct mp_symbol_entry *mp_sym; + +typedef unsigned short quarterword; /* 1/4 of a 64 bit word */ +typedef int halfword; /* 1/2 of a 64 bit word */ + +typedef struct mp_independent_data { + int scale; /* only for |indep_scale|, used together with |serial| */ + int serial; /* only for |indep_value|, used together with |scale| */ +} mp_independent_data; + +typedef struct mp_value_data { + mp_independent_data indep; + mp_number n; + mp_string str; + mp_sym sym; + mp_node node; + mp_knot p; +} mp_value_data; + +typedef struct mp_value { + mp_variable_type type; + int padding; + mp_value_data data; +} mp_value; + +@ The global variable |math_mode| has four settings, representing the math value +type that will be used in this run. + +The typedef for |mp_number| is here because it has to come very early. + +@<Exported types@>= +typedef enum mp_math_mode { + mp_math_scaled_mode, + mp_math_double_mode, + mp_math_binary_mode, + mp_math_decimal_mode +} mp_math_mode; + +@ @<Option variables@>= +int math_mode; /* math mode */ + +@ @<Allocate or initialize ...@>= +mp->math_mode = opt->math_mode; + +@ Most important memory is kept in a chain so we don't need to allocate that +often. We could (at some point) decide to use mimalloc. + +@<Declare helpers@>= +extern void *mp_memory_allocate (size_t size); +extern void *mp_memory_clear_allocate (size_t size); +extern void *mp_memory_reallocate (void *p, size_t size); +extern void mp_memory_free (void *p); + +extern void *mp_allocate_node (MP mp, size_t size); +extern void *mp_allocate_dash (MP mp); + +@ This is an attempt to spend less time in |malloc()|: + +@d max_num_token_nodes 8000 /* maybe make this configureable */ +@d max_num_pair_nodes 1000 +@d max_num_knot_nodes 1000 +@d max_num_value_nodes 1000 +@d max_num_symbolic_nodes 1000 + +@<Global ...@>= +mp_node token_nodes; +mp_node pair_nodes; +int num_token_nodes; +int num_pair_nodes; +mp_knot knot_nodes; +mp_node value_nodes; +int max_knot_nodes; +int num_knot_nodes; +int num_value_nodes; +mp_node symbolic_nodes; +int num_symbolic_nodes; + +@ @<Allocate or initialize ...@>= +mp->token_nodes = NULL; +mp->num_token_nodes = 0; +mp->pair_nodes = NULL; +mp->num_pair_nodes = 0; +mp->knot_nodes = NULL; +mp->max_knot_nodes = max_num_knot_nodes; +mp->num_knot_nodes = 0; +mp->value_nodes = NULL; +mp->num_value_nodes = 0; +mp->symbolic_nodes = NULL; +mp->num_symbolic_nodes = 0; + +@ @<Dealloc ...@>= +while (mp->value_nodes) { + mp_node p = mp->value_nodes; + mp->value_nodes = p->link; + mp_free_node(mp, p, sizeof(mp_value_node_data)); +} +while (mp->symbolic_nodes) { + mp_node p = mp->symbolic_nodes; + mp->symbolic_nodes = p->link; + mp_free_node(mp, p, sizeof(mp_node_data)); +} +while (mp->pair_nodes) { + mp_node p = mp->pair_nodes; + mp->pair_nodes = p->link; + mp_free_node(mp, p, sizeof(mp_pair_node_data)); +} +while (mp->token_nodes) { + mp_node p = mp->token_nodes; + mp->token_nodes = p->link; + mp_free_node(mp, p, sizeof(mp_node_data)); +} +while (mp->knot_nodes) { + mp_knot p = mp->knot_nodes; + mp->knot_nodes = p->next; + mp_free_knot(mp, p); +} + +@ This is a nicer way of allocating nodes. Users who wish to study the memory +requirements of particular applications can can use the special features that +keep track of current and maximum memory usage. All kind of statistics are +available on request but we no longer display them in the library. + +@ @<Glob...@>= +size_t var_used; /* how much memory is in use */ +size_t var_used_max; /* how much memory was in use max */ + +@ @c +void *mp_allocate_node (MP mp, size_t size) +{ + void *p = mp_memory_allocate(size); + ((mp_node) p)->link = NULL; + ((mp_node) p)->hasnumber = 0; + mp->var_used += size; + if (mp->var_used > mp->var_used_max) { + mp->var_used_max = mp->var_used; + } + return p; +} + +void *mp_allocate_dash (MP mp) +{ + void *p = mp_memory_allocate(sizeof(mp_dash_object)); + mp->var_used += sizeof(mp_dash_object); + if (mp->var_used > mp->var_used_max) { + mp->var_used_max = mp->var_used; + } + return p; +} + +@ We want to be able to overload the allocator but then we also need to +pass to the avl handler and that one doesn't take the |mp| pointer so +we just do a hard exit. + +@c +void *mp_memory_allocate (size_t size) +{ + void *w = lmt_memory_malloc(size); + if (! w) { + printf("mplib ran out of memory, case 1"); + exit(EXIT_FAILURE); + } + return w; +} + +void *mp_memory_clear_allocate (size_t size) +{ + void *w = lmt_memory_calloc(1, size); + if (! w) { + printf("mplib ran out of memory, case 2"); + exit(EXIT_FAILURE); + } + return w; +} + +void *mp_memory_reallocate (void *p, size_t size) +{ + void *w = lmt_memory_realloc(p, size); + if (! w) { + printf("mplib ran out of memory, case 3"); + exit(EXIT_FAILURE); + } + return w; +} + +void mp_memory_free (void *p) +{ + lmt_memory_free(p); +} + +@ @<Internal library declarations@>= +# define mp_snprintf snprintf + +@* Dynamic memory allocation. + +The \MP\ system does nearly all of its own memory allocation, so that it can +readily be transported into environments that do not have automatic facilities +for strings, garbage collection, etc., and so that it can be in control of what +error messages the user receives. + +@d mp_link(A) (A)->link /* the |link| field of a node */ +@d mp_type(A) (A)->type /* identifies what kind of value this is */ +@d mp_name_type(A) (A)->name_type /* a clue to the name of this value */ + +@d mp_set_link(A,B) (A)->link = (mp_node) (B) + +@ @<MPlib internal header stuff@>= +typedef struct mp_node_data { + union { + mp_command_code command; + mp_variable_type type; + }; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_value_data data; +} mp_node_data; + +typedef struct mp_node_data *mp_symbolic_node; + +@ These will become inline: + +@c +# define mp_get_sym_info(A) mp_get_indep_value(A) +# define mp_set_sym_info(A,B) mp_set_indep_value(A, (B)) +# define mp_get_sym_sym(A) (A)->data.sym +# define mp_set_sym_sym(A,B) (A)->data.sym = (mp_sym)(B) + +@ The function |get_symbolic_node| returns a pointer to a new symbolic node whose +|link| field is null. @^inner loop@> + +@c +static mp_node mp_new_symbolic_node (MP mp) +{ + mp_symbolic_node p; + if (mp->symbolic_nodes) { + p = (mp_symbolic_node) mp->symbolic_nodes; + mp->symbolic_nodes = p->link; + mp->num_symbolic_nodes--; + p->link = NULL; + } else { + p = mp_allocate_node(mp, sizeof(mp_node_data)); + new_number(p->data.n); + p->hasnumber = 1; + } + p->type = mp_symbol_node_type; + p->name_type = mp_normal_operation; + return (mp_node) p; +} + +@ Conversely, when some node |p| of size |s| is no longer needed, the operation +|free_node(p,s)| will make its words available, by inserting |p| as a new empty +node just before where |rover| now points. + +A symbolic node is recycled by calling |free_symbolic_node|. + +@c +static void mp_free_node (MP mp, mp_node p, size_t siz) +{ + /* node liberation */ + if (p) { + mp->var_used -= siz; + if (mp->math_mode > mp_math_double_mode) { + if (p->hasnumber >= 1 && is_number(((mp_symbolic_node) p)->data.n)) { + free_number(((mp_symbolic_node) p)->data.n); + } + if (p->hasnumber == 2 && is_number(((mp_value_node) p)->subscript)) { + free_number(((mp_value_node) p)->subscript); + } + /* + There was a quite large |switch| here first, but the |mp_dash_node| + case was the only one that did anything ... + */ + if (mp_type(p) == mp_dash_node_type) { + free_number(((mp_dash_node) p)->start_x); + free_number(((mp_dash_node) p)->stop_x); + free_number(((mp_dash_node) p)->dash_y); + } + } + mp_memory_free(p); + } +} + +static void mp_free_symbolic_node (MP mp, mp_node p) +{ + /* node liberation */ + if (p) { + if (mp->num_symbolic_nodes < max_num_symbolic_nodes) { + p->link = mp->symbolic_nodes; + mp->symbolic_nodes = p; + mp->num_symbolic_nodes++; + } else { + mp->var_used -= sizeof(mp_node_data); + mp_memory_free(p); + } + } +} + +static void mp_free_value_node (MP mp, mp_node p) +{ + /* node liberation */ + if (p) { + if (mp->num_value_nodes < max_num_value_nodes) { + p->link = mp->value_nodes; + mp->value_nodes = p; + mp->num_value_nodes++; + } else { + mp->var_used -= sizeof(mp_value_node_data); + if (mp->math_mode > mp_math_double_mode) { + free_number(((mp_value_node) p)->data.n); + free_number(((mp_value_node) p)->subscript); + } + mp_memory_free(p); + } + } +} + +@ @<declarations@>= +static void mp_free_node (MP mp, mp_node p, size_t siz); +static void mp_free_symbolic_node (MP mp, mp_node p); +static void mp_free_value_node (MP mp, mp_node p); + +@* Memory layout. + +Some nodes are created statically, since static allocation is more efficient than +dynamic allocation when we can get away with it. + +@<Glob...@>= +mp_dash_node null_dash; +mp_value_node dep_head; +mp_node inf_val; +mp_node zero_val; +mp_node temp_val; +mp_node end_attr; +mp_node bad_vardef; +mp_node temp_head; +mp_node hold_head; +mp_node spec_head; + +@ The following code gets the memory off to a good start. + +@<Initialize table entries@>= +mp->spec_head = mp_new_symbolic_node(mp); +mp->temp_head = mp_new_symbolic_node(mp); +mp->hold_head = mp_new_symbolic_node(mp); + +@ @<Free table entries@>= +mp_free_symbolic_node(mp, mp->spec_head); +mp_free_symbolic_node(mp, mp->temp_head); +mp_free_symbolic_node(mp, mp->hold_head); + +@ The procedure |flush_node_list(p)| frees an entire linked list of nodes that +starts at a given position, until coming to a |NULL| pointer. @^inner loop@> + +@c +static void mp_flush_node_list (MP mp, mp_node p) +{ + while (p != NULL) { + mp_node q = p; + p = p->link; + if (q->type != mp_symbol_node_type) { + mp_free_token_node(mp, q); + } else { + mp_free_symbolic_node(mp, q); + } + } +} + +@* The command codes. + +Before we can go much further, we need to define symbolic names for the internal +code numbers that represent the various commands obeyed by \MP. These codes are +somewhat arbitrary, but not completely so. For example, some codes have been made +adjacent so that |case| statements in the program need not consider cases that +are widely spaced, or so that |case| statements can be replaced by |if| +statements. A command can begin an expression if and only if its code lies +between |min_primary_command| and |max_primary_command|, inclusive. The first +token of a statement that doesn't begin with an expression has a command code +between |min_command| and |max_statement_command|, inclusive. Anything less than +|min_command| is eliminated during macro expansions, and anything no more than +|max_pre_command| is eliminated when expanding \TEX\ material. Ranges such as +|min_secondary_command..max_secondary_command| are used when parsing expressions, +but the relative ordering within such a range is generally not critical. + +The ordering of the highest-numbered commands (|comma<semicolon<end_group<stop|) +is crucial for the parsing and error-recovery methods of this program as is the +ordering |if_test<fi_or_else| for the smallest two commands. The ordering is also +important in the ranges |numeric_token..plus_or_minus| and +|left_brace..ampersand|. + +At any rate, here is the list, for future reference. + +@d mp_max_command_code mp_stop +@d mp_max_pre_command mp_etex_command +@d mp_min_command (mp_defined_macro_command+1) +@d mp_max_statement_command mp_type_name_command +@d mp_min_primary_command mp_type_name_command +@d mp_min_suffix_token mp_internal_command +@d mp_max_suffix_token mp_numeric_command +@d mp_max_primary_command mp_plus_or_minus_command /* should also be |numeric_token+1| */ +@d mp_min_tertiary_command mp_plus_or_minus_command +@d mp_max_tertiary_command mp_tertiary_binary_command +@d mp_min_expression_command mp_left_brace_command +@d mp_max_expression_command mp_equals_command +@d mp_min_secondary_command mp_and_command +@d mp_max_secondary_command mp_secondary_binary_command +@d mp_end_of_statement (cur_cmd>mp_comma_command) + +@<Enumeration types@>= +typedef enum mp_command_code { + mp_undefined_command, + mp_btex_command, /* begin \TeX\ material (|btex|, |verbatimtex|) */ + mp_etex_command, /* end \TeX\ material (|etex|) */ + mp_if_test_command, /* conditional text (|if|) */ + mp_fi_or_else_command, /* delimiters for conditionals (|elseif|, |else|, |fi|) */ + mp_input_command, /* input a source file (|input|, |endinput|) */ + mp_iteration_command, /* iterate (|for|, |forsuffixes|, |forever|, |endfor|) */ + mp_repeat_loop_command, /* special command substituted for |endfor| */ + mp_exit_test_command, /* premature exit from a loop (|exitif|) */ + mp_relax_command, /* do nothing (|\char`\\|) */ + mp_scan_tokens_command, /* put a string into the input buffer */ + mp_runscript_command, /* put a script result string into the input buffer */ + mp_maketext_command, /* make a text (typesetting) */ + mp_expand_after_command, /* look ahead one token */ + mp_defined_macro_command, /* a macro defined by the user */ + mp_save_command, /* save a list of tokens (|save|) */ + mp_interim_command, /* save an internal quantity (|interim|) */ + mp_let_command, /* redefine a symbolic token (|let|) */ + mp_new_internal_command, /* define a new internal quantity (|newinternal|) */ + mp_macro_def_command, /* define a macro (|def|, |vardef|, etc.) */ + mp_ship_out_command, /* output a character (|shipout|) */ + mp_add_to_command, /* add to edges (|addto|) */ + mp_bounds_command, /* add bounding path to edges (|setbounds|, |clip|) */ + mp_protection_command, /* set protection flag (|outer|, |inner|) */ + mp_property_command, + mp_show_command, /* diagnostic output (|show|, |showvariable|, etc.) */ + mp_mode_command, /* set interaction level (|batchmode|, etc.) */ + mp_only_set_command, /* initialize random number generator (|randomseed|) */ + mp_message_command, /* communicate to user (|message|, |errmessage|) */ + mp_every_job_command, /* designate a starting token (|everyjob|) */ + mp_delimiters_command, /* define a pair of delimiters (|delimiters|) */ + mp_write_command, /* write text to a file (|write|) */ + mp_type_name_command, /* declare a type (|numeric|, |pair|, etc.) */ + mp_left_delimiter_command, /* the left delimiter of a matching pair */ + mp_begin_group_command, /* beginning of a group (|begingroup|) */ + mp_nullary_command, /* an operator without arguments (e.g., |normaldeviate|) */ + mp_unary_command, /* an operator with one argument (e.g., |sqrt|) */ + mp_str_command, /* convert a suffix to a string (|str|) */ + mp_void_command, /* convert a suffix to a boolean (|void|) */ + mp_cycle_command, /* close a cyclic path (|cycle|) */ + mp_of_binary_command, /* binary operation taking |of| (e.g., |point|) */ + mp_capsule_command, /* a value that has been put into a token list */ + mp_string_command, /* a string constant (e.g., |"hello"|) */ + mp_internal_command, /* internal numeric parameter (e.g., |pausing|) */ + mp_tag_command, /* a symbolic token without a primitive meaning */ + mp_numeric_command, /* a numeric constant (e.g., |3.14159|) */ + mp_plus_or_minus_command, /* either |+| or |-| */ + mp_secondary_def_command, /* a macro defined by |secondarydef| */ + mp_tertiary_binary_command, /* an operator at the tertiary level (e.g., |++|) */ + mp_left_brace_command, /* the operator `|\char||| */ + mp_path_join_command, /* the operator |..| */ + mp_ampersand_command, /* the operator `\.\&' */ + mp_tertiary_def_command, /* a macro defined by |tertiarydef| */ + mp_primary_binary_command, /* an operator at the expression level (e.g., |<|) */ + mp_equals_command, /* the operator |=| */ + mp_and_command, /* the operator |and| */ + mp_primary_def_command, /* a macro defined by |primarydef| */ + mp_slash_command, /* the operator |/| */ + mp_secondary_binary_command, /* an operator at the binary level (e.g., |shifted|) */ + mp_parameter_commmand, /* type of parameter (|primary|, |expr|, |suffix|, etc.) */ + mp_controls_command, /* specify control points explicitly (|controls|) */ + mp_tension_command, /* specify tension between knots (|tension|) */ + mp_at_least_command, /* bounded tension value (|atleast|) */ + mp_curl_command, /* specify curl at an end knot (|curl|) */ + mp_macro_special_command, /* special macro operators (|quote|, |\#\AT!|, etc.) */ + mp_right_delimiter_command, /* the right delimiter of a matching pair */ + mp_left_bracket_command, /* the operator |[| */ + mp_right_bracket_command, /* the operator |]| */ + mp_right_brace_command, /* the operator `|\char|}| */ + mp_with_option_command, /* option for filling (|withpen|, |withweight|, etc.) */ + mp_thing_to_add_command, /* variant of |addto| (|contour|, |doublepath|, |also|) */ + mp_of_command, /* the operator |of| */ + mp_to_command, /* the operator |to| */ + mp_step_command, /* the operator |step| */ + mp_until_command, /* the operator |until| */ + mp_within_command, /* the operator |within| */ + mp_assignment_command, /* the operator |:=| */ + mp_colon_command, /* the operator |:| */ + mp_comma_command, /* the operator |,|, must be |colon+1| */ + mp_semicolon_command, /* the operator |;|, must be |comma+1| */ + mp_end_group_command, /* end a group (|endgroup|), must be |semicolon+1| */ + mp_stop_command, /* end a job (|end|, |dump|), must be |end_group+1| */ + // mp_outer_tag_command, /* protection code added to command code */ + mp_undefined_cs_command, /* protection code added to command code */ +} mp_command_code; + +@ Variables and capsules in \MP\ have a variety of \quote {types,} distinguished by +the code numbers defined here. These numbers are also not completely arbitrary. +Things that get expanded must have types |> mp_independent|; a type remaining +after expansion is numeric if and only if its code number is at least +|numeric_type|; objects containing numeric parts must have types between +|transform_type| and |pair_type|; all other types must be smaller than +|transform_type|; and among the types that are not unknown or vacuous, the +smallest two must be |boolean_type| and |string_type| in that order. + +@d unknown_tag 1 /* this constant is added to certain type codes below */ + +@<Enumeration types@>= +typedef enum mp_variable_type { + mp_undefined_type, /* no type has been declared */ + mp_vacuous_type, /* no expression was present */ + mp_boolean_type, /* |boolean| with a known value */ + mp_unknown_boolean_type, + mp_string_type, /* |string| with a known value */ + mp_unknown_string_type, + mp_pen_type, /* |pen| with a known value */ + mp_unknown_pen_type, + mp_nep_type, /* |pen| with a known value */ + mp_unknown_nep_type, + mp_path_type, /* |path| with a known value */ + mp_unknown_path_type, + mp_picture_type, /* |picture| with a known value */ + mp_unknown_picture_type, + mp_transform_type, /* |transform| variable or capsule */ + mp_color_type, /* |color| variable or capsule */ + mp_cmykcolor_type, /* |cmykcolor| variable or capsule */ + mp_pair_type, /* |pair| variable or capsule */ + mp_numeric_type, /* variable that has been declared |numeric| but not used */ + mp_known_type, /* |numeric| with a known value */ + mp_dependent_type, /* a linear combination with |fraction| coefficients */ + mp_proto_dependent_type, /* a linear combination with |scaled| coefficients */ + mp_independent_type, /* |numeric| with unknown value */ + mp_token_list_type, /* variable name or suffix argument or text argument */ + mp_structured_type, /* variable with subscripts and attributes */ + mp_unsuffixed_macro_type, /* variable defined with |vardef| but no |\AT!\#| */ + mp_suffixed_macro_type, /* variable defined with |vardef| and |\AT!\#| */ + + mp_symbol_node_type, + mp_token_node_type, + mp_value_node_type, + mp_attribute_node_type, + mp_subscript_node_type, + mp_pair_node_type, + mp_transform_node_type, + mp_color_node_type, + mp_cmykcolor_node_type, + + /* + It is important that the next 7 items remain in this order, for export as + well as switch/case offsets. + */ + + mp_fill_node_type, + mp_stroked_node_type, + mp_start_clip_node_type, + mp_start_group_node_type, + mp_start_bounds_node_type, + + mp_stop_clip_node_type, + mp_stop_group_node_type, + mp_stop_bounds_node_type, + + mp_dash_node_type, + mp_dep_node_type, + mp_if_node_type, + mp_edge_header_node_type, +} mp_variable_type; + +@ @<Declarations@>= +static void mp_print_type (MP mp, int t); + +@ @c +static const char *mp_type_string(int t) +{ + const char *s = NULL; + switch (t) { + case mp_undefined_type: s = "undefined"; break; + case mp_vacuous_type: s = "vacuous"; break; + case mp_boolean_type: s = "boolean"; break; + case mp_unknown_boolean_type: s = "unknown boolean"; break; + case mp_string_type: s = "string"; break; + case mp_unknown_string_type: s = "unknown string"; break; + case mp_pen_type: s = "pen"; break; + case mp_unknown_pen_type: s = "unknown pen"; break; + case mp_nep_type: s = "pen"; break; + case mp_unknown_nep_type: s = "unknown pen"; break; + case mp_path_type: s = "path"; break; + case mp_unknown_path_type: s = "unknown path"; break; + case mp_picture_type: s = "picture"; break; + case mp_unknown_picture_type: s = "unknown picture"; break; + case mp_transform_type: s = "transform"; break; + case mp_color_type: s = "color"; break; + case mp_cmykcolor_type: s = "cmykcolor"; break; + case mp_pair_type: s = "pair"; break; + case mp_known_type: s = "known numeric"; break; + case mp_dependent_type: s = "dependent"; break; + case mp_proto_dependent_type: s = "proto-dependent"; break; + case mp_numeric_type: s = "numeric"; break; + case mp_independent_type: s = "independent"; break; + case mp_token_list_type: s = "token list"; break; + case mp_structured_type: s = "mp_structured"; break; + case mp_unsuffixed_macro_type: s = "unsuffixed macro"; break; + case mp_suffixed_macro_type: s = "suffixed macro"; break; + case mp_symbol_node_type: s = "symbol node"; break; + case mp_token_node_type: s = "token node"; break; + case mp_value_node_type: s = "value node"; break; + case mp_attribute_node_type: s = "attribute node"; break; + case mp_subscript_node_type: s = "subscript node"; break; + case mp_pair_node_type: s = "pair node"; break; + case mp_transform_node_type: s = "transform node"; break; + case mp_color_node_type: s = "color node"; break; + case mp_cmykcolor_node_type: s = "cmykcolor node"; break; + case mp_fill_node_type: s = "fill node"; break; + case mp_stroked_node_type: s = "stroked node"; break; + case mp_start_clip_node_type: s = "start clip node"; break; + case mp_start_group_node_type: s = "start group node"; break; + case mp_start_bounds_node_type: s = "start bounds node"; break; + case mp_stop_clip_node_type: s = "stop clip node"; break; + case mp_stop_group_node_type: s = "stop group node"; break; + case mp_stop_bounds_node_type: s = "stop bounds node"; break; + case mp_dash_node_type: s = "dash node"; break; + case mp_dep_node_type: s = "dependency node"; break; + case mp_if_node_type: s = "if node"; break; + case mp_edge_header_node_type: s = "edge header node"; break; + default: + { + char ss[256]; + mp_snprintf(ss, 256, "<unknown type %d>", t); + s = mp_strdup(ss); + } + break; + } + return s; +} + +void mp_print_type (MP mp, int t) +{ + if (t >= 0 && t <= mp_edge_header_node_type) { + mp_print_str(mp, mp_type_string(t)); + } else { + mp_print_str(mp, "unknown"); + } +} + +@ Values inside \MP\ are stored in non-symbolic nodes that have a |name_type| as +well as a |type|. The possibilities for |name_type| are defined here; they will +be explained in more detail later. + +@<Enumeration types...@>= +typedef enum mp_name_type_type { + mp_root_operation, /* |name_type| at the top level of a variable */ + mp_saved_root_operation, /* same, when the variable has been saved */ + mp_structured_root_operation, /* |name_type| where a |mp_structured| branch occurs */ + mp_subscript_operation, /* |name_type| in a subscript node */ + mp_attribute_operation, /* |name_type| in an attribute node */ + mp_x_part_operation, /* |name_type| in the |xpart| of a node */ + mp_y_part_operation, /* |name_type| in the |ypart| of a node */ + mp_xx_part_operation, /* |name_type| in the |xxpart| of a node */ + mp_xy_part_operation, /* |name_type| in the |xypart| of a node */ + mp_yx_part_operation, /* |name_type| in the |yxpart| of a node */ + mp_yy_part_operation, /* |name_type| in the |yypart| of a node */ + mp_red_part_operation, /* |name_type| in the |redpart| of a node */ + mp_green_part_operation, /* |name_type| in the |greenpart| of a node */ + mp_blue_part_operation, /* |name_type| in the |bluepart| of a node */ + mp_cyan_part_operation, /* |name_type| in the |redpart| of a node */ + mp_magenta_part_operation, /* |name_type| in the |greenpart| of a node */ + mp_yellow_part_operation, /* |name_type| in the |bluepart| of a node */ + mp_black_part_operation, /* |name_type| in the |greenpart| of a node */ + mp_grey_part_operation, /* |name_type| in the |greypart| of a node */ + mp_capsule_operation, /* |name_type| in stashed-away subexpressions */ + mp_token_operation, /* |name_type| in a numeric token or string token */ + + mp_boolean_type_operation, /* the order needs to match the types (as we use deltas) ! */ + mp_string_type_operation, + mp_pen_type_operation, + mp_nep_type_operation, + mp_path_type_operation, + mp_picture_type_operation, + mp_transform_type_operation, + mp_color_type_operation, + mp_cmykcolor_type_operation, + mp_pair_type_operation, + mp_numeric_type_operation, + + /* Symbolic nodes also have |name_type|, which is a different enumeration */ + + mp_normal_operation, + mp_internal_operation, /* for values of internals */ + mp_macro_operation, /* for macro names */ + mp_expr_operation, /* for macro parameters if type |expr| */ + mp_suffix_operation, /* for macro parameters if type |suffix| */ + mp_text_operation, /* for macro parameters if type |text| */ + @<Operation codes@> +} mp_name_type_type; + +@ Primitive operations that produce values have a secondary identification code +in addition to their command code; it's something like genera and species. For +example, |*| has the command code |primary_binary|, and its secondary +identification is |times|. The secondary codes start such that they don't overlap +with the type codes; some type codes (e.g., |mp_string_type|) are used as +operators as well as type identifications. The relative values are not critical, +except for |true_code..false_code|, |or_op..and_op|, and |filled_op..bounded_op|. +The restrictions are that |and_op-false_code=or_op-true_code|, that the ordering +of |x_part...blue_part| must match that of |x_part_operation..mp_blue_part_operation|, +and the ordering of |filled_op..bounded_op| must match that of the code values +they test for. + +Beware! The operation and type unumerations in some places run in parallel (with +an offset. That makes it possible the handle types with common code using a +delta. In some cases the delta is multiplied by 2 because we have knowns and +unknowns. A less sensitive to patches would be to just duplicate the code (or to +use a function call), + +@d mp_min_of_operation mp_substring_operation + +@<Operation codes@>= +mp_true_operation, /* operation code for |true| */ +mp_false_operation, /* operation code for |false| */ +mp_null_picture_operation, /* operation code for |nullpicture| */ +mp_null_pen_operation, /* operation code for |nullpen| */ +mp_read_string_operation, /* operation code for |readstring| */ +mp_pen_circle_operation, /* operation code for |pencircle| */ +mp_normal_deviate_operation, /* operation code for |normaldeviate| */ +mp_read_from_operation, /* operation code for |readfrom| */ +mp_close_from_operation, /* operation code for |closefrom| */ +mp_odd_operation, /* operation code for |odd| */ +mp_known_operation, /* operation code for |known| */ +mp_unknown_operation, /* operation code for |unknown| */ +mp_not_operation, /* operation code for |not| */ +mp_decimal_operation, /* operation code for |decimal| */ +mp_reverse_operation, /* operation code for |reverse| */ +mp_uncycle_operation, /* operation code for |uncycle| */ +mp_make_path_operation, /* operation code for |makepath| */ +mp_make_pen_operation, /* operation code for |makepen| */ +mp_make_nep_operation, /* operation code for |makenep| */ +mp_convexed_operation, /* operation code for |convexed| */ +mp_uncontrolled_operation, /* operation code for |uncontrolled| */ +mp_oct_operation, /* operation code for |oct| */ +mp_hex_operation, /* operation code for |hex| */ +mp_ASCII_operation, /* operation code for |ASCII| */ +mp_char_operation, /* operation code for |char| */ +mp_length_operation, /* operation code for |length| */ +mp_turning_operation, /* operation code for |turningnumber| */ +mp_color_model_operation, /* operation code for |colormodel| */ +mp_path_part_operation, /* operation code for |pathpart| */ +mp_pen_part_operation, /* operation code for |penpart| */ +mp_dash_part_operation, /* operation code for |dashpart| */ +mp_prescript_part_operation, /* operation code for |prescriptpart| */ +mp_postscript_part_operation, /* operation code for |postscriptpart| */ +mp_stacking_part_operation, /* operation code for |stackingpart| */ +mp_sqrt_operation, /* operation code for |sqrt| */ +mp_m_exp_operation, /* operation code for |mexp| */ +mp_m_log_operation, /* operation code for |mlog| */ +mp_sin_d_operation, /* operation code for |sind| */ +mp_cos_d_operation, /* operation code for |cosd| */ +mp_floor_operation, /* operation code for |floor| */ +mp_uniform_deviate_operation, /* operation code for |uniformdeviate| */ +mp_ll_corner_operation, /* operation code for |llcorner| */ +mp_lr_corner_operation, /* operation code for |lrcorner| */ +mp_ul_corner_operation, /* operation code for |ulcorner| */ +mp_ur_corner_operation, /* operation code for |urcorner| */ +mp_center_of_operation, /* operation code for |centerof| */ +mp_center_of_mass_operation, /* operation code for |centerofmass| */ +mp_corners_operation, /* operation code for |corners| */ +mp_x_range_operation, /* operation code for |xrange| */ +mp_y_range_operation, /* operation code for |yrange| */ +mp_delta_point_operation, /* operation code for |deltapoint| */ +mp_delta_precontrol_operation, /* operation code for |deltaprecontrol| */ +mp_delta_postcontrol_operation,/* operation code for |deltapostcontrol| */ +mp_delta_direction_operation, /* operation code for |deltadirection| */ +mp_arc_length_operation, /* operation code for |arclength| */ +mp_angle_operation, /* operation code for |angle| */ +mp_cycle_operation, /* operation code for |cycle| */ +mp_no_cycle_operation, /* operation code for |nocycle| */ +mp_filled_operation, /* operation code for |filled| */ +mp_stroked_operation, /* operation code for |stroked| */ +mp_clipped_operation, /* operation code for |clipped| */ +mp_grouped_operation, /* operation code for |bounded| */ +mp_bounded_operation, /* operation code for |grouped| */ +mp_plus_operation, /* operation code for \.+ */ +mp_minus_operation, /* operation code for \.- */ +mp_times_operation, /* operation code for \.* */ +mp_over_operation, /* operation code for \./ */ +mp_power_operation, /* operation code for \.^ */ +mp_pythag_add_operation, /* operation code for |++| */ +mp_pythag_sub_operation, /* operation code for |+-+| */ +mp_or_operation, /* operation code for |or| */ +mp_and_operation, /* operation code for |and| */ +mp_less_than_operation, /* operation code for \.< */ +mp_less_or_equal_operation, /* operation code for |<=| */ +mp_greater_than_operation, /* operation code for \.> */ +mp_greater_or_equal_operation, /* operation code for |>=| */ +mp_equal_operation, /* operation code for \.= */ +mp_unequal_operation, /* operation code for |<>| */ +mp_concatenate_operation, /* operation code for \.\& */ +mp_just_append_operation, /* operation code for \.\&\& */ +mp_rotated_operation, /* operation code for |rotated| */ +mp_slanted_operation, /* operation code for |slanted| */ +mp_scaled_operation, /* operation code for |scaled| */ +mp_shifted_operation, /* operation code for |shifted| */ +mp_transformed_operation, /* operation code for |transformed| */ +mp_uncycled_operation, /* operation code for |uncycled| */ +mp_x_scaled_operation, /* operation code for |xscaled| */ +mp_y_scaled_operation, /* operation code for |yscaled| */ +mp_z_scaled_operation, /* operation code for |zscaled| */ +mp_intertimes_operation, /* operation code for |intersectiontimes| */ +mp_intertimes_list_operation, /* operation code for |intersectiontimeslist| */ +mp_double_dot_operation, /* operation code for improper |..| */ +mp_substring_operation, /* operation code for |substring| */ +mp_subpath_operation, /* operation code for |subpath| */ +mp_direction_time_operation, /* operation code for |directiontime| */ +mp_point_operation, /* operation code for |point| */ +mp_precontrol_operation, /* operation code for |precontrol| */ +mp_postcontrol_operation, /* operation code for |postcontrol| */ +mp_direction_operation, /* operation code for |direction| */ +mp_path_point_operation, /* operation code for |pathpoint| */ +mp_path_precontrol_operation, /* operation code for |pathprecontrol| */ +mp_path_postcontrol_operation, /* operation code for |pathpostcontrol| */ +mp_path_direction_operation, /* operation code for |pathdirection| */ +mp_pen_offset_operation, /* operation code for |penoffset| */ +mp_arc_time_operation, /* operation code for |arctime| */ +mp_arc_point_operation, /* operation code for |arcpoint| */ +mp_arc_point_list_operation, /* operation code for |arcpointlist| */ +mp_subarc_length_operation, /* operation code for |subarclength| */ +mp_version_operation, /* operation code for |mpversion| */ +mp_envelope_operation, /* operation code for |envelope| */ +mp_boundingpath_operation, /* operation code for |boundingpath| */ + +@ @c +static const char *mp_op_string (int c) +{ + if (c <= mp_numeric_type) { + return mp_type_string(c); + } else { + switch (c) { + case mp_true_operation : return "true"; + case mp_false_operation : return "false"; + case mp_null_picture_operation : return "nullpicture"; + case mp_null_pen_operation : return "nullpen"; + case mp_read_string_operation : return "readstring"; + case mp_pen_circle_operation : return "pencircle"; + case mp_normal_deviate_operation : return "normaldeviate"; + case mp_read_from_operation : return "readfrom"; + case mp_close_from_operation : return "closefrom"; + case mp_odd_operation : return "odd"; + case mp_known_operation : return "known"; + case mp_unknown_operation : return "unknown"; + case mp_not_operation : return "not"; + case mp_decimal_operation : return "decimal"; + case mp_reverse_operation : return "reverse"; + case mp_uncycle_operation : return "uncycle"; + case mp_make_path_operation : return "makepath"; + case mp_make_pen_operation : return "makepen"; + case mp_make_nep_operation : return "makenep"; + case mp_convexed_operation : return "convexed"; + case mp_uncontrolled_operation : return "uncontrolled"; + case mp_oct_operation : return "oct"; + case mp_hex_operation : return "hex"; + case mp_ASCII_operation : return "ASCII"; + case mp_char_operation : return "char"; + case mp_length_operation : return "length"; + case mp_turning_operation : return "turningnumber"; + case mp_x_part_operation : return "xpart"; + case mp_y_part_operation : return "ypart"; + case mp_xx_part_operation : return "xxpart"; + case mp_xy_part_operation : return "xypart"; + case mp_yx_part_operation : return "yxpart"; + case mp_yy_part_operation : return "yypart"; + case mp_red_part_operation : return "redpart"; + case mp_green_part_operation : return "greenpart"; + case mp_blue_part_operation : return "bluepart"; + case mp_cyan_part_operation : return "cyanpart"; + case mp_magenta_part_operation : return "magentapart"; + case mp_yellow_part_operation : return "yellowpart"; + case mp_black_part_operation : return "blackpart"; + case mp_grey_part_operation : return "greypart"; + case mp_color_model_operation : return "colormodel"; + case mp_prescript_part_operation : return "prescriptpart"; + case mp_postscript_part_operation : return "postscriptpart"; + case mp_stacking_part_operation : return "stackingpart"; + case mp_path_part_operation : return "pathpart"; + case mp_pen_part_operation : return "penpart"; + case mp_dash_part_operation : return "dashpart"; + case mp_sqrt_operation : return "sqrt"; + case mp_m_exp_operation : return "mexp"; + case mp_m_log_operation : return "mlog"; + case mp_sin_d_operation : return "sind"; + case mp_cos_d_operation : return "cosd"; + case mp_floor_operation : return "floor"; + case mp_uniform_deviate_operation : return "uniformdeviate"; + case mp_ll_corner_operation : return "llcorner"; + case mp_lr_corner_operation : return "lrcorner"; + case mp_ul_corner_operation : return "ulcorner"; + case mp_ur_corner_operation : return "urcorner"; + case mp_center_of_operation : return "centerof"; + case mp_center_of_mass_operation : return "centerofmass"; + case mp_corners_operation : return "corners"; + case mp_x_range_operation : return "xrange"; + case mp_y_range_operation : return "yrange"; + case mp_delta_point_operation : return "deltapoint"; + case mp_delta_precontrol_operation : return "deltaprecontrol"; + case mp_delta_postcontrol_operation: return "deltapostcontrol"; + case mp_delta_direction_operation : return "deltadirection"; + case mp_arc_length_operation : return "arclength"; + case mp_angle_operation : return "angle"; + case mp_cycle_operation : return "cycle"; + case mp_no_cycle_operation : return "nocycle"; + case mp_filled_operation : return "filled"; + case mp_stroked_operation : return "stroked"; + case mp_clipped_operation : return "clipped"; + case mp_grouped_operation : return "grouped"; + case mp_bounded_operation : return "bounded"; + case mp_plus_operation : return "+"; + case mp_minus_operation : return "-"; + case mp_times_operation : return "*"; + case mp_over_operation : return "/"; + case mp_power_operation : return "^"; + case mp_pythag_add_operation : return "++"; + case mp_pythag_sub_operation : return "+-+"; + case mp_or_operation : return "or"; + case mp_and_operation : return "and"; + case mp_less_than_operation : return "<"; + case mp_less_or_equal_operation : return "<="; + case mp_greater_than_operation : return ">"; + case mp_greater_or_equal_operation : return ">="; + case mp_equal_operation : return "="; + case mp_unequal_operation : return "<>"; + case mp_concatenate_operation : return "&"; + case mp_just_append_operation : return "&&"; + case mp_rotated_operation : return "rotated"; + case mp_slanted_operation : return "slanted"; + case mp_scaled_operation : return "scaled"; + case mp_shifted_operation : return "shifted"; + case mp_transformed_operation : return "transformed"; + case mp_x_scaled_operation : return "xscaled"; + case mp_y_scaled_operation : return "yscaled"; + case mp_z_scaled_operation : return "zscaled"; + case mp_intertimes_operation : return "intersectiontimes"; + case mp_intertimes_list_operation : return "intersectiontimeslist"; + case mp_substring_operation : return "substring"; + case mp_subpath_operation : return "subpath"; + case mp_direction_time_operation : return "directiontime"; + case mp_point_operation : return "point"; + case mp_precontrol_operation : return "precontrol"; + case mp_postcontrol_operation : return "postcontrol"; + case mp_direction_operation : return "direction"; + case mp_path_point_operation : return "pathpoint"; + case mp_path_precontrol_operation : return "pathprecontrol"; + case mp_path_postcontrol_operation : return "pathpostcontrol"; + case mp_path_direction_operation : return "pathdirection"; + case mp_pen_offset_operation : return "penoffset"; + case mp_arc_time_operation : return "arctime"; + case mp_arc_point_operation : return "arcpoint"; + case mp_arc_point_list_operation : return "arcpointlist"; + case mp_subarc_length_operation : return "subarclength"; + case mp_version_operation : return "mpversion"; + case mp_envelope_operation : return "envelope"; + case mp_boundingpath_operation : return "boundingpath"; + + case mp_pen_type_operation : return "pen"; + case mp_nep_type_operation : return "nep"; + case mp_path_type_operation : return "path"; + case mp_picture_type_operation : return "picture"; + case mp_transform_type_operation : return "transform"; + case mp_color_type_operation : return "color"; + case mp_cmykcolor_type_operation : return "cmykcolor"; + case mp_pair_type_operation : return "pair"; + case mp_numeric_type_operation : return "numeric"; + + default : return ".."; + } + } +} +static void mp_print_op (MP mp, int c) +{ + mp_print_str(mp, mp_op_string(c)); +} + +@ \MP\ also has a bunch of internal parameters that a user might want to fuss +with. Every such parameter has an identifying code number, defined here. + +@<Types...@>= +typedef enum mp_given_internal { + mp_number_system_internal = 1, /* the number system as set up by |numbersystem| */ + mp_number_precision_internal, /* the number system precision as set up by |numberprecision| */ + mp_job_name_internal, /* the jobname as set up from the options stucture */ + mp_tracing_titles_internal, /* show titles online when they appear */ + mp_tracing_equations_internal, /* show each variable when it becomes known */ + mp_tracing_capsules_internal, /* show capsules too */ + mp_tracing_choices_internal, /* show the control points chosen for paths */ + mp_tracing_specs_internal, /* show path subdivision prior to filling with polygonal a pen */ + mp_tracing_commands_internal, /* show commands and operations before they are performed */ + mp_tracing_restores_internal, /* show when a variable or internal is restored */ + mp_tracing_macros_internal, /* show macros before they are expanded */ + mp_tracing_output_internal, /* dummy */ + mp_tracing_stats_internal, /* show memory usage at end of job */ /* now a dummy */ + mp_tracing_online_internal, /* show long diagnostics on terminal and in the log file */ + mp_year_internal, /* the current year (e.g., 1984) */ + mp_month_internal, /* the current month (e.g., 3 $\equiv$ March) */ + mp_day_internal, /* the current day of the month */ + mp_time_internal, /* the number of minutes past midnight when this job started */ + mp_hour_internal, /* the number of hours past midnight when this job started */ + mp_minute_internal, /* the number of minutes in that hour when this job started */ + mp_char_code_internal, /* the number of the next character to be output */ + mp_char_wd_internal, /* the width of the next character to be output */ + mp_char_ht_internal, /* the height of the next character to be output */ + mp_char_dp_internal, /* the depth of the next character to be output */ + mp_char_ic_internal, /* the italic correction of the next character to be output */ + mp_pausing_internal, /* dummy */ + mp_showstopping_internal, /* positive to stop after each |show| command */ + mp_texscriptmode_internal, /* controls spacing in texmode */ + mp_overloadmode_internal, + mp_linejoin_internal, /* as in \ps: 0 for mitered, 1 for round, 2 for beveled */ + mp_linecap_internal, /* as in \ps: 0 for butt, 1 for round, 2 for square */ + mp_stacking_internal, + mp_miterlimit_internal, /* controls miter length as in \ps */ + mp_warning_check_internal, /* controls error message when variable value is large */ + mp_true_corners_internal, /* positive to make |llcorner| etc. ignore |setbounds| */ + mp_default_color_model_internal, /* the default color model for unspecified items */ + mp_restore_clip_color_internal, +} mp_given_internal; + +typedef struct mp_internal { + mp_value v; + char *intname; + int run; + int padding; +} mp_internal; + +@ @<MPlib internal header stuff@>= +typedef enum mp_linecap_codes { + mp_butt_linecap_code, + mp_rounded_linecap_code, + mp_squared_linecap_code, + /* see below */ + mp_weird_linecap_code, +} mp_linecap_codes; + +typedef enum mp_linejoin_codes { + mp_mitered_linejoin_code, + mp_rounded_linejoin_code, + mp_beveled_linejoin_code, + /* we see this value being used */ + mp_weird_linejoin_code, +} mp_linejoin_codes; + +@ @<MPlib internal header stuff@>= +# define internal_value(A) mp->internal[(A)].v.data.n +# define internal_string(A) mp->internal[A].v.data.str +# define set_internal_string(A,B) mp->internal[(A)].v.data.str=(B) +# define internal_name(A) mp->internal[(A)].intname +# define set_internal_name(A,B) mp->internal[(A)].intname=(B) +# define internal_type(A) mp->internal[A].v.type +# define set_internal_type(A,B) mp->internal[(A)].v.type=(B) +# define internal_run(A) mp->internal[(A)].run +# define set_internal_run(A,B) mp->internal[(A)].run=(B) + +@ @d max_given_internal mp_restore_clip_color_internal + +@<Glob...@>= +mp_internal *internal; /* the values of internal quantities */ +int int_ptr; /* the maximum internal quantity defined so far */ +int max_internal; /* current maximum number of internal quantities */ + +@ @<Allocate or initialize ...@>= +//mp->max_internal = 2 * max_given_internal; +mp->max_internal = 1000 + max_given_internal; +mp->internal = mp_memory_allocate((size_t) (mp->max_internal + 1) * sizeof(mp_internal)); + +memset(mp->internal, 0, (size_t) (mp->max_internal + 1) * sizeof(mp_internal)); +for (int i = 1; i <= mp->max_internal; i++) { + new_number(mp->internal[i].v.data.n); +} +for (int i = 1; i <= max_given_internal; i++) { + set_internal_type(i, mp_known_type); +} + +set_internal_type(mp_number_system_internal, mp_string_type); +set_internal_type(mp_job_name_internal, mp_string_type); + +@ @<Set initial ...@>= +mp->int_ptr = max_given_internal; + +@ The symbolic names for internal quantities are put into \MP's hash table by +using a routine called |primitive|, which will be defined later. Let us enter +them now, so that we don't have to list all those names again anywhere else. + +@<Put each of \MP's primitives into the hash table@>= +mp_primitive(mp, "tracingtitles", mp_internal_command, mp_tracing_titles_internal); +@:tracingtitles_}{|tracingtitles| primitive@> +mp_primitive(mp, "tracingequations", mp_internal_command, mp_tracing_equations_internal); +@:mp_tracing_equations_}{|tracingequations| primitive@> +mp_primitive(mp, "tracingcapsules", mp_internal_command, mp_tracing_capsules_internal); +@:mp_tracing_capsules_}{|tracingcapsules| primitive@> +mp_primitive(mp, "tracingchoices", mp_internal_command, mp_tracing_choices_internal); +@:mp_tracing_choices_}{|tracingchoices| primitive@> +mp_primitive(mp, "tracingspecs", mp_internal_command, mp_tracing_specs_internal); +@:mp_tracing_specs_}{|tracingspecs| primitive@> +mp_primitive(mp, "tracingcommands", mp_internal_command, mp_tracing_commands_internal); +@:mp_tracing_commands_}{|tracingcommands| primitive@> +mp_primitive(mp, "tracingrestores", mp_internal_command, mp_tracing_restores_internal); +@:mp_tracing_restores_}{|tracingrestores| primitive@> +mp_primitive(mp, "tracingmacros", mp_internal_command, mp_tracing_macros_internal); +@:mp_tracing_macros_}{|tracingmacros| primitive@> +mp_primitive(mp, "tracingoutput", mp_internal_command, mp_tracing_output_internal); +@:mp_tracing_output_}{|tracingoutput| primitive@> +mp_primitive(mp, "tracingstats", mp_internal_command, mp_tracing_stats_internal); +@:mp_tracing_stats_}{|tracingstats| primitive@> +mp_primitive(mp, "tracingonline", mp_internal_command, mp_tracing_online_internal); +@:mp_tracing_online_}{|tracingonline| primitive@> +mp_primitive(mp, "year", mp_internal_command, mp_year_internal); +@:mp_year_}{|year| primitive@> +mp_primitive(mp, "month", mp_internal_command, mp_month_internal); +@:mp_month_}{|month| primitive@> +mp_primitive(mp, "day", mp_internal_command, mp_day_internal); +@:mp_day_}{|day| primitive@> +mp_primitive(mp, "time", mp_internal_command, mp_time_internal); +@:time_}{|time| primitive@> +mp_primitive(mp, "hour", mp_internal_command, mp_hour_internal); +@:hour_}{|hour| primitive@> +mp_primitive(mp, "minute", mp_internal_command, mp_minute_internal); +@:minute_}{|minute| primitive@> +mp_primitive(mp, "charcode", mp_internal_command, mp_char_code_internal); +@:mp_char_code_}{|charcode| primitive@> +mp_primitive(mp, "charwd", mp_internal_command, mp_char_wd_internal); +@:mp_char_wd_}{|charwd| primitive@> +mp_primitive(mp, "charht", mp_internal_command, mp_char_ht_internal); +@:mp_char_ht_}{|charht| primitive@> +mp_primitive(mp, "chardp", mp_internal_command, mp_char_dp_internal); +@:mp_char_dp_}{|chardp| primitive@> +mp_primitive(mp, "charic", mp_internal_command, mp_char_ic_internal); +@:mp_char_ic_}{|charic| primitive@> +mp_primitive(mp, "pausing", mp_internal_command, mp_pausing_internal); +@:mp_pausing_}{|pausing| primitive@> +mp_primitive(mp, "showstopping", mp_internal_command, mp_showstopping_internal); +@:mp_showstopping_}{|showstopping| primitive@> +mp_primitive(mp, "texscriptmode", mp_internal_command, mp_texscriptmode_internal); +@:mp_texscriptmode_}{|texscriptmode| primitive@> +mp_primitive(mp, "overloadmode", mp_internal_command, mp_overloadmode_internal); +@:mp_overloadmode_}{|overloadmode| primitive@> +mp_primitive(mp, "linejoin", mp_internal_command, mp_linejoin_internal); +@:mp_linejoin_}{|linejoin| primitive@> +mp_primitive(mp, "linecap", mp_internal_command, mp_linecap_internal); +@:mp_linecap_}{|linecap| primitive@> +mp_primitive(mp, "stacking", mp_internal_command, mp_stacking_internal); +@:mp_stacking_}{|stacking| primitive@> +mp_primitive(mp, "miterlimit", mp_internal_command, mp_miterlimit_internal); +@:mp_miterlimit_}{|miterlimit| primitive@> +mp_primitive(mp, "warningcheck", mp_internal_command, mp_warning_check_internal); +@:mp_warning_check_}{|warningcheck| primitive@> +mp_primitive(mp, "truecorners", mp_internal_command, mp_true_corners_internal); +@:mp_true_corners_}{|truecorners| primitive@> +mp_primitive(mp, "defaultcolormodel", mp_internal_command, mp_default_color_model_internal); +@:mp_default_color_model_}{|defaultcolormodel| primitive@> +mp_primitive(mp, "restoreclipcolor", mp_internal_command, mp_restore_clip_color_internal); +@:mp_restore_clip_color_}{|restoreclipcolor| primitive@> +mp_primitive(mp, "numbersystem", mp_internal_command, mp_number_system_internal); +@:mp_number_system_}{|numbersystem| primitive@> +mp_primitive(mp, "numberprecision", mp_internal_command, mp_number_precision_internal); +@:mp_number_precision_}{|numberprecision| primitive@> +mp_primitive(mp, "jobname", mp_internal_command, mp_job_name_internal); +@:mp_job_name_}{|jobname| primitive@> + +@ Colors can be specified in four color models. In the special case of +|no_model|, MetaPost does not output any color operator to the postscript output. + +Note: these values are passed directly on to |with_option|. This only works +because the other possible values passed to |with_option| are 8 and 10 +respectively (from |with_pen| and |with_picture|). + +There is a first state, that is only used for |gs_colormodel|. It flags the fact +that there has not been any kind of color specification by the user so far in the +game. + +@<MPlib header stuff@>= +typedef enum mp_color_model { + mp_no_model, + mp_grey_model, + mp_rgb_model, + mp_cmyk_model, + mp_uninitialized_model, +} mp_color_model; + +@ @<Initialize table entries@>= +number_clone(internal_value(mp_default_color_model_internal),unity_t); +number_multiply_int(internal_value(mp_default_color_model_internal), mp_rgb_model); +number_clone(internal_value(mp_restore_clip_color_internal), unity_t); +set_internal_string(mp_number_system_internal, mp_intern (mp, "scaled")); +number_clone(internal_value(mp_number_precision_internal), precision_default); +number_clone(internal_value(mp_texscriptmode_internal), unity_t); +number_clone(internal_value(mp_overloadmode_internal), zero_t); + +@ Well, we do have to list the names one more time, for use in symbolic +printouts. + +@<Initialize table...@>= +set_internal_name(mp_tracing_titles_internal, mp_strdup("tracingtitles")); +set_internal_name(mp_tracing_equations_internal, mp_strdup("tracingequations")); +set_internal_name(mp_tracing_capsules_internal, mp_strdup("tracingcapsules")); +set_internal_name(mp_tracing_choices_internal, mp_strdup("tracingchoices")); +set_internal_name(mp_tracing_specs_internal, mp_strdup("tracingspecs")); +set_internal_name(mp_tracing_commands_internal, mp_strdup("tracingcommands")); +set_internal_name(mp_tracing_restores_internal, mp_strdup("tracingrestores")); +set_internal_name(mp_tracing_macros_internal, mp_strdup("tracingmacros")); +set_internal_name(mp_tracing_output_internal, mp_strdup("tracingoutput")); +set_internal_name(mp_tracing_stats_internal, mp_strdup("tracingstats")); +set_internal_name(mp_tracing_online_internal, mp_strdup("tracingonline")); +set_internal_name(mp_year_internal, mp_strdup("year")); +set_internal_name(mp_month_internal, mp_strdup("month")); +set_internal_name(mp_day_internal, mp_strdup("day")); +set_internal_name(mp_time_internal, mp_strdup("time")); +set_internal_name(mp_hour_internal, mp_strdup("hour")); +set_internal_name(mp_minute_internal, mp_strdup("minute")); +set_internal_name(mp_char_code_internal, mp_strdup("charcode")); +set_internal_name(mp_char_wd_internal, mp_strdup("charwd")); +set_internal_name(mp_char_ht_internal, mp_strdup("charht")); +set_internal_name(mp_char_dp_internal, mp_strdup("chardp")); +set_internal_name(mp_char_ic_internal, mp_strdup("charic")); +set_internal_name(mp_pausing_internal, mp_strdup("pausing")); /* dummy */ +set_internal_name(mp_showstopping_internal, mp_strdup("showstopping")); +set_internal_name(mp_texscriptmode_internal, mp_strdup("texscriptmode")); +set_internal_name(mp_overloadmode_internal, mp_strdup("overloadmode")); +set_internal_name(mp_linejoin_internal, mp_strdup("linejoin")); +set_internal_name(mp_linecap_internal, mp_strdup("linecap")); +set_internal_name(mp_stacking_internal, mp_strdup("stacking")); +set_internal_name(mp_miterlimit_internal, mp_strdup("miterlimit")); +set_internal_name(mp_warning_check_internal, mp_strdup("warningcheck")); +set_internal_name(mp_true_corners_internal, mp_strdup("truecorners")); +set_internal_name(mp_default_color_model_internal, mp_strdup("defaultcolormodel")); +set_internal_name(mp_restore_clip_color_internal, mp_strdup("restoreclipcolor")); +set_internal_name(mp_job_name_internal, mp_strdup("jobname")); +set_internal_name(mp_number_system_internal, mp_strdup("numbersystem")); +set_internal_name(mp_number_precision_internal, mp_strdup("numberprecision")); + +@ The following procedure, which is called just before \MP\ initializes its input +and output, establishes the initial values of the date and time. @^system +dependencies@> + +Note that the values are |scaled| integers. Hence \MP\ can no longer be used +after the year 32767. + +@c +static void mp_fix_date_and_time (MP mp) +{ + time_t aclock = time ((time_t *) 0); + struct tm *tmptr = localtime (&aclock); + number_clone(internal_value(mp_time_internal), unity_t); + number_multiply_int(internal_value(mp_time_internal), (tmptr->tm_hour * 60 + tmptr->tm_min)); + number_clone(internal_value(mp_hour_internal), unity_t); + number_multiply_int(internal_value(mp_hour_internal), (tmptr->tm_hour)); + number_clone(internal_value(mp_minute_internal), unity_t); + number_multiply_int(internal_value(mp_minute_internal), (tmptr->tm_min)); + number_clone(internal_value(mp_day_internal), unity_t); + number_multiply_int(internal_value(mp_day_internal), (tmptr->tm_mday)); + number_clone(internal_value(mp_month_internal), unity_t); + number_multiply_int(internal_value(mp_month_internal), (tmptr->tm_mon + 1)); + number_clone(internal_value(mp_year_internal), unity_t); + number_multiply_int(internal_value(mp_year_internal), (tmptr->tm_year + 1900)); +} + +@ @<Declarations@>= +static void mp_fix_date_and_time (MP mp); + +@ \MP\ is occasionally supposed to print diagnostic information that goes only +into the transcript file, unless |mp_tracing_online| is positive. Now that we +have defined |mp_tracing_online| we can define two routines that adjust the +destination of print commands: + +@<Declarations@>= +static void mp_begin_diagnostic (MP mp); +static void mp_end_diagnostic (MP mp, int blank_line); +static void mp_print_diagnostic (MP mp, const char *s, const char *t, int nuline); + +@ @c +static void mp_begin_diagnostic (MP mp) +{ + /* prepare to do some tracing */ + mp->old_selector = mp->selector; + if (number_nonpositive(internal_value(mp_tracing_online_internal)) && (mp->selector == mp_term_and_log_selector)) { + mp->selector = mp_log_only_selector; + if (mp->history == mp_spotless) { + mp->history = mp_warning_issued; + } + } +} + +void mp_end_diagnostic (MP mp, int blank_line) +{ + /* restore proper conditions after tracing */ + mp_print_nl(mp, ""); + if (blank_line) { + mp_print_ln(mp); + } + mp->selector = mp->old_selector; +} + +@ @<Glob...@>= +unsigned int old_selector; + +@ We will occasionally use |begin_diagnostic| in connection with line-number +printing, as follows. (The parameter |s| is typically |"Path"| or |"Cycle spec"|, +etc.) + +@c +static void mp_print_diagnostic (MP mp, const char *s, const char *t, int nuline) +{ + mp_begin_diagnostic(mp); + if (nuline) { + mp_print_nl(mp, s); + } else { + mp_print_str(mp, s); + } + mp_print_str(mp, " at line "); + mp_print_int(mp, mp_true_line(mp)); + mp_print_str(mp, t); + mp_print_chr(mp, ':'); +} + +@ The 256 |unsigned char| characters are grouped into classes by means of the +|char_class| table. Individual class numbers have no semantic or syntactic +significance, except in a few instances defined here. There's also |max_class|, +which can be used as a basis for additional class numbers in nonstandard +extensions of \MP. + +@<Enumeration types@>= +typedef enum mp_class_codes { + mp_digit_class = 0, /* the class number of |0123456789| */ + mp_period_class = 1, /* the class number of |.| */ + mp_space_class = 2, /* the class number of spaces and nonstandard characters */ + mp_percent_class = 3, /* the class number of `\.\%' */ + mp_string_class = 4, /* the class number of |"| */ + mp_comma_class = 5, /* the , */ + mp_semicolon_class = 6, /* the ; */ + mp_left_parenthesis_class = 7, /* the class number of |(| */ + mp_right_parenthesis_class = 8, /* the class number of |)| */ + mp_letter_class = 9, /* letters and the underline character */ + mp_suffix_class = 15, + mp_left_bracket_class = 17, /* |[| */ + mp_right_bracket_class = 18, /* |]| */ + mp_brace_class = 19, + mp_invalid_class = 20, /* bad character in the input */ + mp_max_class = 20, /* the largest class number */ +} mp_class_codes; + +@ The class numbers: + +@<Glob...@>= +int char_class[256]; + +@ If changes are made to accommodate non-ASCII character sets, they should follow +the guidelines in Appendix~C of {\sl The {\logos METAFONT}book}. +@:METAFONTbook}{\sl The {\logos METAFONT}book@> @^system dependencies@> + +@<Set initial ...@>= +for (int k = '0'; k <= '9'; k++) { + mp->char_class[k] = mp_digit_class; +} +for (int k = 'A'; k <= 'Z'; k++) { + mp->char_class[k] = mp_letter_class; +} +for (int k = 'a'; k <= 'z'; k++) { + mp->char_class[k] = mp_letter_class; +} + +mp->char_class['.'] = mp_period_class; +mp->char_class[' '] = mp_space_class; +mp->char_class['%'] = mp_percent_class; +mp->char_class['"'] = mp_string_class; +mp->char_class[','] = mp_comma_class; +mp->char_class[';'] = mp_semicolon_class; +mp->char_class['('] = mp_left_parenthesis_class; +mp->char_class[')'] = mp_right_parenthesis_class; + +mp->char_class['_'] = mp_letter_class; +mp->char_class['<'] = 10; +mp->char_class['='] = 10; +mp->char_class['>'] = 10; +mp->char_class[':'] = 10; +mp->char_class['|'] = 10; +mp->char_class['`'] = 11; +mp->char_class['\''] = 11; +mp->char_class['+'] = 12; +mp->char_class['-'] = 12; +mp->char_class['/'] = 13; +mp->char_class['*'] = 13; +mp->char_class['\\'] = 13; +mp->char_class['^'] = 13; +mp->char_class['!'] = 14; +mp->char_class['?'] = 14; +mp->char_class['#'] = mp_suffix_class; +mp->char_class['&'] = mp_suffix_class; +mp->char_class['@@'] = mp_suffix_class; /* will become one after cwebbing */ +mp->char_class['$'] = mp_suffix_class; +mp->char_class['^'] = 16; +mp->char_class['~'] = 16; +mp->char_class['['] = mp_left_bracket_class; +mp->char_class[']'] = mp_right_bracket_class; +mp->char_class['{'] = mp_brace_class; +mp->char_class['}'] = mp_brace_class; + +for (int k = 0; k < ' '; k++) { + mp->char_class[k] = mp_invalid_class; +} + +mp->char_class['\r'] = mp_space_class; +mp->char_class['\n'] = mp_space_class; +mp->char_class['\t'] = mp_space_class; +mp->char_class['\f'] = mp_space_class; + +for (int k = 127; k <= 255; k++) { + mp->char_class[k] = mp->utf8_mode ? mp_letter_class : mp_invalid_class; +} + +if (mp->text_mode) { + mp->char_class[2] = mp_string_class; /* ascii 2 STX*/ + /* mp->char_class[3] = mp_string_class; */ /* ascii 3 ETX */ +} + +@* The hash table. + +Symbolic tokens are stored in and retrieved from an AVL tree. This is not as fast +as an actual hash table, but it is easily extensible. + +A symbolic token contains a pointer to the |mp_string| that contains the string +representation of the symbol, a |halfword| that holds the current command value +of the token, and an |mp_value| for the associated equivalent. + +@d set_text(A) { + (A)->text = (B) ; +} + +@d set_eq_type(A,B) { + (A)->type = (B) ; +} + +@d set_eq_property(A,B) { + (A)->property = (B) ; +} + +@d set_equiv(A,B) { + (A)->v.data.node = NULL ; + (A)->v.data.indep.serial = (B); +} + +@d set_equiv_node(A,B) { + (A)->v.data.node = (B) ; + (A)->v.data.indep.serial = 0; +} + +@d set_equiv_sym(A,B) { + (A)->v.data.node = (mp_node) (B); + (A)->v.data.indep.serial = 0; +} + +@ @c +# define text(A) (A)->text +# define eq_type(A) (A)->type +# define eq_property(A) (A)->property +# define equiv(A) (A)->v.data.indep.serial +# define equiv_node(A) (A)->v.data.node +# define equiv_sym(A) (mp_sym)(A)->v.data.node + +@ @<Types...@>= +typedef struct mp_symbol_entry { + int type; + int property; /* we had padding room anyway */ + mp_value v; + mp_string text; + void *parent; +} mp_symbol_entry; + +@ @<Glob...@>= +int st_count; /* total number of known identifiers */ +avl_tree symbols; /* avl tree of symbolic tokens */ +avl_tree frozen_symbols; /* avl tree of frozen symbolic tokens */ +avl_iterator symbol_iterator; + +mp_sym frozen_bad_vardef; +mp_sym frozen_colon; +mp_sym frozen_end_def; +mp_sym frozen_end_for; +mp_sym frozen_end_group; +mp_sym frozen_etex; +mp_sym frozen_fi; +mp_sym frozen_inaccessible; +mp_sym frozen_left_bracket; +mp_sym frozen_repeat_loop; +mp_sym frozen_right_delimiter; +mp_sym frozen_semicolon; +mp_sym frozen_slash; +mp_sym frozen_undefined; +mp_sym frozen_dump; + +@ Here are the functions needed for the avl construction. + +@<Declarations@>= +static int mp_compare_symbols_entry (void *p, const void *pa, const void *pb); +static void *mp_copy_symbols_entry (const void *p); +static void *mp_delete_symbols_entry (void *p); + +@ The avl comparison function is a straightword version of |strcmp|, +except that checks for the string lengths first. + +@c +static int mp_compare_symbols_entry (void *p, const void *pa, const void *pb) +{ + const mp_symbol_entry *a = (const mp_symbol_entry *) pa; + const mp_symbol_entry *b = (const mp_symbol_entry *) pb; + (void) p; + if (a->text->len != b->text->len) { + return (a->text->len > b->text->len ? 1 : -1); + } + return strncmp ((const char *) a->text->str, (const char *) b->text->str, a->text->len); +} + +@ Copying a symbol happens when an item is inserted into an AVL tree. The |text| +and |mp_number| needs to be deep copied, every thing else can be reassigned. + +@c +static void *mp_copy_symbols_entry (const void *p) +{ + // const mp_symbol_entry *fp = (const mp_symbol_entry *) p; + mp_symbol_entry *fp = (mp_symbol_entry *) p; + MP mp = (MP)fp->parent; + mp_sym ff = mp_memory_allocate(sizeof(mp_symbol_entry)); + if (ff == NULL) { + return NULL; + } + ff->text = mp_aux_copy_strings_entry(fp->text); + if (ff->text == NULL) { + return NULL; + } + ff->v = fp->v; + ff->type = fp->type; + ff->property = fp->property; + ff->parent = mp; + new_number_clone(ff->v.data.n, fp->v.data.n); + return ff; +} + +@ In the current implementation, symbols are not freed until the end of the run. + +@c +static void *mp_delete_symbols_entry (void *p) +{ + mp_sym ff = (mp_sym) p; + MP mp = (MP) ff->parent; + free_number(ff->v.data.n); + mp_memory_free(ff->text->str); + mp_memory_free(ff->text); + mp_memory_free(ff); + return NULL; +} + +@ @<Allocate or initialize ...@>= +mp->symbols = avl_create(mp_compare_symbols_entry, mp_copy_symbols_entry, mp_delete_symbols_entry, mp_memory_allocate, mp_memory_free, NULL); +mp->frozen_symbols = avl_create(mp_compare_symbols_entry, mp_copy_symbols_entry, mp_delete_symbols_entry, mp_memory_allocate, mp_memory_free, NULL); + +@ @<Dealloc variables@>= +if (mp->symbols != NULL) { + avl_destroy (mp->symbols); +} +if (mp->frozen_symbols != NULL) { + avl_destroy (mp->frozen_symbols); +} + +@ Actually creating symbols is done by |id_lookup|, but in order to do so it +needs a way to create a new, empty symbol structure. + +@<Declarations@>= +static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len); + +@ @c +static mp_sym new_symbols_entry (MP mp, unsigned char *nam, size_t len) +{ + mp_sym ff = mp_memory_clear_allocate(sizeof(mp_symbol_entry)); + ff->parent = mp; + ff->text = mp_memory_allocate(sizeof(mp_lstring)); + ff->text->str = nam; + ff->text->len = len; + ff->type = mp_tag_command; + ff->v.type = mp_known_type; + new_number(ff->v.data.n); + return ff; +} + +@ There is one global variable so that |id_lookup| does not always have to create +a new entry just for testing. This is not freed because it creates a double-free +thanks to the |NULL| init. + +@<Global ...@>= +mp_sym id_lookup_test; + +@ @<Initialize table entries@>= +mp->id_lookup_test = new_symbols_entry(mp, NULL, 0); + +@ Certain symbols are \quote {frozen} and not redefinable, since they are used in +error recovery. + +@<Initialize table entries@>= +mp->st_count = 0; +mp->frozen_bad_vardef = mp_frozen_primitive(mp, "a bad variable", mp_tag_command, 0); +mp->frozen_right_delimiter = mp_frozen_primitive(mp, ")", mp_right_delimiter_command, 0); +mp->frozen_inaccessible = mp_frozen_primitive(mp, " INACCESSIBLE", mp_tag_command, 0); +mp->frozen_undefined = mp_frozen_primitive(mp, " UNDEFINED", mp_tag_command, 0); + +@ Here is the subroutine that searches the avl tree for an identifier that +matches a given string of length~|l| appearing in |buffer[j.. (j+l-1)]|. If the +identifier is not found, it is inserted if |insert_new| is |true|, and the +corresponding symbol will be returned. + +There are two variations on the lookup function: one for the normal symbol table, +and one for the table of error recovery symbols. + +Note: simple symbols like |+|, |-|, |*| and |/| are also looked up. One can argue +that a user can redefine them but colons etc. are interpreted direct. Maybe +there's room for some optimization here. We could just put references (to +|mp_sym|) in the |mp| instance object for the handful. Okay, we also have |:=| so +maybe only for single character ones ... not worth the trouble. + +@d mp_id_lookup(A,B,C,D) mp_do_id_lookup((A), mp->symbols, (B), (C), (D)) + +@c +static mp_sym mp_do_id_lookup (MP mp, avl_tree symbols, char *j, size_t l, int insert_new) +{ + mp_sym str; + mp->id_lookup_test->text->str = (unsigned char *) j; + mp->id_lookup_test->text->len = l; + str = (mp_sym) avl_find(mp->id_lookup_test, symbols); + if (str == NULL && insert_new) { + unsigned char *nam = (unsigned char *) mp_strndup(j, l); + mp_sym s = new_symbols_entry(mp, nam, l); + mp->st_count++; + avl_ins(s, symbols, avl_false); + str = (mp_sym) avl_find(s, symbols); + mp_delete_symbols_entry(s); + } + return str; +} + +@ @<Exported function headers@>= +extern int mp_initialize_symbol_traverse (MP mp); +extern void mp_kill_symbol_traverse (MP mp); +extern void *mp_fetch_symbol_traverse (MP mp); +extern void *mp_fetch_symbol (MP mp, char *s); + +@ @c +int mp_initialize_symbol_traverse (MP mp) +{ + mp->symbol_iterator = avl_iterator_new(mp->symbols, AVL_ITERATOR_INI_PRE); + return (mp->symbol_iterator != NULL); +} + +void mp_kill_symbol_traverse (MP mp) +{ + avl_iterator_kill(mp->symbol_iterator); +} + +void *mp_fetch_symbol_traverse (MP mp) +{ + return avl_iterator_next(mp->symbol_iterator); +} + +void *mp_fetch_symbol (MP mp, char *s) +{ + return mp_id_lookup(mp, s, strlen(s), 0); +} + +@ We need to put \MP's \quote {primitive} symbolic tokens into the hash table, +together with their command code (which will be the |eq_type|) and an operand +(which will be the |equiv|). The |primitive| procedure does this, in a way that +no \MP\ user can. The global value |cur_sym| contains the new |eqtb| pointer +after |primitive| has acted. + +@c +static void mp_primitive (MP mp, const char *ss, int c, int o) +{ +// char *s = mp_strdup(ss); +// set_cur_sym(mp_id_lookup(mp, s, strlen(s), 1)); +// mp_memory_free(s); + set_cur_sym(mp_id_lookup(mp, (char *) ss, strlen(ss), 1)); + set_eq_type(cur_sym, c); + set_eq_property(cur_sym, 0x1); /* todo: enumeration values */ + set_equiv(cur_sym, o); +} + +@ Some other symbolic tokens only exist for error recovery. + +@c +static mp_sym mp_frozen_primitive (MP mp, const char *ss, int c, int o) +{ +// char *s = mp_strdup(ss); +// mp_sym str = mp_do_id_lookup(mp, mp->frozen_symbols, s, strlen(s), 1); +// mp_memory_free(s); + mp_sym str = mp_do_id_lookup(mp, mp->frozen_symbols, (char *) ss, strlen(ss), 1); + str->type = c; + str->property = 0x1; /* todo: enumeration values */ + str->v.data.indep.serial = o; + return str; +} + +@ This routine returns |true| if the argument is an un-redefinable symbol because +it is one of the error recovery tokens (as explained elsewhere, +|frozen_inaccessible| actuall is redefinable). + +@c +static int mp_is_frozen (MP mp, mp_sym sym) +{ + mp_sym temp = mp_do_id_lookup(mp, mp->frozen_symbols, (char *) sym->text->str, sym->text->len, 0); + if (temp == mp->frozen_inaccessible) { + return 0; + } else { + return (temp == sym); + } +} + +@ Many of \MP's primitives need no |equiv|, since they are identifiable by their +|eq_type| alone. These primitives are loaded into the hash table as follows: + +@<Put each of \MP's primitives into the hash table@>= +mp_primitive(mp, "..", mp_path_join_command, 0); +@:.._}{|..| primitive@> +mp_primitive(mp, "[", mp_left_bracket_command, 0); +mp->frozen_left_bracket = mp_frozen_primitive (mp, "[", mp_left_bracket_command, 0); +@:[ }{|[| primitive@> +mp_primitive(mp, "]", mp_right_bracket_command, 0); +@:] }{|]| primitive@> +mp_primitive(mp, "}", mp_right_brace_command, 0); +@:]]}{|\char`\|} primitive@> +mp_primitive(mp, "{", mp_left_brace_command, 0); +@:][}{|\char`\{| primitive@> +mp_primitive(mp, ":", mp_colon_command, 0); +mp->frozen_colon = mp_frozen_primitive (mp, ":", mp_colon_command, 0); +@:: }{|:| primitive@> +mp_primitive(mp, ":=", mp_assignment_command, 0); +@::=_}{|:=| primitive@> +mp_primitive(mp, ",", mp_comma_command, 0); +@:, }{\., primitive@> +mp_primitive(mp, ";", mp_semicolon_command, 0); +mp->frozen_semicolon = mp_frozen_primitive (mp, ";", mp_semicolon_command, 0); +@:; }{\.; primitive@> +mp_primitive(mp, "\\", mp_relax_command, 0); +@:]]\||\char`\\| primitive@> +mp_primitive(mp, "addto", mp_add_to_command, 0); +@:add_to_|{|addto| primitive@> +mp_primitive(mp, "atleast", mp_at_least_command, 0); +@:at_least_}{|atleast| primitive@> +mp_primitive(mp, "begingroup", mp_begin_group_command, 0); +mp->bg_loc = cur_sym; +@:begin_group_}{|begingroup| primitive@> +mp_primitive(mp, "controls", mp_controls_command, 0); +@:controls_}{|controls| primitive@> +mp_primitive(mp, "curl", mp_curl_command, 0); +@:curl_}{|curl| primitive@> +mp_primitive(mp, "delimiters", mp_delimiters_command, 0); +@:delimiters_}{|delimiters| primitive@> +mp_primitive(mp, "endgroup", mp_end_group_command, 0); + +mp->eg_loc = cur_sym; +mp->frozen_end_group = mp_frozen_primitive (mp, "endgroup", mp_end_group_command, 0); + +@:endgroup_}{|endgroup| primitive@> +mp_primitive(mp, "everyjob", mp_every_job_command, 0); +@:every_job_}{|everyjob| primitive@> +mp_primitive(mp, "exitif", mp_exit_test_command, 0); +@:exit_if_}{|exitif| primitive@> +mp_primitive(mp, "expandafter", mp_expand_after_command, 0); +@:expand_after_}{|expandafter| primitive@> +mp_primitive(mp, "interim", mp_interim_command, 0); +@:interim_}{|interim| primitive@> +mp_primitive(mp, "let", mp_let_command, 0); +@:let_}{|let| primitive@> +mp_primitive(mp, "newinternal", mp_new_internal_command, 0); +@:new_internal_}{|newinternal| primitive@> +mp_primitive(mp, "of", mp_of_command, 0); +@:of_}{|of| primitive@> +mp_primitive(mp, "randomseed", mp_only_set_command, mp_random_seed_code); +@:mp_random_seed_}{|randomseed| primitive@> +mp_primitive(mp, "maxknotpool", mp_only_set_command, mp_max_knot_pool_code); +@:mp_max_knot_pool_}{|maxknotpool| primitive@> +mp_primitive(mp, "save", mp_save_command, 0); +@:save_}{|save| primitive@> +mp_primitive(mp, "scantokens", mp_scan_tokens_command, 0); +@:scan_tokens_}{|scantokens| primitive@> +mp_primitive(mp, "runscript", mp_runscript_command, 0); +@:run_script_}{|runscript| primitive@> +mp_primitive(mp, "maketext", mp_maketext_command, 0); +@:make_text_}{|maketext| primitive@> +mp_primitive(mp, "shipout", mp_ship_out_command, 0); +@:ship_out_}{|shipout| primitive@> +mp_primitive(mp, "step", mp_step_command, 0); +@:step_}{|step| primitive@> +mp_primitive(mp, "str", mp_str_command, 0); +@:str_}{|str| primitive@> +mp_primitive(mp, "void", mp_void_command, 0); +@:void_}{|void| primitive@> +mp_primitive(mp, "tension", mp_tension_command, 0); +@:tension_}{|tension| primitive@> +mp_primitive(mp, "to", mp_to_command, 0); +@:to_}{|to| primitive@> +mp_primitive(mp, "until", mp_until_command, 0); +@:until_}{|until| primitive@> +mp_primitive(mp, "within", mp_within_command, 0); +@:within_}{|within| primitive@> +mp_primitive(mp, "write", mp_write_command, 0); +@:write_}{|write| primitive@> + +@ Each primitive has a corresponding inverse, so that it is possible to display +the cryptic numeric contents of |eqtb| in symbolic form. Every call of +|primitive| in this program is therefore accompanied by some straightforward code +that forms part of the |print_cmd_mod| routine explained below. + +@<Cases of |print_cmd_mod| for symbolic printing of primitives@>= +case mp_add_to_command: return "addto"; +case mp_assignment_command: return ":="; +case mp_at_least_command: return "atleast"; +case mp_begin_group_command: return "begingroup"; +case mp_colon_command: return ":"; +case mp_comma_command: return ","; +case mp_controls_command: return "controls"; +case mp_curl_command: return "curl"; +case mp_delimiters_command: return "delimiters"; +case mp_end_group_command: return "endgroup"; +case mp_every_job_command: return "everyjob"; +case mp_exit_test_command: return "exitif"; +case mp_expand_after_command: return "expandafter"; +case mp_interim_command: return "interim"; +case mp_left_brace_command: return "{"; +case mp_left_bracket_command: return "["; +case mp_let_command: return "let"; +case mp_new_internal_command: return "newinternal"; +case mp_of_command: return "of"; +case mp_path_join_command: return ".."; +case mp_relax_command: return "\\"; +case mp_right_brace_command: return "}"; +case mp_right_bracket_command: return "]"; +case mp_save_command: return "save"; +case mp_scan_tokens_command: return "scantokens"; +case mp_runscript_command: return "runscript"; +case mp_maketext_command: return "maketext"; +case mp_semicolon_command: return ";"; +case mp_ship_out_command: return "shipout"; +case mp_step_command: return "step"; +case mp_str_command: return "str"; +case mp_void_command: return "void"; +case mp_tension_command: return "tension"; +case mp_to_command: return "to"; +case mp_until_command: return "until"; +case mp_within_command: return "within"; +case mp_write_command: return "write"; + +@ We will deal with the other primitives later, at some point in the program +where their |eq_type| and |equiv| values are more meaningful. For example, the +primitives for macro definitions will be loaded when we consider the routines +that define macros. It is easy to find where each particular primitive was +treated by looking in the index at the end; for example, the section where +|"def"| entered |eqtb| is listed under `|def| primitive'. + +@* Token lists. + +A \MP\ token is either symbolic or numeric or a string, or it denotes a macro +parameter or capsule or an internal; so there are six corresponding ways to +encode it internally: @^token@> + +(1)~A symbolic token for symbol |p| is represented by the pointer |p|, in the +|sym_sym| field of a symbolic node in~|mem|. The |type| field is |symbol_node|; +and it has a |name_type| to differentiate various subtypes of symbolic tokens, +which is usually |normal_sym|, but |macro_sym| for macro names. + +(2)~A numeric token whose |scaled| value is~|v| is represented in a non-symbolic +node of~|mem|; the |type| field is |known|, the |name_type| field is |token|, and +the |value| field holds~|v|. + +(3)~A string token is also represented in a non-symbolic node; the |type| field +is |mp_string_type|, the |name_type| field is |token|, and the |value| field +holds the corresponding |mp_string|. + +(4)~Capsules have |name_type=capsule|, and their |type| and |value| fields +represent arbitrary values, with |type| different from |symbol_node| (in ways to +be explained later). + +(5)~Macro parameters appear in |sym_info| fields of symbolic nodes. The |type| +field is |symbol_node|; the $k$th parameter is represented by |k| in |sym_info|; +and |expr_sym| in |name_type|, if it is of type |expr|, or |suffix_sym| if it +is of type |suffix|, or by |text_sym| if it is of type |text|. + +(6)~The $k$th internal is also represented by |k| in |sym_info|; the |type| field +is |symbol_node| as for the other symbolic tokens; and |internal_sym| is its +|name_type|; + +Actual values of the parameters and internals are kept in a separate stack, as we +will see later. + +Note that the |type| field of a node has nothing to do with \quote {type} in a +printer's sense. It's curious that the same word is used in such different ways. + +@d mp_set_value_sym(A,B) do_set_value_sym (mp, (mp_token_node) (A), (B)) +@d mp_set_value_number(A,B) do_set_value_number(mp, (mp_token_node) (A), &(B)) +@d mp_set_value_node(A,B) do_set_value_node (mp, (mp_token_node) (A), (B)) +@d mp_set_value_str(A,B) do_set_value_str (mp, (mp_token_node) (A), (B)) +@d mp_set_value_knot(A,B) do_set_value_knot (mp, (mp_token_node) (A), (B)) + +@<MPlib internal header stuff@>= +typedef struct mp_node_data *mp_token_node; + +@ @c +# define mp_get_value_sym(A) ((mp_token_node) (A))->data.sym +# define mp_get_value_number(A) ((mp_token_node) (A))->data.n +# define mp_get_value_node(A) ((mp_token_node) (A))->data.node +# define mp_get_value_str(A) ((mp_token_node) (A))->data.str +# define mp_get_value_knot(A) ((mp_token_node) (A))->data.p + +inline static void do_set_value_sym (MP mp, mp_token_node A, mp_sym B) +{ + (void) mp; + A->data.sym=(B); +} + +inline static void do_set_value_number (MP mp, mp_token_node A, mp_number *B) +{ + (void) mp; + A->data.p = NULL; + A->data.str = NULL; + A->data.node = NULL; + number_clone(A->data.n, *B); +} + +inline static void do_set_value_str (MP mp, mp_token_node A, mp_string B) +{ + (void) mp; + A->data.p = NULL; + A->data.str = (B); + add_str_ref((B)); + A->data.node = NULL; + number_clone(A->data.n, zero_t); +} + +inline static void do_set_value_node (MP mp, mp_token_node A, mp_node B) +{ + (void) mp; + /* store the value in a large token node */ + A->data.p = NULL; + A->data.str = NULL; + A->data.node = B; + number_clone(A->data.n, zero_t); +} + +inline static void do_set_value_knot (MP mp, mp_token_node A, mp_knot B) +{ + (void) mp; + A->data.p = (B); + A->data.str = NULL; + A->data.node = NULL; + number_clone(A->data.n, zero_t); +} + +@ @<Declarations@>= +inline static void do_set_value_sym (MP mp, mp_token_node A, mp_sym B); +inline static void do_set_value_number (MP mp, mp_token_node A, mp_number *B); +inline static void do_set_value_str (MP mp, mp_token_node A, mp_string B); +inline static void do_set_value_node (MP mp, mp_token_node A, mp_node B); +inline static void do_set_value_knot (MP mp, mp_token_node A, mp_knot B); + +@ @c +static mp_node mp_new_token_node (MP mp) +{ + mp_node p; + if (mp->token_nodes) { + p = mp->token_nodes; + mp->token_nodes = p->link; + mp->num_token_nodes--; + p->link = NULL; + } else { + p = mp_allocate_node(mp, sizeof(mp_node_data)); + new_number(p->data.n); + p->hasnumber = 1; + } + p->type = mp_token_node_type; + return (mp_node) p; +} + +@ @c +static void mp_free_token_node (MP mp, mp_node p) +{ + if (p) { + if (mp->num_token_nodes < max_num_token_nodes) { + p->link = mp->token_nodes; + mp->token_nodes = p; + mp->num_token_nodes++; + } else { + mp->var_used -= sizeof(mp_node_data); + if (mp->math_mode > mp_math_double_mode) { + free_number(((mp_value_node) p)->data.n); + } + mp_memory_free(p); + } + } +} + +@ @<Declarations@>= +static void mp_free_token_node (MP mp, mp_node p); + +@ A numeric token is created by the following trivial routine. + +@c +static mp_node mp_new_num_tok (MP mp, mp_number *v) +{ + mp_node p = mp_new_token_node(mp); + mp_set_value_number(p, *v); + p->type = mp_known_type; + p->name_type = mp_token_operation; + return p; +} + +@ @<Declarations@>= +static void mp_flush_token_list (MP mp, mp_node p); + +@ A token list is a singly linked list of nodes in |mem|, where each node +contains a token and a link. Here's a subroutine that gets rid of a token list +when it is no longer needed. + +@c +static void mp_flush_token_list (MP mp, mp_node p) +{ + while (p != NULL) { + mp_node q = p; /* the node being recycled */ + p = mp_link(p); + switch (mp_type(q)) { + case mp_symbol_node_type: + mp_free_symbolic_node(mp, q); + continue; + case mp_vacuous_type: + case mp_boolean_type: + case mp_known_type: + break; + case mp_string_type: + delete_str_ref(mp_get_value_str(q)); + break; + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + case mp_pen_type: + case mp_nep_type: + case mp_path_type: + case mp_picture_type: + case mp_pair_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_transform_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + mp_recycle_value(mp, q); + break; + default: + mp_confusion(mp, "token"); + @:this can't happen token}{\quad token@> + } + mp_free_token_node(mp, q); + } +} + +@ The procedure |show_token_list|, which prints a symbolic form of the token list +that starts at a given node |p|, illustrates these conventions. The token list +being displayed should not begin with a reference count. + +An additional parameter |q| is also given; this parameter is either NULL or it +points to a node in the token list where a certain magic computation takes place +that will be explained later. (Basically, |q| is non-NULL when we are printing +the two-line context information at the time of an error message; |q| marks the +place corresponding to where the second line should begin.) + +@^recursion@> + +Unusual entries are printed in the form of all-caps tokens preceded by a space, +e.g., |\char`\ BAD|. + +@<Declarations@>= +static void mp_show_token_list (MP mp, mp_node p, mp_node q); +static void mp_show_token_list_space (MP mp, mp_node p, mp_node q); + +@ We go for a spacy layout because we have more screen estate today. +@c + +void mp_show_token_list (MP mp, mp_node p, mp_node q) +{ + int cclass = mp_percent_class; + (void) q; + while (p != NULL) { + int c = mp_letter_class; + if (mp_type(p) != mp_symbol_node_type) { + if (mp_name_type(p) == mp_token_operation) { + if (mp_type(p) == mp_known_type) { + if (cclass == mp_digit_class) { + mp_print_chr(mp, ' '); + } + if (number_negative(mp_get_value_number(p))) { + if (cclass == mp_left_bracket_class) { + mp_print_chr(mp, ' '); + } + mp_print_chr(mp, '['); + print_number(mp_get_value_number(p)); + mp_print_chr(mp, ']'); + c = mp_right_bracket_class; + } else { + print_number(mp_get_value_number(p)); + c = mp_digit_class; + } + } else if (mp_type(p) == mp_string_type) { + mp_print_chr(mp, '"'); + mp_print_mp_str(mp, mp_get_value_str(p)); + mp_print_chr(mp, '"'); + c = mp_string_class; + } else { + mp_print_str(mp, " BAD"); + } + } else if ((mp_name_type(p) != mp_capsule_operation) || (mp_type(p) < mp_vacuous_type) || (mp_type(p) > mp_independent_type)) { + mp_print_str(mp, " BAD"); + } else { + mp_print_capsule(mp, p); + c = mp_right_parenthesis_class; + } + } else if (mp_name_type(p) == mp_expr_operation || mp_name_type(p) == mp_suffix_operation || mp_name_type(p) == mp_text_operation) { + int r = mp_get_sym_info(p); + if (mp_name_type(p) == mp_expr_operation) { + mp_print_str(mp, "(EXPR"); + } else if (mp_name_type(p) == mp_suffix_operation) { + mp_print_str(mp, "(SUFFIX"); + } else { + mp_print_str(mp, "(TEXT"); + } + mp_print_int(mp, r); + mp_print_chr(mp, ')'); + c = mp_right_parenthesis_class; + } else { + mp_sym sr = mp_get_sym_sym(p); + if (sr == mp_collective_subscript) { + if (cclass == mp_left_bracket_class) { + mp_print_chr(mp, ' '); + } + mp_print_str(mp, "[]"); + c = mp_right_bracket_class; + } else { + mp_string rr = text(sr); + if (rr == NULL || rr->str == NULL) { + mp_print_str(mp, " NONEXISTENT"); + } else { + c = mp->char_class[(rr->str[0])]; + if (c == cclass) { + switch (c) { + case mp_letter_class: + mp_print_chr(mp, '.'); + break; + case mp_comma_class: + case mp_semicolon_class: + case mp_left_parenthesis_class: + case mp_right_parenthesis_class: + break; + default: + mp_print_chr(mp, ' '); + break; + } + } + mp_print_mp_str(mp, rr); + } + } + } + cclass = c; + p = mp_link(p); + } + return; +} + +void mp_show_token_list_space (MP mp, mp_node p, mp_node q) +{ + (void) q; + while (p != NULL) { + if (mp_type(p) != mp_symbol_node_type) { + if (mp_name_type(p) == mp_token_operation) { + if (mp_type(p) == mp_known_type) { + if (number_negative(mp_get_value_number(p))) { + mp_print_str(mp, "[ "); + print_number(mp_get_value_number(p)); + mp_print_str(mp, " ]"); + } else { + print_number(mp_get_value_number(p)); + } + } else if (mp_type(p) == mp_string_type) { + mp_print_chr(mp, '"'); + mp_print_mp_str(mp, mp_get_value_str(p)); + mp_print_chr(mp, '"'); + } else { + mp_print_str(mp, "BAD"); + } + } else if ((mp_name_type(p) != mp_capsule_operation) || (mp_type(p) < mp_vacuous_type) || (mp_type(p) > mp_independent_type)) { + mp_print_str(mp, "BAD"); + } else { + mp_print_capsule(mp, p); + } + } else if (mp_name_type(p) == mp_expr_operation || mp_name_type(p) == mp_suffix_operation || mp_name_type(p) == mp_text_operation) { + int r = mp_get_sym_info(p); + if (mp_name_type(p) == mp_expr_operation) { + mp_print_str(mp, "(EXPR "); + } else if (mp_name_type(p) == mp_suffix_operation) { + mp_print_str(mp, "(SUFFIX "); + } else { + mp_print_str(mp, "(TEXT "); + } + mp_print_int(mp, r); + mp_print_chr(mp, ')'); + } else { + mp_sym sr = mp_get_sym_sym(p); + if (sr == mp_collective_subscript) { + mp_print_str(mp, "[]"); + } else { + mp_string rr = text(sr); + if (rr == NULL || rr->str == NULL) { + mp_print_str(mp, "NONEXISTENT"); + } else { + mp_print_mp_str(mp, rr); + } + } + } + p = mp_link(p); + if (p) { + mp_print_chr(mp, ' '); + } + } + return; +} + +@ @<Declarations@>= +static void mp_print_capsule (MP mp, mp_node p); + +@ @<Declare miscellaneous procedures that were declared |forward|@>= +void mp_print_capsule (MP mp, mp_node p) +{ + mp_print_chr(mp, '('); + mp_print_exp(mp, p, 0); + mp_print_chr(mp, ')'); +} + +@ Macro definitions are kept in \MP's memory in the form of token lists that have +a few extra symbolic nodes at the beginning. + +The first node contains a reference count that is used to tell when the list is +no longer needed. To emphasize the fact that a reference count is present, we +shall refer to the |sym_info| field of this special node as the |ref_count| +field. @^reference counts@> + +The next node or nodes after the reference count serve to describe the formal +parameters. They consist of zero or more parameter tokens followed by a code for +the type of macro. + +/* reference count preceding a macro definition or picture header */ + +@d mp_get_ref_count(A) mp_get_indep_value(A) +@d mp_set_ref_count(A,B) mp_set_indep_value(A,B) +@d mp_add_mac_ref(A) mp_set_ref_count((A), mp_get_ref_count((A))+1) /* make a new reference to a macro list */ +@d mp_decr_mac_ref(A) mp_set_ref_count((A), mp_get_ref_count((A))-1) /* remove a reference to a macro list */ + +@<Types...@>= +typedef enum mp_macro_info { + mp_general_macro, /* preface to a macro defined with a parameter list */ + mp_primary_macro, /* preface to a macro with a |primary| parameter */ + mp_secondary_macro, /* preface to a macro with a |secondary| parameter */ + mp_tertiary_macro, /* preface to a macro with a |tertiary| parameter */ + mp_expr_macro, /* preface to a macro with an undelimited |expr| parameter */ + mp_of_macro, /* preface to a macro with undelimited `|expr| |x| |of|~|y|' parameters */ + mp_suffix_macro, /* preface to a macro with an undelimited |suffix| parameter */ + mp_text_macro, /* preface to a macro with an undelimited |text| parameter */ + mp_expr_parameter, /* used by |expr| primitive */ + mp_suffix_parameter, /* used by |suffix| primitive */ + mp_text_parameter /* used by |text| primitive */ +} mp_macro_info; + +@ @c +static void mp_delete_mac_ref (MP mp, mp_node p) +{ + /* |p| points to the reference count of a macro list that is losing one reference */ + if (mp_get_ref_count(p) == 0) { + mp_flush_token_list(mp, p); + } else { + mp_decr_mac_ref(p); + } +} + +@ The following subroutine displays a macro, given a pointer to its reference +count. + +@c +static void mp_show_macro (MP mp, mp_node p, mp_node q) +{ + p = mp_link(p); /* bypass the reference count */ + while (mp_name_type(p) != mp_macro_operation) { + mp_node r = mp_link(p); + mp_link(p) = NULL; + mp_show_token_list(mp, p, NULL); + mp_link(p) = r; + p = r; + } + switch (mp_get_sym_info(p)) { + case mp_general_macro: + mp_print_str(mp, "-> "); + break; + @.->@> + case mp_primary_macro: + case mp_secondary_macro: + case mp_tertiary_macro: + mp_print_str(mp, "<"); + mp_print_cmd_mod(mp, mp_parameter_commmand, mp_get_sym_info(p)); + mp_print_str(mp, "> -> "); + break; + case mp_expr_macro: + mp_print_str(mp, "<expr> -> "); + break; + case mp_of_macro: + mp_print_str(mp, "<expr> of <primary> -> "); + break; + case mp_suffix_macro: + mp_print_str(mp, "<suffix> -> "); + break; + case mp_text_macro: + mp_print_str(mp, "<text> -> "); + break; + } + mp_show_token_list(mp, mp_link(p), q); +} + +@* Data structures for variables. + +The variables of \MP\ programs can be simple, like |x|, or they can combine the +structural property of arrays and records, like |x20a.b|. A \MP\ user assigns a +type to a variable like |x20a.b| by saying, for example, `|boolean| |x[]a.b|'. +It's time for us to study how such things are represented inside of the computer. + +Each variable value occupies two consecutive words, either in a non-symbolic node +called a value node, or as a non-symbolic subfield of a larger node. One of those +two words is called the |value| field; it is an integer, containing either a +|scaled| numeric value or the representation of some other type of quantity. (It +might also be subdivided into halfwords, in which case it is referred to by other +names instead of |value|.) The other word is broken into subfields called |type|, +|name_type|, and |link|. The |type| field is a quarterword that specifies the +variable's type, and |name_type| is a quarterword from which \MP\ can reconstruct +the variable's name (sometimes by using the |link| field as well). Thus, only +1.25 words are actually devoted to the value itself; the other three-quarters of +a word are overhead, but they aren't wasted because they allow \MP\ to deal with +sparse arrays and to provide meaningful diagnostics. + +In this section we shall be concerned only with the structural aspects of +variables, not their values. Later parts of the program will change the |type| +and |value| fields, but we shall treat those fields as black boxes whose contents +should not be touched. + +However, if the |type| field is |mp_structured|, there is no |value| field, and +the second word is broken into two pointer fields called |attr_head| and +|subscr_head|. Those fields point to additional nodes that contain structural +information, as we shall see. + +TH Note: DEK and JDH had a nice theoretical split between |value|, |attr| and +|subscr| nodes, as documented above and further below. However, all three types +had a bad habit of transmuting into each other in practice while pointers to them +still lived on elsewhere, so using three different C structures is simply not +workable. All three are now represented as a single C structure called +|mp_value_node|. + +There is a potential union in this structure in the interest of space saving: +|subscript| and |hashloc| are mutually exclusive. + +Actually, so are |attr_head| + |subscr_head| on one side and and |value_| on the +other, but because of all the access macros that are used in the code base to get +at values, those cannot be folded into a union (yet); this would have required +creating a similar union in |mp_token_node| where it would only serve to confuse +things. + +Finally, |parent| only applies in |attr| nodes (the ones that have |hashloc|), +but creating an extra substructure inside the union just for that does not save +space and the extra complication in the structure is not worth the minimal extra +code clarification. + +@d mp_get_attribute_head(A) mp_do_get_attribute_head(mp, (mp_value_node) (A)) +@d mp_set_attribute_head(A,B) mp_do_set_attribute_head(mp, (mp_value_node) (A),(mp_node) (B)) + +@d mp_get_subscr_head(A) mp_do_get_subscr_head(mp,(mp_value_node) (A)) +@d mp_set_subscr_head(A,B) mp_do_set_subscr_head(mp,(mp_value_node) (A),(mp_node) (B)) + +@<MPlib internal header stuff@>= +typedef struct mp_value_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_value_data data; + mp_number subscript; + mp_sym hashloc_; + mp_node parent; + mp_node attr_head; + mp_node subscr_head; +} mp_value_node_data; + +@ @c +static mp_node mp_do_get_attribute_head (MP mp, mp_value_node A) +{ + (void) mp; + return A->attr_head; +} + +static mp_node mp_do_get_subscr_head (MP mp, mp_value_node A) +{ + return A->subscr_head; + (void) mp; +} + +static void mp_do_set_attribute_head (MP mp, mp_value_node A, mp_node d) +{ + (void) mp; + A->attr_head = d; +} + +static void mp_do_set_subscr_head (MP mp, mp_value_node A, mp_node d) +{ + (void) mp; + A->subscr_head = d; +} + +@ @<Declarations@>= +static mp_node mp_do_get_subscr_head (MP mp, mp_value_node A); +static mp_node mp_do_get_attribute_head (MP mp, mp_value_node A); +static void mp_do_set_attribute_head (MP mp, mp_value_node A, mp_node d); +static void mp_do_set_subscr_head (MP mp, mp_value_node A, mp_node d); + +@ It would have been nicer to make |mp_new_value_node| return |mp_value_node| +variables, but with |eqtb| as it stands that became messy: lots of typecasts. So, +it returns a simple |mp_node| for now. + +@c +static mp_node mp_new_value_node (MP mp) +{ + mp_value_node p; + if (mp->value_nodes) { + p = (mp_value_node) mp->value_nodes; + mp->value_nodes = p->link; + mp->num_value_nodes--; + p->link = NULL; + } else { + p = mp_allocate_node(mp, sizeof(mp_value_node_data)); + new_number(p->data.n); + new_number(p->subscript); + p->hasnumber = 2; + } + mp_type(p) = mp_value_node_type; + return (mp_node) p; +} + +@ @<Declarations@>= +static mp_node mp_new_value_node (MP mp); + +@ An attribute node is three words long. Two of these words contain |type| and +|value| fields as described above, and the third word contains additional +information: There is an |hashloc| field, which contains the hash address of the +token that names this attribute; and there's also a |parent| field, which points +to the value node of |mp_structured| type at the next higher level (i.e., at the +level to which this attribute is subsidiary). The |name_type| in an attribute +node is |attr|. The |link| field points to the next attribute with the same +parent; these are arranged in increasing order, so that |mp_get_hashloc +(mp_link(p)) > mp_get_hashloc (p)|. The final attribute node links to the +constant |end_attr|, whose |hashloc| field is greater than any legal hash +address. The |attr_head| in the parent points to a node whose |name_type| is +|mp_structured_root_operation|; this node represents the NULL attribute, i.e., +the variable that is relevant when no attributes are attached to the parent. The +|attr_head| node has the fields of either a value node, a subscript node, or an +attribute node, depending on what the parent would be if it were not structured; +but the subscript and attribute fields are ignored, so it effectively contains +only the data of a value node. The |link| field in this special node points to an +attribute node whose |hashloc| field is zero; the latter node represents a +collective subscript |[]| attached to the parent, and its |link| field points to +the first non-special attribute node (or to |end_attr| if there are none). + +A subscript node likewise occupies three words, with |type| and |value| fields +plus extra information; its |name_type| is |subscr|. In this case the third word +is called the |subscript| field, which is a |scaled| integer. The |link| field +points to the subscript node with the next larger subscript, if any; otherwise +the |link| points to the attribute node for collective subscripts at this level. +We have seen that the latter node contains an upward pointer, so that the parent +can be deduced. + +The |name_type| in a parent-less value node is |root|, and the |link| is the hash +address of the token that names this value. + +In other words, variables have a hierarchical structure that includes enough +threads running around so that the program is able to move easily between +siblings, parents, and children. An example should be helpful: (The reader is +advised to draw a picture while reading the following description, since that +will help to firm up the ideas.) Suppose that |x| and |x.a| and |x[]b| and |x5| +and |x20b| have been mentioned in a user's program, where |x[]b| has been +declared to be of |boolean| type. Let |h(x)|, |h(a)|, and |h(b)| be the hash +addresses of \.x, \.a, and~\.b. Then |eq_type(h(x)) = name| and |equiv(h(x)) = +p|, where |p|~is a non-symbolic value node with |mp_name_type(p) = root| and +|mp_link(p)=h(x)|. We have |type(p) = mp_structured|, |mp_get_attribute_head(p) = +q|, and |mp_get_subscr_head(p) = r|, where |q| points to a value node and |r| to +a subscript node. (Are you still following this? Use a pencil to draw a diagram.) +The lone variable |x| is represented by |type(q)| and |value(q)|; furthermore +|mp_name_type(q) = mp_structured_root_operation| and |mp_link(q) = q1|, where +|q1| points to an attribute node representing |x[]|. Thus |mp_name_type(q1) = +attr|, |mp_get_hashloc(q1) = mp_collective_subscript = 0|, |mp_get_parent(q1) = +p|, |type(q1) = mp_structured|, |mp_get_attribute_head(q1) = qq|, and +|mp_get_subscr_head(q1) = qq1|; |qq| is a three-word \quote {attribute-as-value} +node with |type(qq) = numeric_type| (assuming that |x5| is numeric, because |qq| +represents |x[]| with no further attributes), |mp_name_type(qq) = +structured_root|, |mp_get_hashloc(qq)=0|, |mp_get_parent(qq) = p|, and +|mp_link(qq) = qq1|. (Now pay attention to the next part.) Node |qq1| is an +attribute node representing |x[][]|, which has never yet occurred; its |type| +field is |undefined|, and its |value| field is undefined. We have +|mp_name_type(qq1) = attr|, |mp_get_hashloc(qq1)=mp_collective_subscript|, +|mp_get_parent(qq1) = q1|, and |mp_link(qq1) = qq2|. Since |qq2| represents +|x[]b|, |type(qq2) = mp_unknown_boolean|; also |mp_get_hashloc(qq2) = h(b)|, +|mp_get_parent(qq2) = q1|, |mp_name_type(qq2) = attr|, |mp_link(qq2) = end_attr|. +(Maybe colored lines will help untangle your picture.) Node |r| is a subscript +node with |type| and |value| representing |x5|; |mp_name_type(r) = subscr|, +|subscript(r) = 5.0|, and |mp_link(r) = r1| is another subscript node. To +complete the picture, see if you can guess what |mp_link(r1)| is; give up? +It's~|q1|. Furthermore |subscript(r1) = 20.0|, |mp_name_type(r1) = subscr|, +|type(r1)=mp_structured|, |mp_get_attribute_head(r1) = qqq|, +|mp_get_subscr_head(r1) = qqq1|, and we finish things off with three more nodes +|qqq|, |qqq1|, and |qqq2| hung onto~|r1|. (Perhaps you should start again with a +larger sheet of paper.) The value of variable |x20b| appears in node~|qqq2|, as +you can well imagine. + +If the example in the previous paragraph doesn't make things crystal clear, a +glance at some of the simpler subroutines below will reveal how things work out +in practice. + +The only really unusual thing about these conventions is the use of collective +subscript attributes. The idea is to avoid repeating a lot of type information +when many elements of an array are identical macros (for which distinct values +need not be stored) or when they don't have all of the possible attributes. +Branches of the structure below collective subscript attributes do not carry +actual values except for macro identifiers; branches of the structure below +subscript nodes do not carry significant information in their collective +subscript attributes. + +@c +# define mp_get_hashloc(A) ((mp_value_node)(A))->hashloc_ +# define mp_set_hashloc(A,B) ((mp_value_node)(A))->hashloc_ = B +# define mp_get_parent(A) ((mp_value_node)(A))->parent +# define mp_set_parent(A,B) ((mp_value_node)(A))->parent = B + +@ @c +static mp_value_node mp_get_attribute_node (MP mp) +{ + mp_value_node p = (mp_value_node) mp_new_value_node(mp); + mp_type(p) = mp_attribute_node_type; + return p; +} + +@ Setting the |hashloc| field of |end_attr| to a value greater than any legal +hash address is done by assigning $-1$ typecasted to |mp_sym|, hopefully +resulting in all bits being set. On systems that support negative pointer values +or where typecasting $-1$ does not result in all bits in a pointer being set, +something else needs to be done. @^system dependencies@> + +@<Initialize table...@>= +mp->end_attr = (mp_node) mp_get_attribute_node(mp); +mp_set_hashloc(mp->end_attr, (mp_sym)-1); +mp_set_parent((mp_value_node) mp->end_attr, NULL); + +@ @<Free table...@>= +mp_free_value_node(mp, mp->end_attr); + +@d mp_collective_subscript (void *)0 /* code for the attribute |[]| */ +@d mp_subscript(A) ((mp_value_node)(A))->subscript + +@ @c +static mp_value_node mp_get_subscr_node (MP mp) +{ + mp_value_node p = (mp_value_node) mp_new_value_node(mp); + mp_type(p) = mp_subscript_node_type; + return p; +} + +@ Variables of type |pair| will have values that point to four-word nodes +containing two numeric values. The first of these values has |name_type = +mp_x_part_operation| and the second has |name_type = mp_y_part_operation|; the +|link| in the first points back to the node whose |value| points to this +four-word node. + +@d mp_x_part(A) ((mp_pair_node) (A))->x_part /* where the |xpart| is found in a pair node */ +@d mp_y_part(A) ((mp_pair_node) (A))->y_part /* where the |ypart| is found in a pair node */ + +@<MPlib internal header stuff@>= +typedef struct mp_pair_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_node x_part; + mp_node y_part; +} mp_pair_node_data; + +typedef struct mp_pair_node_data *mp_pair_node; + +@ @c +static mp_node mp_get_pair_node (MP mp) +{ + mp_node p; + if (mp->pair_nodes) { + p = mp->pair_nodes; + mp->pair_nodes = p->link; + mp->num_pair_nodes--; + p->link = NULL; + } else { + p = mp_allocate_node(mp, sizeof(mp_pair_node_data)); + } + mp_type(p) = mp_pair_node_type; + return (mp_node) p; +} + +@ @c +static void mp_free_pair_node (MP mp, mp_node p) +{ + if (p) { + if (mp->num_pair_nodes < max_num_pair_nodes) { + p->link = mp->pair_nodes; + mp->pair_nodes = p; + mp->num_pair_nodes++; + } else { + mp->var_used -= sizeof(mp_pair_node_data); + mp_memory_free(p); + } + } +} + +@ If |type(p) = mp_pair_type| or if |value(p) = NULL|, the procedure call +|init_pair_node(p)| will allocate a pair node for~|p|. The individual parts of +such nodes are initially of type |mp_independent|. + +@c +static void mp_init_pair_node (MP mp, mp_node p) +{ + mp_node q; /* the new node */ + mp_type(p) = mp_pair_type; + q = mp_get_pair_node(mp); + mp_y_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_y_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_y_part(q)) = mp_y_part_operation; + mp_link(mp_y_part(q)) = p; + mp_x_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_x_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_x_part(q)) = mp_x_part_operation; + mp_link(mp_x_part(q)) = p; + mp_set_value_node(p, q); +} + +@ Variables of type |transform| are similar, but in this case their |value| +points to a 12-word node containing six values, identified by |x_part_operation|, +|y_part_operation|, |mp_xx_part_operation|, |mp_xy_part_operation|, +|mp_yx_part_operation|, and |mp_yy_part_operation|. + +@d mp_tx_part(A) ((mp_transform_node) (A))->tx_part /* where the |xpart| is found in a transform node */ +@d mp_ty_part(A) ((mp_transform_node) (A))->ty_part /* where the |ypart| is found in a transform node */ +@d mp_xx_part(A) ((mp_transform_node) (A))->xx_part /* where the |xxpart| is found in a transform node */ +@d mp_xy_part(A) ((mp_transform_node) (A))->xy_part /* where the |xypart| is found in a transform node */ +@d mp_yx_part(A) ((mp_transform_node) (A))->yx_part /* where the |yxpart| is found in a transform node */ +@d mp_yy_part(A) ((mp_transform_node) (A))->yy_part /* where the |yypart| is found in a transform node */ + +@<MPlib internal header stuff@>= +typedef struct mp_transform_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_node tx_part; + mp_node ty_part; + mp_node xx_part; + mp_node yx_part; + mp_node xy_part; + mp_node yy_part; +} mp_transform_node_data; + +typedef struct mp_transform_node_data *mp_transform_node; + +@ @c +static mp_node mp_get_transform_node (MP mp) +{ + mp_transform_node p = (mp_transform_node) mp_allocate_node(mp, sizeof(mp_transform_node_data)); + mp_type(p) = mp_transform_node_type; + return (mp_node) p; +} + +@ @c +static void mp_init_transform_node (MP mp, mp_node p) +{ + mp_node q; /* the new node */ + mp_type(p) = mp_transform_type; + q = mp_get_transform_node(mp); /* big node */ + mp_yy_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_yy_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_yy_part(q)) = mp_yy_part_operation; + mp_link(mp_yy_part(q)) = p; + mp_yx_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_yx_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_yx_part(q)) = mp_yx_part_operation; + mp_link(mp_yx_part(q)) = p; + mp_xy_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_xy_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_xy_part(q)) = mp_xy_part_operation; + mp_link(mp_xy_part(q)) = p; + mp_xx_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_xx_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_xx_part(q)) = mp_xx_part_operation; + mp_link(mp_xx_part(q)) = p; + mp_ty_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_ty_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_ty_part(q)) = mp_y_part_operation; + mp_link(mp_ty_part(q)) = p; + mp_tx_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_tx_part(q)); /* sets |type(q)| and |value(q)| */ + mp_name_type(mp_tx_part(q)) = mp_x_part_operation; + mp_link(mp_tx_part(q)) = p; + mp_set_value_node(p, q); +} + +@ Variables of type |color| have 3~values in 6~words identified by +|mp_red_part_operation|, |mp_green_part_operation|, and |mp_blue_part_operation|. + +@d mp_red_part(A) ((mp_color_node) (A))->red_part /* where the |redpart| is found in a color node */ +@d mp_green_part(A) ((mp_color_node) (A))->green_part /* where the |greenpart| is found in a color node */ +@d mp_blue_part(A) ((mp_color_node) (A))->blue_part /* where the |bluepart| is found in a color node */ +@d mp_grey_part(A) ((mp_color_node) (A))->grey_part /* where the |greypart| is found in a color node */ +@d mp_cyan_part(A) ((mp_color_node) (A))->cyan_part /* where the |cyanpart| is found in a color node */ +@d mp_magenta_part(A) ((mp_color_node) (A))->magenta_part /* where the |magentapart| is found in a color node */ +@d mp_yellow_part(A) ((mp_color_node) (A))->yellow_part /* where the |yellowpart| is found in a color node */ +@d mp_black_part(A) ((mp_color_node) (A))->black_part /* where the |blackpart| is found in a color node */ + +@<MPlib internal header stuff@>= +typedef struct mp_color_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + union { + mp_node red_part; + mp_node cyan_part; + }; + union { + mp_node green_part; + mp_node magenta_part; + }; + union { + mp_node blue_part; + mp_node yellow_part; + }; + union { + mp_node grey_part; + mp_node black_part; + }; +} mp_color_node_data; + +typedef struct mp_color_node_data *mp_color_node; + +@ @c +static void mp_init_color_node (MP mp, mp_node p, int type) +{ + mp_node q = (mp_node) mp_allocate_node(mp, sizeof(mp_color_node_data)); + q->link = NULL; + mp_type(p) = type; + switch (type) { + case mp_color_type: + mp_type(q) = mp_color_node_type; + /* */ + mp_red_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_red_part(q)); + mp_name_type(mp_red_part(q)) = mp_red_part_operation; + mp_link(mp_red_part(q)) = p; + /* */ + mp_green_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_green_part(q)); + mp_name_type(mp_green_part(q)) = mp_green_part_operation; + mp_link(mp_green_part(q)) = p; + /* */ + mp_blue_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_blue_part(q)); + mp_name_type(mp_blue_part(q)) = mp_blue_part_operation; + mp_link(mp_blue_part(q)) = p; + break; + case mp_cmykcolor_type: + mp_type(q) = mp_cmykcolor_node_type; + /* */ + mp_cyan_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_cyan_part(q)); + mp_name_type(mp_cyan_part(q)) = mp_cyan_part_operation; + mp_link(mp_cyan_part(q)) = p; + /* */ + mp_magenta_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_magenta_part(q)); + mp_name_type(mp_magenta_part(q)) = mp_magenta_part_operation; + mp_link(mp_magenta_part(q)) = p; + /* */ + mp_yellow_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_yellow_part(q)); + mp_name_type(mp_yellow_part(q)) = mp_yellow_part_operation; + mp_link(mp_yellow_part(q)) = p; + /* */ + mp_black_part(q) = mp_new_value_node(mp); + mp_new_indep(mp, mp_black_part(q)); + mp_name_type(mp_black_part(q)) = mp_black_part_operation; + mp_link(mp_black_part(q)) = p; + break; + } + mp_set_value_node(p, q); +} + +@ When an entire structured variable is saved, the |root| indication is +temporarily replaced by |saved_root|. Some variables have no name; they just are +used for temporary storage while expressions are being evaluated. We call them +{\sl capsules}. + +@ The |id_transform| function creates a capsule for the identity transformation. + +@c +static mp_node mp_id_transform (MP mp) +{ + mp_node q; + mp_node p = mp_new_value_node(mp); + mp_name_type(p) = mp_capsule_operation; + mp_set_value_number(p, zero_t); /* todo: this was |null| */ + mp_init_transform_node(mp, p); + q = mp_get_value_node(p); + mp_type(mp_tx_part(q)) = mp_known_type; + mp_set_value_number(mp_tx_part(q), zero_t); + mp_type(mp_ty_part(q)) = mp_known_type; + mp_set_value_number(mp_ty_part(q), zero_t); + mp_type(mp_xy_part(q)) = mp_known_type; + mp_set_value_number(mp_xy_part(q), zero_t); + mp_type(mp_yx_part(q)) = mp_known_type; + mp_set_value_number(mp_yx_part(q), zero_t); + mp_type(mp_xx_part(q)) = mp_known_type; + mp_set_value_number(mp_xx_part(q), unity_t); + mp_type(mp_yy_part(q)) = mp_known_type; + mp_set_value_number(mp_yy_part(q), unity_t); + return p; +} + +@ Tokens are of type |tag_token| when they first appear, but they point to |NULL| +until they are first used as the root of a variable. The following subroutine +establishes the root node on such grand occasions. + +@c +static void mp_new_root (MP mp, mp_sym x) +{ + mp_node p = mp_new_value_node(mp); + mp_type(p) = mp_undefined_type; + mp_name_type(p) = mp_root_operation; + mp_set_value_sym(p, x); + set_equiv_node(x, p); +} + +@ These conventions for variable representation are illustrated by the +|print_variable_name| routine, which displays the full name of a variable given +only a pointer to its value. + +@<Declarations@>= +static void mp_print_variable_name (MP mp, mp_node p); + +@ @c +void mp_print_variable_name (MP mp, mp_node p) +{ + mp_node q = NULL; /* a token list that will name the variable's suffix */ + mp_node r = NULL; /* temporary for token list creation */ + while (mp_name_type(p) >= mp_x_part_operation) { + switch (mp_name_type(p)) { + case mp_x_part_operation : mp_print_str(mp, "xpart "); break; + case mp_y_part_operation : mp_print_str(mp, "ypart "); break; + case mp_xx_part_operation : mp_print_str(mp, "xxpart "); break; + case mp_xy_part_operation : mp_print_str(mp, "xypart "); break; + case mp_yx_part_operation : mp_print_str(mp, "yxpart "); break; + case mp_yy_part_operation : mp_print_str(mp, "yypart "); break; + case mp_red_part_operation : mp_print_str(mp, "redpart "); break; + case mp_green_part_operation : mp_print_str(mp, "greenpart "); break; + case mp_blue_part_operation : mp_print_str(mp, "bluepart "); break; + case mp_cyan_part_operation : mp_print_str(mp, "cyanpart "); break; + case mp_magenta_part_operation: mp_print_str(mp, "magentapart "); break; + case mp_yellow_part_operation : mp_print_str(mp, "yellowpart "); break; + case mp_black_part_operation : mp_print_str(mp, "blackpart "); break; + case mp_grey_part_operation : mp_print_str(mp, "greypart "); break; + case mp_capsule_operation : mp_print_fmt(mp, "%%CAPSULE%p", p); return; + default : break; + } + p = mp_link(p); + } + while (mp_name_type(p) > mp_saved_root_operation) { + /* + Ascend one level, pushing a token onto list |q| and replacing |p| by + its parent + */ + if (mp_name_type(p) == mp_subscript_operation) { + r = mp_new_num_tok(mp, &(mp_subscript(p))); + do { + p = mp_link(p); + } while (mp_name_type(p) != mp_attribute_operation); + } else if (mp_name_type(p) == mp_structured_root_operation) { + p = mp_link(p); + goto FOUND; + } else if (mp_name_type(p) != mp_attribute_operation) { + mp_confusion(mp, "variable"); + } else { + r = mp_new_symbolic_node(mp); + /* the hash address */ + mp_set_sym_sym(r, mp_get_hashloc(p)); + } + mp_set_link(r, q); + q = r; + FOUND: + p = mp_get_parent((mp_value_node) p); + + } + /* + now |link(p)| is the hash address of |p|, and |name_type(p)| is either + |root| or |saved_root|. Have to prepend a token to |q| for + |show_token_list|. + */ + r = mp_new_symbolic_node(mp); + mp_set_sym_sym(r, mp_get_value_sym(p)); + mp_link(r) = q; + if (mp_name_type(p) == mp_saved_root_operation) { + mp_print_str(mp, "(SAVED)"); + } + mp_show_token_list(mp, r, NULL); + mp_flush_token_list(mp, r); +} + +@ The |interesting| function returns |true| if a given variable is not in a +capsule, or if the user wants to trace capsules. + +@c +static int mp_interesting (MP mp, mp_node p) +{ + if (number_positive(internal_value(mp_tracing_capsules_internal))) { + return 1; + } else { + mp_name_type_type t = mp_name_type(p); + if (t >= mp_x_part_operation && t != mp_capsule_operation) { + mp_node tt = mp_get_value_node(mp_link(p)); + switch (t) { + case mp_x_part_operation: t = mp_name_type(mp_x_part (tt)); break; + case mp_y_part_operation: t = mp_name_type(mp_y_part (tt)); break; + case mp_xx_part_operation: t = mp_name_type(mp_xx_part (tt)); break; + case mp_xy_part_operation: t = mp_name_type(mp_xy_part (tt)); break; + case mp_yx_part_operation: t = mp_name_type(mp_yx_part (tt)); break; + case mp_yy_part_operation: t = mp_name_type(mp_yy_part (tt)); break; + case mp_red_part_operation: t = mp_name_type(mp_red_part (tt)); break; + case mp_green_part_operation: t = mp_name_type(mp_green_part (tt)); break; + case mp_blue_part_operation: t = mp_name_type(mp_blue_part (tt)); break; + case mp_cyan_part_operation: t = mp_name_type(mp_cyan_part (tt)); break; + case mp_magenta_part_operation: t = mp_name_type(mp_magenta_part(tt)); break; + case mp_yellow_part_operation: t = mp_name_type(mp_yellow_part (tt)); break; + case mp_black_part_operation: t = mp_name_type(mp_black_part (tt)); break; + case mp_grey_part_operation: t = mp_name_type(mp_grey_part (tt)); break; + default: break; + } + } + return (t != mp_capsule_operation); + } +} + +@ Now here is a subroutine that converts an unstructured type into an equivalent +structured type, by inserting a |mp_structured| node that is capable of growing. +This operation is done only when |mp_name_type(p)=root|, |subscr|, or |attr|. + +The procedure returns a pointer to the new node that has taken node~|p|'s place +in the structure. Node~|p| itself does not move, nor are its |value| or |type| +fields changed in any way. + +@c +static mp_node mp_new_structure (MP mp, mp_node p) +{ + mp_node r = NULL; + switch (mp_name_type(p)) { + case mp_root_operation: + { + mp_sym q = mp_get_value_sym(p); + r = mp_new_value_node(mp); + set_equiv_node(q, r); + } + break; + case mp_subscript_operation: + /* Link a new subscript node |r| in place of node |p| */ + { + mp_node q_new; + mp_node q = p; + do { + q = mp_link(q); + } while (mp_name_type(q) != mp_attribute_operation); + q = mp_get_parent((mp_value_node) q); + r = mp->temp_head; + mp_set_link(r, mp_get_subscr_head(q)); + do { + q_new = r; + r = mp_link(r); + } while (r != p); + r = (mp_node) mp_get_subscr_node(mp); + if (q_new == mp->temp_head) { + mp_set_subscr_head(q, r); + } else { + mp_set_link(q_new, r); + } + number_clone(mp_subscript(r), mp_subscript(p)); + } + break; + case mp_attribute_operation: + /* + Link a new attribute node |r| in place of node |p| If the + attribute is |collective_subscript|, there are two pointers to + node~|p|, so we must change both of them. + */ + { + mp_value_node rr; + mp_node q = mp_get_parent((mp_value_node) p); + r = mp_get_attribute_head(q); + do { + q = r; + r = mp_link(r); + } while (r != p); + rr = mp_get_attribute_node(mp); + r = (mp_node) rr; + mp_set_link(q, rr); + mp_set_hashloc(rr, mp_get_hashloc(p)); + mp_set_parent(rr, mp_get_parent((mp_value_node) p)); + if (mp_get_hashloc(p) == mp_collective_subscript) { + q = mp->temp_head; + mp_set_link(q, mp_get_subscr_head(mp_get_parent((mp_value_node) p))); + while (mp_link(q) != p) { + q = mp_link(q); + } + if (q == mp->temp_head) { + mp_set_subscr_head(mp_get_parent((mp_value_node) p), (mp_node) rr); + } else { + mp_set_link(q, rr); + } + } + } + break; + default: + mp_confusion(mp, "structure"); + break; + } + if (r) { + mp_value_node q; + mp_set_link(r, mp_link(p)); + mp_set_value_sym(r, mp_get_value_sym(p)); + mp_type(r) = mp_structured_type; + mp_name_type(r) = mp_name_type(p); + mp_set_attribute_head(r, p); + mp_name_type(p) = mp_structured_root_operation; + q = mp_get_attribute_node(mp); + mp_set_link(p, q); + mp_set_subscr_head(r, (mp_node) q); + mp_set_parent(q, r); + mp_type(q) = mp_undefined_type; + mp_name_type(q) = mp_attribute_operation; + mp_set_link(q, mp->end_attr); + mp_set_hashloc(q, mp_collective_subscript); + } + return r; +} + +@ The |find_variable| routine is given a pointer~|t| to a nonempty token list of +suffixes; it returns a pointer to the corresponding non-symbolic value. For +example, if |t| points to token |x| followed by a numeric token containing the +value~7, |find_variable| finds where the value of |x7| is stored in memory. This +may seem a simple task, and it usually is, except when |x7| has never been +referenced before. Indeed, |x| may never have even been subscripted before; +complexities arise with respect to updating the collective subscript information. + +If a macro type is detected anywhere along path~|t|, or if the first item on |t| +isn't a |tag_token|, the value |NULL| is returned. Otherwise |p| will be a +non-NULL pointer to a node such that |undefined < type(p) < mp_structured|. + +@c +static mp_node mp_find_variable (MP mp, mp_node t) +{ + mp_sym p_sym = mp_get_sym_sym(t); + @^inner loop@> + // if ((eq_type(p_sym) % mp_outer_tag_command) != mp_tag_command) { + if (eq_type(p_sym) != mp_tag_command) { + return NULL; + } else { + mp_node p, q, r, s; /* nodes in the \quote {value} line */ + mp_node pp, qq, rr, ss; /* nodes in the \quote {collective} line */ + t = mp_link(t); + if (equiv_node(p_sym) == NULL) { + mp_new_root (mp, p_sym); + } + p = equiv_node(p_sym); + pp = p; + while (t != NULL) { + /* + Make sure that both nodes |p| and |pp| are of |mp_structured| type + Although |pp| and |p| begin together, they diverge when a subscript + occurs; |pp|~stays in the collective line while |p|~goes through + actual subscript values. + */ + if (mp_type(pp) != mp_structured_type) { + if (mp_type(pp) > mp_structured_type) { + return NULL; + } else { + ss = mp_new_structure(mp, pp); + if (p == pp) { + p = ss; + } + pp = ss; + } + } + /* now |type(pp)=mp_structured| */ + if (mp_type(p) != mp_structured_type) { + /* it cannot be |>mp_structured| */ + p = mp_new_structure(mp, p); + /* now |type(p)=mp_structured| */ + } + if (mp_type(t) != mp_symbol_node_type) { + /* + Descend one level for the subscript |value (t)| We want this part + of the program to be reasonably fast, in case there are lots of + subscripts at the same level of the data structure. Therefore we + store an \quote {infinite} value in the word that appears at the end + of the subscript list, even though that word isn't part of a + subscript node. + */ + mp_number nn, save_subscript; /* temporary storage */ + new_number_clone(nn, mp_get_value_number(t)); + pp = mp_link(mp_get_attribute_head(pp)); + /* now |mp_get_hashloc(pp)=mp_collective_subscript| */ + q = mp_link(mp_get_attribute_head(p)); + new_number_clone(save_subscript, mp_subscript(q)); + set_number_to_inf(mp_subscript(q)); + s = mp->temp_head; + mp_set_link(s, mp_get_subscr_head(p)); + do { + r = s; + s = mp_link(s); + } while (number_greater(nn, mp_subscript(s))); + if (number_equal(nn, mp_subscript(s))) { + p = s; + } else { + mp_value_node p1 = mp_get_subscr_node(mp); + if (r == mp->temp_head) { + mp_set_subscr_head(p, (mp_node) p1); + } else { + mp_set_link(r, p1); + } + mp_set_link(p1, s); + number_clone(mp_subscript(p1), nn); + mp_name_type(p1) = mp_subscript_operation; + mp_type(p1) = mp_undefined_type; + p = (mp_node) p1; + } + number_clone(mp_subscript(q), save_subscript); + free_number(save_subscript); + free_number(nn); + } else { + /* Descend one level for the attribute |mp_get_sym_info(t)| */ + mp_sym nn1 = mp_get_sym_sym(t); + ss = mp_get_attribute_head(pp); + do { + rr = ss; + ss = mp_link(ss); + } while (nn1 > mp_get_hashloc(ss)); + if (nn1 < mp_get_hashloc(ss)) { + qq = (mp_node) mp_get_attribute_node(mp); + mp_set_link(rr, qq); + mp_set_link(qq, ss); + mp_set_hashloc(qq, nn1); + mp_name_type(qq) = mp_attribute_operation; + mp_type(qq) = mp_undefined_type; + mp_set_parent((mp_value_node) qq, pp); + ss = qq; + } + if (p == pp) { + p = ss; + pp = ss; + } else { + pp = ss; + s = mp_get_attribute_head(p); + do { + r = s; + s = mp_link(s); + } while (nn1 > mp_get_hashloc(s)); + if (nn1 == mp_get_hashloc(s)) { + p = s; + } else { + q = (mp_node) mp_get_attribute_node(mp); + mp_set_link(r, q); + mp_set_link(q, s); + mp_set_hashloc(q, nn1); + mp_name_type(q) = mp_attribute_operation; + mp_type(q) = mp_undefined_type; + mp_set_parent((mp_value_node) q, p); + p = q; + } + } + } + t = mp_link(t); + } + if (mp_type(pp) >= mp_structured_type) { + if (mp_type(pp) == mp_structured_type) { + pp = mp_get_attribute_head(pp); + } else { + return NULL; + } + } + if (mp_type(p) == mp_structured_type) { + p = mp_get_attribute_head(p); + } + if (mp_type(p) == mp_undefined_type) { + if (mp_type(pp) == mp_undefined_type) { + mp_type(pp) = mp_numeric_type; + mp_set_value_number(pp, zero_t); + } + mp_type(p) = mp_type(pp); + mp_set_value_number(p, zero_t); + } + return p; + } +} + +@ Variables lose their former values when they appear in a type declaration, or +when they are defined to be macros or |let| equal to something else. A +subroutine will be defined later that recycles the storage associated with any +particular |type| or |value|; our goal now is to study a higher level process +called |flush_variable|, which selectively frees parts of a variable structure. + +This routine has some complexity because of examples such as |numeric x[]a[]b| +which recycles all variables of the form |x[i]a[j]b| (and no others), while +|vardef x[]a[] = ...| discards all variables of the form |x[i]a[j]| followed by +an arbitrary suffix, except for the collective node |x[]a[]| itself. The obvious +way to handle such examples is to use recursion; so that's what we~do. +@^recursion@> + +Parameter |p| points to the root information of the variable; parameter |t| +points to a list of symbolic nodes that represent suffixes, with |info = +mp_collective_subscript| for subscripts. + +@<Declarations@>= +static void mp_flush_cur_exp (MP mp, mp_value v); + +@ @c +static void mp_flush_variable (MP mp, mp_node p, mp_node t, int discard_suffixes) +{ + while (t != NULL) { + if (mp_type(p) != mp_structured_type) { + return; + } else { + /* attribute to match */ + mp_sym n = mp_get_sym_sym(t); + t = mp_link(t); + if (n == mp_collective_subscript) { + mp_node q = mp_get_subscr_head(p); + mp_node r = NULL; + while (mp_name_type(q) == mp_subscript_operation) { + mp_flush_variable(mp, q, t, discard_suffixes); + if (t != NULL) { + r = q; + } else if (mp_type(q) == mp_structured_type) { + r = q; + } else { + if (r == NULL) { + mp_set_subscr_head(p, mp_link(q)); + } else { + mp_set_link(r, mp_link(q)); + } + mp_free_value_node(mp, q); + } + q = r == NULL ? mp_get_subscr_head(p) : mp_link(r); + } + } + p = mp_get_attribute_head(p); + do { + p = mp_link(p); + } while (mp_get_hashloc(p) < n); + if (mp_get_hashloc(p) != n) { + return; + } + } + } + if (discard_suffixes) { + mp_flush_below_variable(mp, p); + } else { + if (mp_type(p) == mp_structured_type) { + p = mp_get_attribute_head(p); + } + mp_recycle_value(mp, p); + } +} + +@ The next procedure is simpler; it wipes out everything but |p| itself, which +becomes undefined. + +@<Declarations@>= +static void mp_flush_below_variable (MP mp, mp_node p); + +@ @c +void mp_flush_below_variable (MP mp, mp_node p) +{ + if (mp_type(p) != mp_structured_type) { + mp_recycle_value(mp, p); /* this sets |type(p)=undefined| */ + } else { + mp_node r; + mp_node q = mp_get_subscr_head(p); + while (mp_name_type(q) == mp_subscript_operation) { + mp_flush_below_variable(mp, q); + r = q; + q = mp_link(q); + mp_free_value_node(mp, r); + } + r = mp_get_attribute_head(p); + q = mp_link(r); + mp_recycle_value(mp, r); + mp_free_value_node(mp, r); + do { + mp_flush_below_variable(mp, q); + r = q; + q = mp_link(q); + mp_free_value_node(mp, r); + } while (q != mp->end_attr); + mp_type(p) = mp_undefined_type; + } +} + +@ Just before assigning a new value to a variable, we will recycle the old value +and make the old value undefined. The |und_type| routine determines what type of +undefined value should be given, based on the current type before recycling. + +@c +static int mp_und_type (MP mp, mp_node p) +{ + (void) mp; + switch (mp_type(p)) { + case mp_vacuous_type: + return mp_undefined_type; + case mp_boolean_type: + case mp_unknown_boolean_type: + return mp_unknown_boolean_type; + case mp_string_type: + case mp_unknown_string_type: + return mp_unknown_string_type; + case mp_pen_type: + case mp_unknown_pen_type: + return mp_unknown_pen_type; + case mp_nep_type: + case mp_unknown_nep_type: + return mp_unknown_nep_type; + case mp_path_type: + case mp_unknown_path_type: + return mp_unknown_path_type; + case mp_picture_type: + case mp_unknown_picture_type: + return mp_unknown_picture_type; + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + case mp_numeric_type: + return mp_type(p); + case mp_known_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + return mp_numeric_type; + default: + return 0; + } +} + +@ The |clear_symbol| routine is used when we want to redefine the equivalent of a +symbolic token. It must remove any variable structure or macro definition that is +currently attached to that symbol. If the |saving| parameter is true, a +subsidiary structure is saved instead of destroyed. + +@c +static void mp_clear_symbol (MP mp, mp_sym p, int saving) +{ + mp_node q = equiv_node(p); + if (eq_property(p) > 0) { + mp_check_overload(mp, p); + } + // switch (eq_type(p) % mp_outer_tag_command) { + switch (eq_type(p)) { + case mp_defined_macro_command: + case mp_primary_def_command: + case mp_secondary_def_command: + case mp_tertiary_def_command: + if (!saving) { + mp_delete_mac_ref(mp, q); + } + break; + case mp_tag_command: + if (q != NULL) { + if (saving) { + mp_name_type(q) = mp_saved_root_operation; + } else { + mp_flush_below_variable(mp, q); + mp_free_value_node(mp, q); + } + } + break; + default: + break; + } + set_equiv(p, mp->frozen_undefined->v.data.indep.serial); + set_eq_type(p, mp->frozen_undefined->type); +} + +@* Saving and restoring equivalents. + +The nested structure given by |begingroup| and |endgroup| allows |eqtb| entries +to be saved and restored, so that temporary changes can be made without +difficulty. When the user requests a current value to be saved, \MP\ puts that +value into its \quote {save stack.} An appearance of |endgroup| ultimately causes +the old values to be removed from the save stack and put back in their former +places. + +The save stack is a linked list containing three kinds of entries, distinguished +by their |type| fields. If |p| points to a saved item, then + +\smallskip \hang |p->type = 0| stands for a group boundary; each |begingroup| +contributes such an item to the save stack and each |endgroup| cuts back the +stack until the most recent such entry has been removed. + +\smallskip \hang |p->type = mp_normal_operation| means that |p->value| holds the +former contents of |eqtb[q]| (saved in the |knot| field of the value, which is +otherwise unused for variables). Such save stack entries are generated by |save| +commands. + +\smallskip \hang |p->type = mp_internal_operation| means that |p->value| is a +|mp_internal| to be restored to internal parameter number~|q| (saved in the +|serial| field of the value, which is otherwise unused for internals). Such +entries are generated by |interim| commands. + +\smallskip \noindent The global variable |save_ptr| points to the top item on the +save stack. + +@<Types...@>= +typedef struct mp_save_data { + int type; + int padding; + mp_internal value; + struct mp_save_data *link; +} mp_save_data; + +@ @<Glob...@>= +mp_save_data *save_ptr; /* the most recently saved item */ + +@ @<Set init...@>= +mp->save_ptr = NULL; + +@ Saving a boundary item +@c +static void mp_save_boundary (MP mp) +{ + mp_save_data *p = mp_memory_allocate(sizeof(mp_save_data)); + p->type = 0; + p->link = mp->save_ptr; + mp->save_ptr = p; +} + +@ The |save_variable| routine is given a hash address |q|; it salts this address +in the save stack, together with its current equivalent, then makes token~|q| +behave as though it were brand new. + +Nothing is stacked when |save_ptr = NULL|, however; there's no way to remove +things from the stack when the program is not inside a group, so there's no point +in wasting the space. + +@c +static void mp_save_variable (MP mp, mp_sym q) +{ + if (mp->save_ptr != NULL) { + mp_save_data *p = mp_memory_allocate(sizeof(mp_save_data)); + p->type = mp_normal_operation; + p->link = mp->save_ptr; + p->value.v.data.indep.scale = eq_type(q); + p->value.v.data.indep.serial = equiv(q); + p->value.v.data.node = equiv_node(q); + p->value.v.data.p = (mp_knot)q; + mp->save_ptr = p; + } + mp_clear_symbol(mp, q, (mp->save_ptr != NULL)); +} + +static void mp_unsave_variable (MP mp) +{ + mp_sym q = (mp_sym)mp->save_ptr->value.v.data.p; + if (number_positive(internal_value(mp_tracing_restores_internal))) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{restoring "); + mp_print_mp_str(mp,text(q)); + mp_print_chr(mp, '}'); + mp_end_diagnostic(mp, 0); + } + mp_clear_symbol(mp, q, 0); + set_eq_type(q, mp->save_ptr->value.v.data.indep.scale); + set_equiv(q,mp->save_ptr->value.v.data.indep.serial); + q->v.data.node = mp->save_ptr->value.v.data.node; + // if (eq_type(q) % mp_outer_tag_command == mp_tag_command) { + if (eq_type(q) == mp_tag_command) { + mp_node pp = q->v.data.node; + if (pp != NULL) { + mp_name_type(pp) = mp_root_operation; + } + } +} + +@ Similarly, |save_internal| is given the location |q| of an internal quantity +like |mp_tracing_pens|. It creates a save stack entry of the third kind. + +Todo: check what happens with strings! We need to mess with the ref counter and +there is no need to copy a number when we have a string. + +@c +static void mp_save_internal (MP mp, int q) +{ + if (mp->save_ptr != NULL) { + mp_save_data *p = mp_memory_allocate(sizeof(mp_save_data)); + p->type = mp_internal_operation; + p->link = mp->save_ptr; + p->value = mp->internal[q]; + p->value.v.data.indep.serial = q; + if (internal_run(q) == 1) { + mp->run_internal(mp, 1, q, internal_type(q), internal_name(q)); + } + new_number_clone(p->value.v.data.n, mp->internal[q].v.data.n); + mp->save_ptr = p; + } +} + +static void mp_unsave_internal (MP mp) +{ + int q = mp->save_ptr->value.v.data.indep.serial; + mp_internal saved = mp->save_ptr->value; + if (number_positive(internal_value(mp_tracing_restores_internal))) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{restoring "); + mp_print_str(mp, internal_name(q)); + mp_print_chr(mp, '='); + switch (internal_type(q)) { + case mp_known_type: + case mp_numeric_type: + print_number(saved.v.data.n); + break; + case mp_boolean_type: + mp_print_str(mp, number_to_boolean(saved.v.data.n) == mp_true_operation ? "true" : "false"); + break; + case mp_string_type: + { + char *s = mp_str(mp, saved.v.data.str); + mp_print_str(mp, s); + break; + } + default: + mp_confusion(mp, "internal restore"); + break; + } + mp_print_chr(mp, '}'); + mp_end_diagnostic(mp, 0); + } + free_number(mp->internal[q].v.data.n); + if (internal_run(q) == 1) { + mp->run_internal(mp, 2, q, internal_type(q), internal_name(q)); + } + mp->internal[q] = saved; +} + +@ At the end of a group, the |unsave| routine restores all of the saved +equivalents in reverse order. This routine will be called only when there is at +least one boundary item on the save stack. + +@c +static void mp_unsave (MP mp) +{ + mp_save_data *p; /* saved item */ + while (mp->save_ptr->type != 0) { + if (mp->save_ptr->type == mp_internal_operation) { + mp_unsave_internal(mp); + } else { + mp_unsave_variable(mp); + } + p = mp->save_ptr->link; + mp_memory_free(mp->save_ptr); + mp->save_ptr = p; + } + p = mp->save_ptr->link; + mp_memory_free(mp->save_ptr); + mp->save_ptr = p; +} + +@* Data structures for paths. + +When a \MP\ user specifies a path, \MP\ will create a list of knots and control +points for the associated cubic spline curves. If the knots are $z_0$, $z_1$, +\dots, $z_n$, there are control points $z_k^+$ and $z_{k+1}^-$ such that the +cubic splines between knots $z_k$ and $z_{k+1}$ are defined by B\'ezier's formula +@:Bezier}{B\'ezier, Pierre Etienne@> + +$$\eqalign{z(t)&=B(z_k,z_k^+,z_{k+1}^-,z_{k+1};t)\cr +&=(1-t)^3z_k+3(1-t)^2tz_k^++3(1-t)t^2z_{k+1}^-+t^3z_{k+1}\cr}$$ + +for |0<=t<=1|. + +There is a 8-word node for each knot $z_k$, containing one word of control +information and six words for the |x| and |y| coordinates of $z_k^-$ and $z_k$ +and~$z_k^+$. The control information appears in the |mp_left_type| and +|mp_right_type| fields, which each occupy a quarter of the first word in the +node; they specify properties of the curve as it enters and leaves the knot. +There's also a halfword |link| field, which points to the following knot, and a +final supplementary word (of which only a quarter is used). + +If the path is a closed contour, knots 0 and |n| are identical; i.e., the |link| +in knot |n-1| points to knot~0. But if the path is not closed, the |mp_left_type| +of knot~0 and the |mp_right_type| of knot~|n| are equal to |endpoint|. In the +latter case the |link| in knot~|n| points to knot~0, and the control points +$z_0^-$ and $z_n^+$ are not used. + +@d mp_next_knot(A) (A)->next /* the next knot in this list */ +@d mp_left_type(A) (A)->left_type /* characterizes the path entering this knot */ +@d mp_right_type(A) (A)->right_type /* characterizes the path leaving this knot */ +@d mp_prev_knot(A) (A)->prev /* the previous knot in this list (only for pens) */ +@d mp_knot_info(A) (A)->info /* temporary info, used during splitting */ + +@<Exported types...@>= +typedef struct mp_knot_data *mp_knot; + +typedef struct mp_knot_data { + mp_number x_coord; /* the |x| coordinate of this knot */ + mp_number y_coord; /* the |y| coordinate of this knot */ + union { + mp_number left_x; /* the |x| coordinate of previous control point */ + mp_number left_curl; /* curl information when entering this knot */ + mp_number left_given; /* given direction when entering this knot */ + }; + union { + mp_number left_y; /* the |y| coordinate of previous control point */ + mp_number left_tension; /* tension information when entering this knot */ + }; + union { + mp_number right_x; /* the |x| coordinate of next control point */ + mp_number right_curl; /* curl information when leaving this knot */ + mp_number right_given; /* given direction when leaving this knot */ + }; + union { + mp_number right_y; /* the |y| coordinate of next control point */ + mp_number right_tension; /* tension information when leaving this knot */ + }; + mp_knot next; + mp_knot prev; + unsigned char left_type; + unsigned char right_type; + unsigned char originator; + unsigned char state; + signed int info; + /* we now have some 3 bytes slack that we can use */ +} mp_knot_data; + +@ @<Exported types...@>= +typedef struct mp_gr_knot_data *mp_gr_knot; + +typedef struct mp_gr_knot_data { + double x_coord; + double y_coord; + double left_x; + double left_y; + double right_x; + double right_y; + mp_gr_knot next; + mp_gr_knot prev; + unsigned char left_type; + unsigned char right_type; + unsigned char originator; + unsigned char state; + signed int info; +} mp_gr_knot_data; + +@ @<MPlib header stuff@>= +typedef enum mp_knot_type { + mp_endpoint_knot, /* |mp_left_type| at path beginning and |mp_right_type| at path end */ + mp_explicit_knot, /* |mp_left_type| or |mp_right_type| when control points are known */ + mp_given_knot, /* |mp_left_type| or |mp_right_type| when a direction is given */ + mp_curl_knot, /* |mp_left_type| or |mp_right_type| when a curl is desired */ + mp_open_knot, /* |mp_left_type| or |mp_right_type| when \MP\ should choose the direction */ + mp_end_cycle_knot +} mp_knot_type; + +@ Before the B\'ezier control points have been calculated, the memory space they +will ultimately occupy is taken up by information that can be used to compute +them. There are four cases: + +\yskip \textindent{$\bullet$} If |mp_right_type=mp_open|, the curve should leave +the knot in the same direction it entered; \MP\ will figure out a suitable +direction. + +\yskip \textindent{$\bullet$} If |mp_right_type=mp_curl|, the curve should leave +the knot in a direction depending on the angle at which it enters the next knot +and on the curl parameter stored in |right_curl|. + +\yskip \textindent{$\bullet$} If |mp_right_type=mp_given|, the curve should leave +the knot in a nonzero direction stored as an |angle| in |right_given|. + +\yskip \textindent{$\bullet$} If |mp_right_type=mp_explicit|, the B\'ezier +control point for leaving this knot has already been computed; it is in the +|mp_right_x| and |mp_right_y| fields. + +\yskip\noindent The rules for |mp_left_type| are similar, but they refer to the +curve entering the knot, and to |left| fields instead of |right| fields. + +Non-|explicit| control points will be chosen based on \quote {tension} parameters +in the |left_tension| and |right_tension| fields. The |atleast| option is +represented by negative tension values. @:at_least_}{|atleast| primitive@> + +For example, the \MP\ path specification + +$$|z0..z1..tension atleast 1..\{curl 2\|z2..z3\{-1,-2\}..tension 3 and 4..p},$$ + +where \.p is the path |z4..controls z45 and z54..z5|, will be represented by +the six knots \def\lodash{\hbox to 1.1em{\thinspace\hrulefill\thinspace}} + +$$\vbox{\halign{#\hfil&&\qquad#\hfil\cr |mp_left_type|&|left| +info&|x_coord,y_coord|&|mp_right_type|&|right| info\cr \noalign{\yskip} +|endpoint|&\lodash$,\,$\lodash&$x_0,y_0$&|curl|&$1.0,1.0$\cr +|open|&\lodash$,1.0$&$x_1,y_1$&|open|&\lodash$,-1.0$\cr +|curl|&$2.0,-1.0$&$x_2,y_2$&|curl|&$2.0,1.0$\cr +|given|&$d,1.0$&$x_3,y_3$&|given|&$d,3.0$\cr +|open|&\lodash$,4.0$&$x_4,y_4$&|explicit|&$x_{45},y_{45}$\cr +|explicit|&$x_{54},y_{54}$&$x_5,y_5$&|endpoint|&\lodash$,\,$\lodash\cr}}$$ + +Here |d| is the |angle| obtained by calling |n_arg(-unity,-two)|. Of course, this +example is more complicated than anything a normal user would ever write. + +These types must satisfy certain restrictions because of the form of \MP's path +syntax: (i)~|open| type never appears in the same node together with |endpoint|, +|given|, or |curl|. (ii)~The |mp_right_type| of a node is |explicit| if and only +if the |mp_left_type| of the following node is |explicit|. (iii)~|endpoint| types +occur only at the ends, as mentioned above. + +@ Knots can be user-supplied, or they can be created by program code, like the +|split_cubic| function, or |copy_path|. The distinction is needed for the cleanup +routine that runs after |split_cubic|, because it should only delete knots it has +previously inserted, and never anything that was user-supplied. In order to be +able to differentiate one knot from another, we will set |originator(p) := +mp_metapost_user| when it appeared in the actual metapost program, and +|originator(p) := mp_program_code| in all other cases. + +@d mp_originator(A) (A)->originator /* the creator of this knot */ +@d mp_knotstate(A) (A)->state + +@<Exported types@>= +enum mp_knot_originator { + mp_program_code, /* not created by a user */ + mp_metapost_user /* created by a user */ +}; +enum mp_knot_states { + mp_regular_knot, + mp_begin_knot, + mp_end_knot, + mp_single_knot, +}; + +@ Here is a routine that prints a given knot list in symbolic form. It +illustrates the conventions discussed above, and checks for anomalies that might +arise while \MP\ is being debugged. + +@<Declarations@>= +static void mp_pr_path (MP mp, mp_knot h); + +@ @c +void mp_pr_path (MP mp, mp_knot h) +{ + mp_knot p = h; + do { + mp_knot q = mp_next_knot(p); + if ((p == NULL) || (q == NULL)) { + mp_print_nl(mp, "???"); + return; /* this won't happen */ + @.???@> + } else { + @<Print information for adjacent knots |p| and |q|@> + DONE1: + p = q; + if (p && ((p != h) || (mp_left_type(h) != mp_endpoint_knot))) { + @<Print two dots, followed by |given| or |curl| if present@> + } + } + } while (p != h); + if (mp_left_type(h) != mp_endpoint_knot) { + mp_print_str(mp, " cycle"); + } +} + +@ @<Print information for adjacent knots...@>= +mp_print_two(mp, &(p->x_coord), &(p->y_coord)); +switch (mp_knotstate(p)) { + case mp_begin_knot: + mp_print_str(mp, " {begin}"); + break; + case mp_end_knot: + mp_print_str(mp, " {end}"); + break; +} +switch (mp_right_type(p)) { + case mp_endpoint_knot: + { + if (mp_left_type(p) == mp_open_knot) { + mp_print_str(mp, " {open?}"); /* can't happen */ + @.open?@> + } + if ((mp_left_type(q) != mp_endpoint_knot) || (q != h)) { + q = NULL; /* force an error */ + } + goto DONE1; + } + break; + case mp_explicit_knot: + { + @<Print control points between |p| and |q|, then |goto done1|@> + } + break; + case mp_open_knot: + { + @<Print information for a curve that begins |open|@> + } + break; + case mp_curl_knot: + case mp_given_knot: + { + @<Print information for a curve that begins |curl| or |given|@> + } + break; + default: + { + mp_print_str(mp, "???"); /* can't happen */ + @.???@> + } + break; +} +if (mp_left_type(q) <= mp_explicit_knot) { + mp_print_str(mp, " .. control ?"); /* can't happen */ + @.control?@> +} else if ((! number_equal(p->right_tension, unity_t)) || (! number_equal(q->left_tension, unity_t))) { + @<Print tension between |p| and |q|@> +} + +@ Since |n_sin_cos| produces |fraction| results, which we will print as if they +were |scaled|, the magnitude of a |given| direction vector will be~4096. + +@<Print two dots...@>= +mp_number n_sin, n_cos; +new_fraction(n_sin); +new_fraction(n_cos); +mp_print_nl(mp, " .. "); +if (mp_left_type(p) == mp_given_knot) { + n_sin_cos(p->left_given, n_cos, n_sin); + mp_print_str(mp, "{"); + print_number(n_cos); + mp_print_chr(mp, ','); + print_number(n_sin); + mp_print_chr(mp, '}'); +} else if (mp_left_type(p) == mp_curl_knot) { + mp_print_str(mp, "{curl "); + print_number(p->left_curl); + mp_print_chr(mp, '}'); +} +free_number(n_sin); +free_number(n_cos); + +@ @<Print tension between |p| and |q|@>= +mp_number v1; +mp_print_str(mp, " .. tension"); +if (number_negative(p->right_tension)) { + mp_print_str(mp, " atleast"); +} +new_number_abs(v1, p->right_tension); +print_number(v1); +if (! number_equal(p->right_tension, q->left_tension)) { + mp_print_str(mp, " and"); + if (number_negative(q->left_tension)) { + mp_print_str(mp, " atleast"); + } + number_abs_clone(v1, p->left_tension); + print_number(v1); +} +free_number(v1); + +@ @<Print control points between |p| and |q|, then |goto done1|@>= +mp_print_str(mp, " .. controls "); +mp_print_two(mp, &(p->right_x), &(p->right_y)); +mp_print_str(mp, " and "); +if (mp_left_type(q) != mp_explicit_knot) { + mp_print_str(mp, "??"); /* can't happen */ + @.??@> +} else { + mp_print_two(mp, &(q->left_x), &(q->left_y)); +} +goto DONE1; + +@ @<Print information for a curve that begins |open|@>= +if ((mp_left_type(p) != mp_explicit_knot) && (mp_left_type(p) != mp_open_knot)) { + mp_print_str(mp, " {open?}"); /* can't happen */ + @.open?@> +} + +@ A curl of 1 is shown explicitly, so that the user sees clearly that \MP's +default curl is present. + +@<Print information for a curve that begins |curl|...@>= +if (mp_left_type(p) == mp_open_knot) { + mp_print_str(mp, " ??"); /* can't happen */ + @.??@> +} +if (mp_right_type(p) == mp_curl_knot) { + mp_print_str(mp, " {curl"); + print_number(p->right_curl); +} else { + mp_number n_sin, n_cos; + new_fraction(n_sin); + new_fraction(n_cos); + n_sin_cos(p->right_given, n_cos, n_sin); + mp_print_str(mp, " {"); + print_number(n_cos); + mp_print_chr(mp, ','); + print_number(n_sin); + free_number(n_sin); + free_number(n_cos); +} +mp_print_str(mp, "} "); + +@ It is convenient to have another version of |pr_path| that prints the path as a +diagnostic message. + +@<Declarations@>= +static void mp_print_path (MP mp, mp_knot h, const char *s, int nuline); + +@ @c +void mp_print_path (MP mp, mp_knot h, const char *s, int nuline) +{ + mp_print_diagnostic(mp, "Path", s, nuline); + mp_print_ln(mp); + @.Path at line...@> + mp_pr_path(mp, h); + mp_end_diagnostic(mp, 1); +} + +@ @<Declarations@>= +static mp_knot mp_new_knot (MP mp); + +@ @c +static mp_knot mp_new_knot (MP mp) +{ + mp_knot q; + if (mp->knot_nodes) { + q = mp->knot_nodes; + mp->knot_nodes = q->next; + mp->num_knot_nodes--; + } else { + q = mp_memory_clear_allocate(sizeof(struct mp_knot_data)); + } + new_number(q->x_coord); + new_number(q->y_coord); + new_number(q->left_x); + new_number(q->left_y); + new_number(q->right_x); + new_number(q->right_y); + return q; +} + +@ @<Declarations@>= +static mp_gr_knot mp_gr_new_knot (MP mp); + +@ @c +static mp_gr_knot mp_gr_new_knot (MP mp) +{ + mp_gr_knot q = mp_memory_allocate(sizeof(struct mp_gr_knot_data)); + (void) mp; + return q; +} + +@ If we want to duplicate a knot node, we can say |copy_knot|: + +@c +static mp_knot mp_copy_knot (MP mp, mp_knot p) +{ + mp_knot q; + if (mp->knot_nodes) { + q = mp->knot_nodes; + mp->knot_nodes = q->next; + mp->num_knot_nodes--; + } else { + q = mp_memory_allocate(sizeof(struct mp_knot_data)); + } + memcpy(q, p, sizeof(struct mp_knot_data)); + if (mp->math_mode > mp_math_double_mode) { + new_number_clone(q->x_coord, p->x_coord); + new_number_clone(q->y_coord, p->y_coord); + new_number_clone(q->left_x, p->left_x); + new_number_clone(q->left_y, p->left_y); + new_number_clone(q->right_x, p->right_x); + new_number_clone(q->right_y, p->right_y); + } + mp_prev_knot(q) = NULL; + mp_next_knot(q) = NULL; + return q; +} + +@ If we want to export a knot node, we can say |export_knot|: + +@c +static mp_gr_knot mp_export_knot (MP mp, mp_knot p) +{ + mp_gr_knot q = mp_gr_new_knot(mp); + q->x_coord = number_to_double(p->x_coord); + q->y_coord = number_to_double(p->y_coord); + q->left_x = number_to_double(p->left_x); + q->left_y = number_to_double(p->left_y); + q->right_x = number_to_double(p->right_x); + q->right_y = number_to_double(p->right_y); + q->left_type = p->left_type; + q->right_type = p->right_type; + q->info = p->info; + q->originator = p->originator; + q->state = p->state; + q->prev = NULL; + q->next = NULL; + return q; +} + +@ The |copy_path| routine makes a clone of a given path. + +@c +static mp_knot mp_copy_path (MP mp, mp_knot p) +{ + if (p == NULL) { + return NULL; + } else { + mp_knot q = mp_copy_knot(mp, p); + mp_knot qq = q; + mp_knot pp = mp_next_knot(p); + while (pp != p) { + mp_knot k = mp_copy_knot(mp, pp); + mp_next_knot(qq) = k; + mp_prev_knot(k) = qq; + qq = mp_next_knot(qq); + pp = mp_next_knot(pp); + } + mp_next_knot(qq) = q; + mp_prev_knot(q) = qq; + return q; + } +} + +@ The |export_path| routine makes a clone of a given path +and converts the |value|s therein to |double|s. + +@c +static mp_gr_knot mp_export_path (MP mp, mp_knot p) +{ + if (p == NULL) { + return NULL; + } else { + mp_gr_knot q = mp_export_knot(mp, p); + mp_gr_knot qq = q; + mp_knot pp = mp_next_knot(p); + while (pp != p) { + mp_gr_knot k = mp_export_knot(mp, pp); + mp_prev_knot(k) = qq; + mp_next_knot(qq) = k; + qq = k; + pp = mp_next_knot(pp); + } + mp_prev_knot(q) = qq; + mp_next_knot(qq) = q; + return q; + } +} + +@ Just before |ship_out|, knot lists are exported for printing. + +@ The |export_knot_list| routine therefore also makes a clone of a given path. + +@c +static mp_gr_knot mp_export_knot_list (MP mp, mp_knot p) +{ + if (p == NULL) { + return NULL; + } else { + mp_gr_knot q = mp_export_path(mp, p); + return q; + } +} + +@ Similarly, there's a way to copy the {\em reverse} of a path. This procedure +returns a pointer to the first node of the copy, if the path is a cycle, but to +the final node of a non-cyclic copy. The global variable |path_tail| will point +to the final node of the original path; this trick makes it easier to implement +|doublepath|. + +All node types are assumed to be |endpoint| or |explicit| only. + +@c +static mp_knot mp_htap_ypoc (MP mp, mp_knot p) +{ + mp_knot q = mp_new_knot(mp); /* this will correspond to |p| */ + mp_knot qq = q; + mp_knot pp = p; + while (1) { + mp_right_type(qq) = mp_left_type(pp); + mp_left_type(qq) = mp_right_type(pp); + number_clone(qq->x_coord, pp->x_coord); + number_clone(qq->y_coord, pp->y_coord); + number_clone(qq->right_x, pp->left_x); + number_clone(qq->right_y, pp->left_y); + number_clone(qq->left_x, pp->right_x); + number_clone(qq->left_y, pp->right_y); + mp_originator(qq) = mp_originator(pp); + mp_knotstate(qq) = mp_knotstate(pp); + if (mp_next_knot(pp) == p) { + mp_prev_knot(qq) = q; + mp_next_knot(q) = qq; + mp->path_tail = pp; + return q; + } else { + mp_knot rr = mp_new_knot(mp); + mp_prev_knot(qq) = rr; + mp_next_knot(rr) = qq; + qq = rr; + pp = mp_next_knot(pp); + } + } +} + +@ @<Glob...@>= +mp_knot path_tail; /* the node that links to the beginning of a path */ + +@ When a cyclic list of knot nodes is no longer needed, it can be recycled by +calling the following subroutine. + +@<Declarations@>= +static void mp_toss_knot_list (MP mp, mp_knot p); +static void mp_toss_knot (MP mp, mp_knot p); +static void mp_free_knot (MP mp, mp_knot p); + +@ Numbers are unions of a scaled (integer), double or pointer. The pointer is +used for e.g.\ decimal numbers. These are structs with a size that is set at +compile time. A decimal number struct is allocated in the new_number function and +all the \METAPOST\ data structures that have number handle clean up and renewal. +Keeping the numbers in the free know list entries is just not worth the effort so +in decimal mode quite a bit of (de/re)allocation goes on. + +@c +static void mp_free_knot (MP mp, mp_knot q) +{ + if (mp->math_mode > mp_math_double_mode) { + free_number(q->x_coord); + free_number(q->y_coord); + free_number(q->left_x); + free_number(q->left_y); + free_number(q->right_x); + free_number(q->right_y); + } + mp_memory_free(q); +} + +static void mp_toss_knot (MP mp, mp_knot q) +{ + if (mp->num_knot_nodes < mp->max_knot_nodes) { + mp_next_knot(q) = mp->knot_nodes; + mp->knot_nodes = q; + mp->num_knot_nodes++; + if (mp->math_mode > mp_math_double_mode) { + free_number(q->x_coord); + free_number(q->y_coord); + free_number(q->left_x); + free_number(q->left_y); + free_number(q->right_x); + free_number(q->right_y); + } + } else { + mp_free_knot(mp, q); + } +} + +static void mp_toss_knot_list (MP mp, mp_knot p) +{ + if (p == NULL) { + return; + } else { + mp_knot q = p; + do { + mp_knot r = mp_next_knot(q); + mp_toss_knot(mp, q); + q = r; + } while (q != p); + } +} + +@* Choosing control points. + +Now we must actually delve into one of \MP's more difficult routines, the +|make_choices| procedure that chooses angles and control points for the splines +of a curve when the user has not specified them explicitly. The parameter to +|make_choices| points to a list of knots and path information, as described +above. + +A path decomposes into independent segments at \quote {breakpoint} knots, which are +knots whose left and right angles are both prespecified in some way (i.e., their +|mp_left_type| and |mp_right_type| aren't both open). + +@c +void mp_make_choices (MP mp, mp_knot knots) +{ + mp_knot h; /* the first breakpoint */ + mp_knot p, q; /* consecutive breakpoints being processed */ + @<Other local variables for |make_choices|@> + /* make sure that |arith_error=false| */ + check_arith(); + if (number_positive(internal_value(mp_tracing_choices_internal))) { + mp_print_path(mp, knots, ", before choices", 1); + } + @<If consecutive knots are equal, join them explicitly@> + @<Find the first breakpoint, |h|, on the path; insert an artificial breakpoint if the path is an unbroken cycle@> + p = h; + do { + @<Fill in the control points between |p| and the next breakpoint, thenadvance |p| to that breakpoint@> + } while (p != h); + if (number_positive(internal_value(mp_tracing_choices_internal))) { + mp_print_path(mp, knots, ", after choices", 1); + } + if (mp->arith_error) { + @<Report an unexpected problem during the choice-making@> + } +} + +@ @<Internal ...@>= +void mp_make_choices (MP mp, mp_knot knots); + +@ @<Report an unexpected problem during the choice...@>= +mp_back_error( + mp, + "Some number got too big", + "The path that I just computed is out of range. So it will probably look funny.\n" + "Proceed, for a laugh." +); +@.Some number got too big@> +mp_get_x_next(mp); +mp->arith_error = 0; + +@ Two knots in a row with the same coordinates will always be joined by an +explicit \quote {curve} whose control points are identical with the knots. + +@<If consecutive knots are equal, join them explicitly@>= +p = knots; +do { + q = mp_next_knot(p); + if (number_equal(p->x_coord, q->x_coord) && number_equal(p->y_coord, q->y_coord) && mp_right_type(p) > mp_explicit_knot) { + mp_right_type(p) = mp_explicit_knot; + if (mp_left_type(p) == mp_open_knot) { + mp_left_type(p) = mp_curl_knot; + set_number_to_unity(p->left_curl); + } + mp_left_type(q) = mp_explicit_knot; + if (mp_right_type(q) == mp_open_knot) { + mp_right_type(q) = mp_curl_knot; + set_number_to_unity(q->right_curl); + } + number_clone(p->right_x, p->x_coord); + number_clone(q->left_x, p->x_coord); + number_clone(p->right_y, p->y_coord); + number_clone(q->left_y, p->y_coord); + } + p = q; +} while (p != knots); + +@ If there are no breakpoints, it is necessary to compute the direction angles +around an entire cycle. In this case the |mp_left_type| of the first node is +temporarily changed to |end_cycle|. + +@<Find the first breakpoint, |h|, on the path...@>= +h = knots; +while (1) { + if (mp_left_type(h) != mp_open_knot) { + break; + } else if (mp_right_type(h) != mp_open_knot) { + break; + } else { + h = mp_next_knot(h); + if (h == knots) { + mp_left_type(h) = mp_end_cycle_knot; + break; + } + } +} + +@ If |mp_right_type(p) < given| and |q = mp_link(p)|, we must have +|mp_right_type(p) = mp_left_type(q) = mp_explicit| or |endpoint|. + +@<Fill in the control points between |p| and the next breakpoint...@>= +q = mp_next_knot(p); +if (mp_right_type(p) >= mp_given_knot) { + while ((mp_left_type(q) == mp_open_knot) && (mp_right_type(q) == mp_open_knot)) { + q = mp_next_knot(q); + } + @<Fill in the control information between consecutive breakpoints |p| and |q|@> +} else if (mp_right_type(p) == mp_endpoint_knot) { + @<Give reasonable values for the unused control points between |p| and~|q|@> +} +p = q; + +@ This step makes it possible to transform an explicitly computed path without +checking the |mp_left_type| and |mp_right_type| fields. + +@<Give reasonable values for the unused control points between |p| and~|q|@>= +number_clone(p->right_x, p->x_coord); +number_clone(p->right_y, p->y_coord); +number_clone(q->left_x, q->x_coord); +number_clone(q->left_y, q->y_coord); + +@ Before we can go further into the way choices are made, we need to consider the +underlying theory. The basic ideas implemented in |make_choices| are due to John +Hobby, who introduced the notion of \quote {mock curvature} @^Hobby, John +Douglas@> at a knot. Angles are chosen so that they preserve mock curvature when +a knot is passed, and this has been found to produce excellent results. + +It is convenient to introduce some notations that simplify the necessary +formulas. Let $d_{k,k+1}=\vert z\k-z_k\vert$ be the (nonzero) distance between +knots |k| and |k+1|; and let + +$${z\k-z_k\over z_k-z_{k-1}}={d_{k,k+1}\over d_{k-1,k}}e^{i\psi_k}$$ + +so that a polygonal line from $z_{k-1}$ to $z_k$ to $z\k$ turns left through an +angle of~$\psi_k$. We assume that $\vert\psi_k\vert\L180^\circ$. The control +points for the spline from $z_k$ to $z\k$ will be denoted by + +$$\eqalign{z_k^+&=z_k+ \textstyle{1\over3}\rho_k e^{i\theta_k}(z\k-z_k),\cr +z\k^-&=z\k- \textstyle{1\over3}\sigma\k e^{-i\phi\k}(z\k-z_k),\cr}$$ + +where $\rho_k$ and $\sigma\k$ are nonnegative \quote {velocity ratios} at the +beginning and end of the curve, while $\theta_k$ and $\phi\k$ are the +corresponding \quote {offset angles.} These angles satisfy the condition + +$$\theta_k+\phi_k+\psi_k=0,\eqno(*)$$ + +whenever the curve leaves an intermediate knot~|k| in the direction that it +enters. + +@ Let $\alpha_k$ and $\beta\k$ be the reciprocals of the \quote {tension} of the curve +at its beginning and ending points. This means that $\rho_k=\alpha_k +f(\theta_k,\phi\k)$ and $\sigma\k=\beta\k f(\phi\k,\theta_k)$, where +$f(\theta,\phi)$ is \MP's standard velocity function defined in the |velocity| +subroutine. The cubic spline $B(z_k^{\phantom+},z_k^+, z\k^-,z\k^{\phantom+};t)$ +has curvature @^curvature@> + +$${2\sigma\k\sin(\theta_k+\phi\k)-6\sin\theta_k\over\rho_k^2d_{k,k+1}} \qquad{\rm +and}\qquad {2\rho_k\sin(\theta_k+\phi\k)-6\sin\phi\k\over\sigma\k^2d_{k,k+1}}$$ + +at |t=0| and |t=1|, respectively. The mock curvature is the linear @^mock +curvature@> approximation to this true curvature that arises in the limit for +small $\theta_k$ and~$\phi\k$, if second-order terms are discarded. The standard +velocity function satisfies $$f(\theta,\phi)=1+O(\theta^2+\theta\phi+\phi^2);$$ +hence the mock curvatures are respectively + +$${2\beta\k(\theta_k+\phi\k)-6\theta_k\over\alpha_k^2d_{k,k+1}} \qquad{\rm +and}\qquad +{2\alpha_k(\theta_k+\phi\k)-6\phi\k\over\beta\k^2d_{k,k+1}}.\eqno(**)$$ + +@ The turning angles $\psi_k$ are given, and equation $(*)$ above determines +$\phi_k$ when $\theta_k$ is known, so the task of angle selection is essentially +to choose appropriate values for each $\theta_k$. When equation~$(*)$ is used to +eliminate $\phi$~variables from $(**)$, we obtain a system of linear equations of +the form + +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ + +where + +$$A_k={\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, \qquad +B_k={3-\alpha_{k-1}\over\beta_k^2d_{k-1,k}}, \qquad +C_k={3-\beta\k\over\alpha_k^2d_{k,k+1}}, \qquad +D_k={\beta\k\over\alpha_k^2d_{k,k+1}}.$$ + +The tensions are always $3\over4$ or more, hence each $\alpha$ and~$\beta$ will +be at most $4\over3$. It follows that $B_k|5\over4|A_k$ and +$C_k|5\over4|D_k$; hence the equations are diagonally dominant; hence they have +a unique solution. Moreover, in most cases the tensions are equal to~1, so that +$B_k=2A_k$ and $C_k=2D_k$. This makes the solution numerically stable, and there +is an exponential damping effect: The data at knot $k\pm j$ affects the angle at +knot~$k$ by a factor of~$O(2^{-j})$. + +@ However, we still must consider the angles at the starting and ending knots of +a non-cyclic path. These angles might be given explicitly, or they might be +specified implicitly in terms of an amount of \quote {curl.} + +Let's assume that angles need to be determined for a non-cyclic path starting at +$z_0$ and ending at~$z_n$. Then equations of the form + +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta_{k+1}=R_k$$ + +have been given for +$0<k<n$, and it will be convenient to introduce equations of the same form for +$k=0$ and $k=n$, where + +$$A_0=B_0=C_n=D_n=0.$$ + +If $\theta_0$ is supposed to have a given value $E_0$, we simply define $C_0=1$, +$D_0=0$, and $R_0=E_0$. Otherwise a curl parameter, $\gamma_0$, has been +specified at~$z_0$; this means that the mock curvature at $z_0$ should be +$\gamma_0$ times the mock curvature at $z_1$; i.e., + +$${2\beta_1(\theta_0+\phi_1)-6\theta_0\over\alpha_0^2d_{01}} +=\gamma_0{2\alpha_0(\theta_0+\phi_1)-6\phi_1\over\beta_1^2d_{01}}.$$ + +This equation simplifies to + +$$(\alpha_0\chi_0+3-\beta_1)\theta_0+ +\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\theta_1= +-\bigl((3-\alpha_0)\chi_0+\beta_1\bigr)\psi_1,$$ + +where $\chi_0=\alpha_0^2\gamma_0/\beta_1^2$; so we can set $C_0= +\chi_0\alpha_0+3-\beta_1$, $D_0=(3-\alpha_0)\chi_0+\beta_1$, $R_0=-D_0\psi_1$. It +can be shown that $C_0>0$ and $C_0B_1-A_1D_0>0$ when $\gamma_0\G0$, hence the +linear equations remain nonsingular. + +Similar considerations apply at the right end, when the final angle $\phi_n$ may +or may not need to be determined. It is convenient to let $\psi_n=0$, hence +$\theta_n=-\phi_n$. We either have an explicit equation $\theta_n=E_n$, or we +have + +$$\bigl((3-\beta_n)\chi_n+\alpha_{n-1}\bigr)\theta_{n-1}+ +(\beta_n\chi_n+3-\alpha_{n-1})\theta_n=0,\qquad +\chi_n={\beta_n^2\gamma_n\over\alpha_{n-1}^2}.$$ + +When |make_choices| chooses angles, it must compute the coefficients of these +linear equations, then solve the equations. To compute the coefficients, it is +necessary to compute arctangents of the given turning angles~$\psi_k$. When the +equations are solved, the chosen directions $\theta_k$ are put back into the form +of control points by essentially computing sines and cosines. + +@ OK, we are ready to make the hard choices of |make_choices|. Most of the work +is relegated to an auxiliary procedure called |solve_choices|, which has been +introduced to keep |make_choices| from being extremely long. + +@<Fill in the control information between...@>= +@<FillInAllocate@> +@<Calculate the turning angles $\psi_k$ and the distances $d_{k,k+1}$; set $n$ to the length of the path@> +@<Remove |open| types at the breakpoints@> +@<FillInDeallocate@> +mp_solve_choices(mp, p, q, n); + +@ It's convenient to precompute quantities that will be needed several times +later. The values of |delta_x[k]| and |delta_y[k]| will be the coordinates of +$z\k-z_k$, and the magnitude of this vector will be |delta[k]=@t$d_{k,k+1}$@>|. +The path angle $\psi_k$ between $z_k-z_{k-1}$ and $z\k-z_k$ will be stored in +|psi[k]|. + +@<Glob...@>= +int path_size; /* maximum number of knots between breakpoints of a path */ +int path_padding; /* be nice */ + +mp_number *delta_x; +mp_number *delta_y; +mp_number *delta; /* knot differences */ +mp_number *psi; /* turning angles */ + +@ @<Dealloc variables@>= +for (int k = 0; k<mp->path_size; k++) { + free_number(mp->delta_x[k]); + free_number(mp->delta_y[k]); + free_number(mp->delta[k]); + free_number(mp->psi[k]); +} +mp_memory_free(mp->delta_x); +mp_memory_free(mp->delta_y); +mp_memory_free(mp->delta); +mp_memory_free(mp->psi); + +@ @<Other local variables for |make_choices|@>= +int k, n; /* current and final knot numbers */ +mp_knot s, t; /* registers for list traversal */ + +@ @<FillInAllocate@>= +mp_number sine, cosine; /* trig functions of various angles */ +mp_number arg1, arg2, r1, r2; +mp_number delx, dely; /* directions where |open| meets |explicit| */ +new_fraction(sine); +new_fraction(cosine); +new_number(arg1); +new_number(arg2); +new_fraction(r1); +new_fraction(r2); +new_number(delx); +new_number(dely); + +@ @<FillInDeallocate@>= +free_number(sine); +free_number(cosine); +free_number(arg1); +free_number(arg2); +free_number(r1); +free_number(r2); +free_number(delx); +free_number(dely); + +@ @<Calculate the turning angles...@>= +{ + RESTART: + k = 0; + s = p; + n = mp->path_size; + do { + t = mp_next_knot(s); + set_number_from_subtraction(mp->delta_x[k], t->x_coord, s->x_coord); + set_number_from_subtraction(mp->delta_y[k], t->y_coord, s->y_coord); + pyth_add(mp->delta[k], mp->delta_x[k], mp->delta_y[k]); + if (k > 0) { + make_fraction(r1, mp->delta_y[k - 1], mp->delta[k - 1]); + number_clone(sine, r1); + make_fraction(r2, mp->delta_x[k - 1], mp->delta[k - 1]); + number_clone(cosine, r2); + take_fraction(r1, mp->delta_x[k], cosine); + take_fraction(r2, mp->delta_y[k], sine); + set_number_from_addition(arg1, r1, r2); + take_fraction(r1, mp->delta_y[k], cosine); + take_fraction(r2, mp->delta_x[k], sine); + set_number_from_subtraction(arg2, r1, r2); + n_arg(mp->psi[k], arg1, arg2 ); + } + ++k; + s = t; + if (k == mp->path_size) { + mp_reallocate_paths(mp, mp->path_size + (mp->path_size / 4)); + goto RESTART; /* retry, loop size has changed */ + } else if (s == q) { + n = k; + } + } while (! ((k >= n) && (mp_left_type(s) != mp_end_cycle_knot))); + if (k == n) { + set_number_to_zero(mp->psi[k]); + } else { + number_clone(mp->psi[k], mp->psi[1]); + } +} + +@ When we get to this point of the code, |mp_right_type(p)| is either |given| or +|curl| or |open|. If it is |open|, we must have |mp_left_type(p)=mp_end_cycle| or +|mp_left_type(p)=mp_explicit|. In the latter case, the |open| type is converted +to |given|; however, if the velocity coming into this knot is zero, the |open| +type is converted to a |curl|, since we don't know the incoming direction. + +Similarly, |mp_left_type(q)| is either |given| or |curl| or |open| or +|mp_end_cycle|. The |open| possibility is reduced either to |given| or to |curl|. + +@<Remove |open| types at the breakpoints@>= +{ + if (mp_left_type(q) == mp_open_knot) { + set_number_from_subtraction(delx, q->right_x, q->x_coord); + set_number_from_subtraction(dely, q->right_y, q->y_coord); + if (number_zero(delx) && number_zero(dely)) { + mp_left_type(q) = mp_curl_knot; + set_number_to_unity(q->left_curl); + } else { + mp_left_type(q) = mp_given_knot; + n_arg(q->left_given, delx, dely); + } + } + if ((mp_right_type(p) == mp_open_knot) && (mp_left_type(p) == mp_explicit_knot)) { + set_number_from_subtraction(delx, p->x_coord, p->left_x); + set_number_from_subtraction(dely, p->y_coord, p->left_y); + if (number_zero(delx) && number_zero(dely)) { + mp_right_type(p) = mp_curl_knot; + set_number_to_unity(p->right_curl); + } else { + mp_right_type(p) = mp_given_knot; + n_arg(p->right_given, delx, dely); + } + } +} + +@ Linear equations need to be solved whenever |n>1|; and also when |n=1| and +exactly one of the breakpoints involves a curl. The simplest case occurs when +|n=1| and there is a curl at both breakpoints; then we simply draw a straight +line. + +But before coding up the simple cases, we might as well face the general case, +since we must deal with it sooner or later, and since the general case is likely +to give some insight into the way simple cases can be handled best. + +When there is no cycle, the linear equations to be solved form a tridiagonal +system, and we can apply the standard technique of Gaussian elimination to +convert that system to a sequence of equations of the form + +$$\theta_0+u_0\theta_1=v_0,\quad \theta_1+u_1\theta_2=v_1,\quad\ldots,\quad +\theta_{n-1}+u_{n-1}\theta_n=v_{n-1},\quad \theta_n=v_n.$$ + +It is possible to do this diagonalization while generating the equations. Once +$\theta_n$ is known, it is easy to determine $\theta_{n-1}$, \dots, $\theta_1$, +$\theta_0$; thus, the equations will be solved. + +The procedure is slightly more complex when there is a cycle, but the basic idea +will be nearly the same. In the cyclic case the right-hand sides will be +$v_k+w_k\theta_0$ instead of simply $v_k$, and we will start the process off with +$u_0=v_0=0$, $w_0=1$. The final equation will be not $\theta_n=v_n$ but +$\theta_n+u_n\theta_1=v_n+w_n\theta_0$; an appropriate ending routine will take +account of the fact that $\theta_n=\theta_0$ and eliminate the $w$'s from the +system, after which the solution can be obtained as before. + +When $u_k$, $v_k$, and $w_k$ are being computed, the three pointer variables |r|, +|s|,~|t| will point respectively to knots |k-1|, |k|, and~|k+1|. The $u$'s and +$w$'s are scaled by $2^{28}$, i.e., they are of type |fraction|; the $\theta$'s +and $v$'s are of type |angle|. + +@<Glob...@>= +mp_number *theta; /* values of $\theta_k$ */ +mp_number *uu; /* values of $u_k$ */ +mp_number *vv; /* values of $v_k$ */ +mp_number *ww; /* values of $w_k$ */ + +@ @<Dealloc variables@>= +for (int k = 0; k < mp->path_size; k++) { + free_number(mp->theta[k]); + free_number(mp->uu[k]); + free_number(mp->vv[k]); + free_number(mp->ww[k]); +} +mp_memory_free(mp->theta); +mp_memory_free(mp->uu); +mp_memory_free(mp->vv); +mp_memory_free(mp->ww); + +@ @<Declarations@>= +static void mp_reallocate_paths (MP mp, int l); + +@ @c +void mp_reallocate_paths (MP mp, int l) +{ + mp->delta_x = mp_memory_reallocate(mp->delta_x, (size_t) (l + 1) * sizeof(mp_number)); + mp->delta_y = mp_memory_reallocate(mp->delta_y, (size_t) (l + 1) * sizeof(mp_number)); + mp->delta = mp_memory_reallocate(mp->delta, (size_t) (l + 1) * sizeof(mp_number)); + mp->psi = mp_memory_reallocate(mp->psi, (size_t) (l + 1) * sizeof(mp_number)); + mp->theta = mp_memory_reallocate(mp->theta, (size_t) (l + 1) * sizeof(mp_number)); + mp->uu = mp_memory_reallocate(mp->uu, (size_t) (l + 1) * sizeof(mp_number)); + mp->vv = mp_memory_reallocate(mp->vv, (size_t) (l + 1) * sizeof(mp_number)); + mp->ww = mp_memory_reallocate(mp->ww, (size_t) (l + 1) * sizeof(mp_number)); + for (int k = mp->path_size; k<l; k++) { + new_number(mp->delta_x[k]); + new_number(mp->delta_y[k]); + new_number(mp->delta[k]); + new_angle(mp->psi[k]); + new_angle(mp->theta[k]); + new_fraction(mp->uu[k]); + new_angle(mp->vv[k]); + new_fraction(mp->ww[k]); + } + mp->path_size = l; +} + +@ Our immediate problem is to get the ball rolling by setting up the first +equation or by realizing that no equations are needed, and to fit this +initialization into a framework suitable for the overall computation. + +@<Declarations@>= +static void mp_solve_choices (MP mp, mp_knot p, mp_knot q, int n); + +@ @c +void mp_solve_choices (MP mp, mp_knot p, mp_knot q, int n) +{ + int k = 0; /* current knot number */ + mp_knot r = 0; + mp_knot s = p; + mp_number ff; + new_fraction(ff); + while (1) { + mp_knot t = mp_next_knot(s); + if (k == 0) { + @<Get the linear equations started; or |return| with the control points in place, if linear equations needn't be solved@> + } else { + switch (mp_left_type(s)) { + case mp_end_cycle_knot: + case mp_open_knot: + @<Set up the equation to match mock curvatures at $z_k$; then |goto found| with $\theta_n$ adjusted to equal $\theta_0$, if a cycle has ended@> + break; + case mp_curl_knot: + @<Set up the equation for a curl at $\theta_n$ and |goto found|@> + break; + case mp_given_knot: + @<Calculate the given value of $\theta_n$ and |goto found|@> + break; + } + } + r = s; + s = t; + ++k; + } +FOUND: + @<Finish choosing angles and assigning control points@> + free_number(ff); +} + +@ On the first time through the loop, we have |k=0| and |r| is not yet defined. +The first linear equation, if any, will have $A_0=B_0=0$. + +@<Get the linear equations started...@>= +switch (mp_right_type(s)) { + case mp_given_knot: + if (mp_left_type(t) == mp_given_knot) { + @<Reduce to simple case of two givens and |return|@> + } else { + @<Set up the equation for a given value of $\theta_0$@> + } + break; + case mp_curl_knot: + if (mp_left_type(t) == mp_curl_knot) { + @<Reduce to simple case of straight line and |return|@> + } else { + @<Set up the equation for a curl at $\theta_0$@> + } + break; + case mp_open_knot: + set_number_to_zero(mp->uu[0]); + set_number_to_zero(mp->vv[0]); + number_clone(mp->ww[0], fraction_one_t); + /* this begins a cycle */ + break; +} + +@ The general equation that specifies equality of mock curvature at $z_k$ is + +$$A_k\theta_{k-1}+(B_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k,$$ + +as derived above. We want to combine this with the already-derived equation +$\theta_{k-1}+u_{k-1}\theta_k=v_{k-1}+w_{k-1}\theta_0$ in order to obtain a new +equation $\theta_k+u_k\theta\k=v_k+w_k\theta_0$. This can be done by dividing the +equation + +$$(B_k-u_{k-1}A_k+C_k)\theta_k+D_k\theta\k=-B_k\psi_k-D_k\psi\k-A_kv_{k-1} +-A_kw_{k-1}\theta_0$$ + +by $B_k-u_{k-1}A_k+C_k$. The trick is to do this carefully with fixed-point +arithmetic, avoiding the chance of overflow while retaining suitable precision. + +The calculations will be performed in several registers that provide temporary +storage for intermediate quantities. + +@ @<Set up the equation to match mock curvatures...@>= +{ + mp_number aa, bb, cc, acc; /* temporary registers */ + mp_number dd, ee; /* likewise, but |scaled| */ + new_fraction(aa); + new_fraction(bb); + new_fraction(cc); + new_fraction(acc); + new_number(dd); + new_number(ee); + @<Calculate the values $|aa|=A_k/B_k$, $|bb|=D_k/C_k$, $|dd|=(3-\alpha_{k-1})d_{k,k+1}$, $|ee|=(3-\beta\k)d_{k-1,k}$, and $|cc|=(B_k-u_{k-1}A_k)/B_k$@> + @<Calculate the ratio $|ff|=C_k/(C_k+B_k-u_{k-1}A_k)$@> + take_fraction(mp->uu[k], ff, bb); + @<Calculate the values of $v_k$ and $w_k$@> + if (mp_left_type(s) == mp_end_cycle_knot) { + @<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@> + } + free_number(aa); + free_number(bb); + free_number(cc); + free_number(acc); + free_number(dd); + free_number(ee); +} + +@ Since tension values are never less than 3/4, the values |aa| and |bb| computed +here are never more than 4/5. + +@<Calculate the values $|aa|=...@>= +{ + mp_number absval; + new_number_abs(absval, r->right_tension); + if (number_equal(absval, unity_t)) { + number_clone(aa, fraction_half_t); + number_clone(dd, mp->delta[k]); + number_double(dd); + } else { + mp_number arg1, arg2, ret; + new_number(arg1); + new_number_abs(arg2, r->right_tension); + number_multiply_int(arg2, 3); + number_subtract(arg2, unity_t); + make_fraction(aa, unity_t, arg2); + number_abs_clone(arg2, r->right_tension); + new_fraction(ret); + make_fraction(ret, unity_t, arg2); + set_number_from_subtraction(arg1, fraction_three_t, ret); + take_fraction(arg2, mp->delta[k], arg1); + number_clone(dd, arg2); + free_number(ret); + free_number(arg1); + free_number(arg2); + } + number_abs_clone(absval, t->left_tension); + if (number_equal(absval, unity_t)) { + number_clone(bb, fraction_half_t); + number_clone(ee, mp->delta[k - 1]); + number_double(ee); + } else { + mp_number arg1, arg2, ret; + new_number(arg1); + new_number_abs(arg2, t->left_tension); + number_multiply_int(arg2, 3); + number_subtract(arg2, unity_t); + make_fraction(bb, unity_t, arg2); + number_abs_clone(arg2, t->left_tension); + new_fraction(ret); + make_fraction(ret, unity_t, arg2); + set_number_from_subtraction(arg1, fraction_three_t, ret); + take_fraction(ee, mp->delta[k - 1], arg1); + free_number(ret); + free_number(arg1); + free_number(arg2); + } + free_number(absval); +} +{ + mp_number r1; + new_number(r1); + take_fraction(r1, mp->uu[k - 1], aa); + set_number_from_subtraction(cc, fraction_one_t, r1); + free_number(r1); +} + +@ The ratio to be calculated in this step can be written in the form + +$$\beta_k^2\cdot|ee|\over\beta_k^2\cdot|ee|+\alpha_k^2\cdot +|cc|\cdot|dd|,$$ + +because of the quantities just calculated. The values of |dd| and |ee| will not +be needed after this step has been performed. + +@<Calculate the ratio $|ff|=C_k/(C_k+B_k-u_{k-1}A_k)$@>= +{ + mp_number rt, lt; + mp_number arg2; + new_number_clone(arg2, dd); + take_fraction(dd, arg2, cc); + new_number_abs(lt, s->left_tension); + new_number_abs(rt, s->right_tension); + if (! number_equal(lt, rt)) { + /* $\beta_k^{-1}\ne\alpha_k^{-1}$ */ + mp_number r1; + new_number(r1); + if (number_less(lt, rt)) { + /* $\alpha_k^2/\beta_k^2$ */ + make_fraction(r1, lt, rt); + take_fraction(ff, r1, r1); + number_clone(r1, dd); + take_fraction(dd, r1, ff); + } else { + /* $\beta_k^2/\alpha_k^2$ */ + make_fraction(r1, rt, lt); + take_fraction(ff, r1, r1); + number_clone(r1, ee); + take_fraction(ee, r1, ff); + } + free_number(r1); + } + free_number(rt); + free_number(lt); + set_number_from_addition(arg2, dd, ee); + make_fraction(ff, ee, arg2); + free_number(arg2); +} + +@ The value of $u_{k-1}$ will be |<=1| except when $k=1$ and the previous +equation was specified by a curl. In that case we must use a special method of +computation to prevent overflow. + +Fortunately, the calculations turn out to be even simpler in this \quote {hard} case. +The curl equation makes $w_0=0$ and $v_0=-u_0\psi_1$, hence +$-B_1\psi_1-A_1v_0=-(B_1-u_0A_1)\psi_1=-|cc|\cdot B_1\psi_1$. + +@<Calculate the values of $v_k$ and $w_k$@>= +take_fraction(acc, mp->psi[k + 1], mp->uu[k]); +number_negate(acc); +if (mp_right_type(r) == mp_curl_knot) { + mp_number r1, arg2; + new_fraction(r1); + new_number(arg2); + set_number_from_subtraction(arg2, fraction_one_t, ff); + take_fraction(r1, mp->psi[1], arg2); + set_number_to_zero(mp->ww[k]); + set_number_from_subtraction(mp->vv[k], acc, r1); + free_number(r1); + free_number(arg2); +} else { + mp_number arg1, r1; + new_fraction(r1); + new_number(arg1); + set_number_from_subtraction(arg1, fraction_one_t, ff); + /* this is $B_k/(C_k+B_k-u_{k-1}A_k)<5$ */ + make_fraction(ff, arg1, cc); + free_number(arg1); + take_fraction(r1, mp->psi[k], ff); + number_subtract(acc, r1); + number_clone(r1, ff); + /* this is $A_k/(C_k+B_k-u_{k-1}A_k)$ */ + take_fraction(ff, r1, aa); + take_fraction(r1, mp->vv[k - 1], ff); + set_number_from_subtraction(mp->vv[k], acc, r1 ); + if (number_zero(mp->ww[k - 1])) { + set_number_to_zero(mp->ww[k]); + } else { + take_fraction(mp->ww[k], mp->ww[k - 1], ff); + number_negate(mp->ww[k]); + } + free_number(r1); +} + +@ When a complete cycle has been traversed, we have $\theta_k+u_k\theta\k= +v_k+w_k\theta_0$, for |1<=k<=n|. We would like to determine the value of +$\theta_n$ and reduce the system to the form $\theta_k+u_k\theta\k=v_k$ for +|0<=k<n|, so that the cyclic case can be finished up just as if there were no +cycle. + +The idea in the following code is to observe that + +$$\eqalign{\theta_n&=v_n+w_n\theta_0-u_n\theta_1=\cdots\cr +&=v_n+w_n\theta_0-u_n\bigl(v_1+w_1\theta_0-u_1(v_2+\cdots +-u_{n-2}(v_{n-1}+w_{n-1}\theta_0-u_{n-1}\theta_0))\bigr),\cr}$$ + +so we can solve for $\theta_n=\theta_0$. + +@<Adjust $\theta_n$ to equal $\theta_0$ and |goto found|@>= +mp_number arg2, r1; +new_number(arg2); +new_number(r1); +set_number_to_zero(aa); +number_clone(bb, fraction_one_t); /* we have |k=n| */ +do { + --k; + if (k == 0) { + k = n; + } + take_fraction(r1, aa, mp->uu[k]); + set_number_from_subtraction(aa, mp->vv[k], r1); + take_fraction(r1, bb, mp->uu[k]); + set_number_from_subtraction(bb, mp->ww[k], r1); +} while (k != n); +/* now $\theta_n=|aa|+|bb|\cdot\theta_n$ */ +set_number_from_subtraction(arg2, fraction_one_t, bb); +make_fraction(r1, aa, arg2); +number_clone(aa, r1); +number_clone(mp->theta[n], aa); +number_clone(mp->vv[0], aa); +for (k = 1; k < n; k++) { + take_fraction(r1, aa, mp->ww[k]); + number_add(mp->vv[k], r1); +} +free_number(arg2); +free_number(r1); +free_number(aa); +free_number(bb); +free_number(cc); +free_number(acc); +free_number(dd); +free_number(ee); +goto FOUND; + +@ @c +static void mp_reduce_angle (MP mp, mp_number *a) +{ + mp_number abs_a; + new_number_abs(abs_a, *a); + if (number_greater(abs_a, one_eighty_deg_t)) { + if (number_positive(*a)) { + number_subtract(*a, three_sixty_deg_t); + } else { + number_add(*a, three_sixty_deg_t); + } + } + free_number(abs_a); +} + +@ @<Declarations@>= +static void mp_reduce_angle (MP mp, mp_number *a); + +@ @<Calculate the given value of $\theta_n$...@>= +{ + mp_number narg; + new_angle(narg); + n_arg(narg, mp->delta_x[n - 1], mp->delta_y[n - 1]); + set_number_from_subtraction(mp->theta[n], s->left_given, narg); + free_number(narg); + mp_reduce_angle(mp, &mp->theta[n]); + goto FOUND; +} + +@ @<Set up the equation for a given value of $\theta_0$@>= +{ + mp_number narg; + new_angle(narg); + n_arg(narg, mp->delta_x[0], mp->delta_y[0]); + set_number_from_subtraction(mp->vv[0], s->right_given, narg); + free_number(narg); + mp_reduce_angle(mp, &mp->vv[0]); + set_number_to_zero(mp->uu[0]); + set_number_to_zero(mp->ww[0]); +} + +@ @<Set up the equation for a curl at $\theta_0$@>= +{ + mp_number lt, rt, cc; /* tension values */ + new_number_clone(cc, s->right_curl); + new_number_abs(lt, t->left_tension); + new_number_abs(rt, s->right_tension); + if (number_unity(rt) && number_unity(lt)) { + mp_number arg1, arg2; + new_number_clone(arg1, cc); + new_number_clone(arg2, cc); + number_double(arg1); + number_add(arg1, unity_t); + number_add(arg2, two_t); + make_fraction(mp->uu[0], arg1, arg2); + free_number(arg1); + free_number(arg2); + } else { + mp_curl_ratio(mp, &mp->uu[0], &cc, &rt, <); + } + take_fraction(mp->vv[0], mp->psi[1], mp->uu[0]); + number_negate(mp->vv[0]); + set_number_to_zero(mp->ww[0]); + free_number(rt); + free_number(lt); + free_number(cc); +} + +@ @<Set up the equation for a curl at $\theta_n$...@>= +{ + mp_number lt, rt, cc; /* tension values */ + new_number_clone(cc, s->left_curl); + new_number_abs(lt, s->left_tension); + new_number_abs(rt, r->right_tension); + if (number_unity(rt) && number_unity(lt)) { + mp_number arg1, arg2; + new_number_clone(arg1, cc); + new_number_clone(arg2, cc); + number_double(arg1); + number_add(arg1, unity_t); + number_add(arg2, two_t); + make_fraction(ff, arg1, arg2); + free_number(arg1); + free_number(arg2); + } else { + mp_curl_ratio(mp, &ff, &cc, <, &rt); + } + { + mp_number arg1, arg2, r1; + new_fraction(r1); + new_fraction(arg1); + new_number(arg2); + take_fraction(arg1, mp->vv[n - 1], ff); + take_fraction(r1, ff, mp->uu[n - 1]); + set_number_from_subtraction(arg2, fraction_one_t, r1); + make_fraction(mp->theta[n], arg1, arg2); + number_negate(mp->theta[n]); + free_number(r1); + free_number(arg1); + free_number(arg2); + } + free_number(rt); + free_number(lt); + free_number(cc); + goto FOUND; +} + +@ The |curl_ratio| subroutine has three arguments, which our previous notation +encourages us to call $\gamma$, $\alpha^{-1}$, and $\beta^{-1}$. It is a somewhat +tedious program to calculate + +$${(3-\alpha)\alpha^2\gamma+\beta^3\over \alpha^3\gamma+(3-\beta)\beta^2},$$ + +with the result reduced to 4 if it exceeds 4. (This reduction of curl is +necessary only if the curl and tension are both large.) The values of $\alpha$ +and $\beta$ will be at most~4/3. + +@<Declarations@>= +static void mp_curl_ratio (MP mp, mp_number *ret, mp_number *gamma, mp_number *a_tension, mp_number *b_tension); + +@ @c +void mp_curl_ratio (MP mp, mp_number *ret, mp_number *gamma_orig, mp_number *a_tension, mp_number *b_tension) +{ + mp_number alpha, beta, gamma, num, denom, ff; /* registers */ + mp_number arg1; + new_number(arg1); + new_fraction(alpha); + new_fraction(beta); + new_fraction(gamma); + new_fraction(ff); + new_fraction(denom); + new_fraction(num); + make_fraction(alpha, unity_t, *a_tension); + make_fraction(beta, unity_t, *b_tension); + number_clone(gamma, *gamma_orig); + if (number_lessequal(alpha, beta)) { + make_fraction(ff, alpha, beta); + number_clone(arg1, ff); + take_fraction(ff, arg1, arg1); + number_clone(arg1, gamma); + take_fraction(gamma, arg1, ff); + convert_fraction_to_scaled(beta); + take_fraction(denom, gamma, alpha); + number_add(denom, three_t); + } else { + make_fraction(ff, beta, alpha); + number_clone(arg1, ff); + take_fraction(ff, arg1, arg1); + take_fraction(arg1, beta, ff); + convert_fraction_to_scaled(arg1); + number_clone(beta, arg1); + take_fraction(denom, gamma, alpha); + set_number_from_div(arg1, ff, twelvebits_3); + number_add(denom, arg1); + } + number_subtract(denom, beta); + set_number_from_subtraction(arg1, fraction_three_t, alpha); + take_fraction(num, gamma, arg1); + number_add(num, beta); + number_clone(arg1, denom); + number_double(arg1); + number_double(arg1); /* arg1 = 4*denom */ + if (number_greaterequal(num, arg1)) { + number_clone(*ret, fraction_four_t); + } else { + make_fraction(*ret, num, denom); + } + free_number(alpha); + free_number(beta); + free_number(gamma); + free_number(num); + free_number(denom); + free_number(ff); + free_number(arg1); +} + +@ We're in the home stretch now. + +@<Finish choosing angles and assigning control points@>= +{ + mp_number r1; + new_number(r1); + for (k = n - 1; k >= 0; k--) { + take_fraction(r1, mp->theta[k + 1], mp->uu[k]); + set_number_from_subtraction(mp->theta[k], mp->vv[k], r1); + } + free_number(r1); +} +s = p; +k = 0; +{ + mp_number arg; + new_number(arg); + do { + mp_knot t = mp_next_knot(s); + n_sin_cos(mp->theta[k], mp->ct, mp->st); + number_negated_clone(arg, mp->psi[k + 1]); + number_subtract(arg, mp->theta[k + 1]); + n_sin_cos(arg, mp->cf, mp->sf); + mp_set_controls (mp, s, t, k); + ++k; + s = t; + } while (k != n); + free_number(arg); +} + +@ The |set_controls| routine actually puts the control points into a pair of +consecutive nodes |p| and~|q|. Global variables are used to record the values of +$\sin\theta$, $\cos\theta$, $\sin\phi$, and $\cos\phi$ needed in this +calculation. + +@<Glob...@>= +mp_number st; +mp_number ct; +mp_number sf; +mp_number cf; /* sines and cosines */ + +@ @<Initialize table...@>= +new_fraction(mp->st); +new_fraction(mp->ct); +new_fraction(mp->sf); +new_fraction(mp->cf); + +@ @<Dealloc ...@>= +free_number(mp->st); +free_number(mp->ct); +free_number(mp->sf); +free_number(mp->cf); + +@ @<Declarations@>= +static void mp_set_controls (MP mp, mp_knot p, mp_knot q, int k); + +@ @c +void mp_set_controls (MP mp, mp_knot p, mp_knot q, int k) +{ + mp_number rr, ss; /* velocities, divided by thrice the tension */ + mp_number lt, rt; /* tensions */ + mp_number sine; /* $\sin(\theta+\phi)$ */ + mp_number tmp; + mp_number r1, r2; + new_number(tmp); + new_number(r1); + new_number(r2); + new_number_abs(lt, q->left_tension); + new_number_abs(rt, p->right_tension); + new_fraction(sine); + new_fraction(rr); + new_fraction(ss); + velocity(rr, mp->st, mp->ct, mp->sf, mp->cf, rt); + velocity(ss, mp->sf, mp->cf, mp->st, mp->ct, lt); + if (number_negative(p->right_tension) || number_negative(q->left_tension)) { + @<Decrease the velocities, if necessary, to stay inside the bounding triangle@> + } + take_fraction(r1, mp->delta_x [k], mp->ct); + take_fraction(r2, mp->delta_y [k], mp->st); + number_subtract(r1, r2); + take_fraction(tmp, r1, rr); + set_number_from_addition(p->right_x, p->x_coord, tmp); + take_fraction(r1, mp->delta_y[k], mp->ct); + take_fraction(r2, mp->delta_x[k], mp->st); + number_add(r1, r2); + take_fraction(tmp, r1, rr); + set_number_from_addition(p->right_y, p->y_coord, tmp); + take_fraction(r1, mp->delta_x[k], mp->cf); + take_fraction(r2, mp->delta_y[k], mp->sf); + number_add(r1, r2); + take_fraction(tmp, r1, ss); + set_number_from_subtraction(q->left_x, q->x_coord, tmp); + take_fraction(r1, mp->delta_y[k], mp->cf); + take_fraction(r2, mp->delta_x[k], mp->sf); + number_subtract(r1, r2); + take_fraction(tmp, r1, ss); + set_number_from_subtraction(q->left_y, q->y_coord, tmp); + mp_right_type(p) = mp_explicit_knot; + mp_left_type(q) = mp_explicit_knot; + free_number(tmp); + free_number(r1); + free_number(r2); + free_number(lt); + free_number(rt); + free_number(rr); + free_number(ss); + free_number(sine); +} + +@ The boundedness conditions $|rr|\L\sin\phi\,/\sin(\theta+\phi)$ and +$|ss|\L\sin\theta\,/\sin(\theta+\phi)$ are to be enforced if $\sin\theta$, +$\sin\phi$, and $\sin(\theta+\phi)$ all have the same sign. Otherwise there is no +\quote {bounding triangle.} + +@<Decrease the velocities, if necessary...@>= +if ((number_nonnegative(mp->st) && number_nonnegative(mp->sf)) || (number_nonpositive(mp->st) && number_nonpositive(mp->sf))) { + mp_number r1, r2, arg1; + new_fraction(r1); + new_fraction(r2); + new_number_abs(arg1, mp->st); + take_fraction(r1, arg1, mp->cf); + number_abs_clone(arg1, mp->sf); + take_fraction(r2, arg1, mp->ct); + set_number_from_addition(sine, r1, r2); + if (number_positive(sine)) { + set_number_from_addition(arg1, fraction_one_t, unity_t); /* safety factor */ + number_clone(r1, sine); + take_fraction(sine, r1, arg1); + if (number_negative(p->right_tension)) { + number_abs_clone(arg1, mp->sf); + if (ab_vs_cd(arg1, fraction_one_t, rr, sine) < 0) { + number_abs_clone(arg1, mp->sf); + make_fraction(rr, arg1, sine); + } + } + if (number_negative(q->left_tension)) { + number_abs_clone(arg1, mp->st); + if (ab_vs_cd(arg1, fraction_one_t, ss, sine) < 0) { + number_abs_clone(arg1, mp->st); + make_fraction(ss, arg1, sine); + } + } + } + free_number(arg1); + free_number(r1); + free_number(r2); +} + +@ Only the simple cases remain to be handled. + +@<Reduce to simple case of two givens and |return|@>= +{ + mp_number arg1; + mp_number narg; + new_angle(narg); + n_arg(narg, mp->delta_x[0], mp->delta_y[0]); + new_number(arg1); + set_number_from_subtraction(arg1, p->right_given, narg); + n_sin_cos(arg1, mp->ct, mp->st); + set_number_from_subtraction(arg1, q->left_given, narg); + n_sin_cos(arg1, mp->cf, mp->sf); + number_negate(mp->sf); + mp_set_controls (mp, p, q, 0); + free_number(narg); + free_number(arg1); + free_number(ff); + return; +} + +@ @<Reduce to simple case of straight line and |return|@>= +{ + mp_number lt, rt; /* tension values */ + mp_right_type(p) = mp_explicit_knot; + mp_left_type(q) = mp_explicit_knot; + new_number_abs(lt, q->left_tension); + new_number_abs(rt, p->right_tension); + if (number_unity(rt)) { + mp_number arg2; + new_number(arg2); + if (number_nonnegative(mp->delta_x[0])) { + set_number_from_addition(arg2, mp->delta_x[0], epsilon_t); + } else { + set_number_from_subtraction(arg2, mp->delta_x[0], epsilon_t); + } + number_int_div(arg2, 3); + set_number_from_addition(p->right_x, p->x_coord, arg2); + if (number_nonnegative(mp->delta_y[0])) { + set_number_from_addition(arg2, mp->delta_y[0], epsilon_t); + } else { + set_number_from_subtraction(arg2, mp->delta_y[0], epsilon_t); + } + number_int_div(arg2, 3); + set_number_from_addition(p->right_y, p->y_coord, arg2); + free_number(arg2); + } else { + mp_number arg2, r1; + new_fraction(r1); + new_number_clone(arg2, rt); + number_multiply_int(arg2, 3); + make_fraction(ff, unity_t, arg2); /* $\alpha/3$ */ + free_number(arg2); + take_fraction(r1, mp->delta_x[0], ff); + set_number_from_addition(p->right_x, p->x_coord, r1); + take_fraction(r1, mp->delta_y[0], ff); + set_number_from_addition(p->right_y, p->y_coord, r1); + } + if (number_unity(lt)) { + mp_number arg2; + new_number(arg2); + if (number_nonnegative(mp->delta_x[0])) { + set_number_from_addition(arg2, mp->delta_x[0], epsilon_t); + } else { + set_number_from_subtraction(arg2, mp->delta_x[0], epsilon_t); + } + number_int_div(arg2, 3); + set_number_from_subtraction(q->left_x, q->x_coord, arg2); + if (number_nonnegative(mp->delta_y[0])) { + set_number_from_addition(arg2, mp->delta_y[0], epsilon_t); + } else { + set_number_from_subtraction(arg2, mp->delta_y[0], epsilon_t); + } + number_int_div(arg2, 3); + set_number_from_subtraction(q->left_y, q->y_coord, arg2); + free_number(arg2); + } else { + mp_number arg2, r1; + new_fraction(r1); + new_number_clone(arg2, lt); + number_multiply_int(arg2, 3); + make_fraction(ff, unity_t, arg2); /* $\beta/3$ */ + free_number(arg2); + take_fraction(r1, mp->delta_x[0], ff); + set_number_from_subtraction(q->left_x, q->x_coord, r1); + take_fraction(r1, mp->delta_y[0], ff); + set_number_from_subtraction(q->left_y, q->y_coord, r1); + free_number(r1); + } + free_number(ff); + free_number(lt); + free_number(rt); + return; +} + +@ Various subroutines that are useful for the new (1.770) exported api for +solving path choices + +@c +# define TOO_LARGE(a) (fabs((a))>4096.0) +# define PI 3.1415926535897932384626433832795028841971 + +static int out_of_range (MP mp, double a) +{ + (void) mp; + mp_number t; + new_number_from_double(mp, t, fabs(a)); + if (number_greaterequal(t, inf_t)) { + free_number(t); + return 1; + } else { + free_number(t); + return 0; + } +} + +static int mp_link_knotpair (MP mp, mp_knot p, mp_knot q) +{ + (void) mp; + if (p == NULL || q == NULL) { + return 0; + } else { + mp_prev_knot(q) = p; + mp_next_knot(p) = q; + set_number_from_double(p->right_tension, 1.0); + if (mp_right_type(p) == mp_endpoint_knot) { + mp_right_type(p) = mp_open_knot; + } + set_number_from_double(q->left_tension, 1.0); + if (mp_left_type(q) == mp_endpoint_knot) { + mp_left_type(q) = mp_open_knot; + } + return 1; + } +} + +static int mp_link_knotpair_xy (MP mp, mp_knot p, mp_knot q) +{ + (void) mp; + if (p == NULL || q == NULL) { + return 0; + } else { + mp_prev_knot(q) = p; + mp_next_knot(p) = q; + return 1; + } +} + +int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q) +{ + return mp_link_knotpair(mp, p, q); +} + +int mp_close_path (MP mp, mp_knot q, mp_knot first) +{ + if (q == NULL || first == NULL) { + return 0; + } else { + mp_prev_knot(first) = q; + mp_next_knot(q) = first; + mp_right_type(q) = mp_endpoint_knot; + set_number_from_double(q->right_tension, 1.0); + mp_left_type(first) = mp_endpoint_knot; + set_number_from_double(first->left_tension, 1.0); + return 1; + } +} + +mp_knot mp_create_knot (MP mp) +{ + mp_knot q = mp_new_knot(mp); + mp_left_type(q) = mp_endpoint_knot; + mp_right_type(q) = mp_endpoint_knot; + return q; +} + +int mp_set_knot (MP mp, mp_knot p, double x, double y) +{ + if (p == NULL) { + return 0; + } else if (out_of_range(mp, x)) { + return 0; + } else if (out_of_range(mp, y)) { + return 0; + } else { + set_number_from_double(p->x_coord, x); + set_number_from_double(p->y_coord, y); + return 1; + } +} + +mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y) +{ + mp_knot q = mp_create_knot(mp); + if (q == NULL) { + return NULL; + } else if (! mp_set_knot(mp, q, x, y)) { + mp_memory_free(q); + return NULL; + } else if (p == NULL) { + return q; + } else if (mp_link_knotpair(mp, p, q)) { + return q; + } else { + mp_memory_free(q); + return NULL; + } +} + +mp_knot mp_append_knot_xy (MP mp, mp_knot p, double x, double y) +{ + mp_knot q = mp_create_knot(mp); + if (q == NULL) { + return NULL; + } else if (! mp_set_knot(mp, q, x, y)) { + mp_memory_free(q); + return NULL; + } else if (p == NULL) { + return q; + } else if (mp_link_knotpair_xy(mp, p, q)) { + mp_right_type(p) = mp_explicit_knot; + mp_left_type(p) = mp_explicit_knot; + return q; + } else { + mp_memory_free(q); + return NULL; + } +} + +int mp_set_knot_curl (MP mp, mp_knot q, double value) /* same as mp_set_knot_right_curl */ +{ + if (q == NULL) { + return 0; + } else if (TOO_LARGE(value)) { + return 0; + } else { + mp_right_type(q) = mp_curl_knot; + set_number_from_double(q->right_curl, value); + if (mp_left_type(q) == mp_open_knot) { + mp_left_type(q) = mp_curl_knot; + set_number_from_double(q->left_curl, value); + } + return 1; + } +} + +int mp_set_knot_left_curl (MP mp, mp_knot q, double value) +{ + if (q == NULL) { + return 0; + } else if (TOO_LARGE(value)) { + return 0; + } else { + mp_left_type(q) = mp_curl_knot; + set_number_from_double(q->left_curl, value); + if (mp_right_type(q) == mp_open_knot) { + mp_right_type(q) = mp_curl_knot; + set_number_from_double(q->right_curl, value); + } + return 1; + } +} + +int mp_set_knot_right_curl (MP mp, mp_knot q, double value) +{ + if (q == NULL) { + return 0; + } else if (TOO_LARGE(value)) { + return 0; + } else { + mp_right_type(q) = mp_curl_knot; + set_number_from_double(q->right_curl, value); + if (mp_left_type(q) == mp_open_knot) { + mp_left_type(q) = mp_curl_knot; + set_number_from_double(q->left_curl, value); + } + return 1; + } +} + +int mp_set_knot_simple_curl (MP mp, mp_knot q) +{ + if (q == NULL) { + return 0; + } else { + /* no need for double */ + mp_right_type(q) = mp_curl_knot; + set_number_from_double(q->right_curl, 1.0); + mp_left_type(q) = mp_curl_knot; + set_number_from_double(q->left_curl, 1.0); + return 1; + } +} + +int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) +{ + if (p == NULL || q == NULL) { + return 0; + } else if (mp_set_knot_curl(mp, p, t1)) { + return mp_set_knot_curl(mp, q, t2); + } else { + return 0; + } +} + +int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) +{ + if (p == NULL || q == NULL) { + return 0; + } else if (TOO_LARGE(t1)) { + return 0; + } else if (TOO_LARGE(t2)) { + return 0; + } else if ((fabs(t1) < 0.75)) { + return 0; + } else if ((fabs(t2) < 0.75)) { + return 0; + } else { + set_number_from_double(p->right_tension, t1); + set_number_from_double(q->left_tension, t2); + return 1; + } +} + +int mp_set_knot_left_tension (MP mp, mp_knot p, double t1) +{ + if (p == NULL) { + return 0; + } else if (TOO_LARGE(t1)) { + return 0; + } else if ((fabs(t1) < 0.75)) { + return 0; + } else { + set_number_from_double(p->left_tension, t1); + return 1; + } +} + +int mp_set_knot_right_tension (MP mp, mp_knot p, double t1) +{ + if (p == NULL) { + return 0; + } else if (TOO_LARGE(t1)) { + return 0; + } else if ((fabs(t1) < 0.75)) { + return 0; + } else { + set_number_from_double(p->right_tension, t1); + return 1; + } +} + +int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) +{ + if (p == NULL || q == NULL) { + return 0; + } else if (out_of_range(mp, x1)) { + return 0; + } else if (out_of_range(mp, y1)) { + return 0; + } else if (out_of_range(mp, x2)) { + return 0; + } else if (out_of_range(mp, y2)) { + return 0; + } else { + mp_right_type(p) = mp_explicit_knot; + set_number_from_double(p->right_x, x1); + set_number_from_double(p->right_y, y1); + mp_left_type(q) = mp_explicit_knot; + set_number_from_double(q->left_x, x2); + set_number_from_double(q->left_y, y2); + return 1; + } +} + +int mp_set_knot_left_control (MP mp, mp_knot p, double x1, double y1) +{ + if (p == NULL) { + return 0; + } else if (out_of_range(mp, x1)) { + return 0; + } else if (out_of_range(mp, y1)) { + return 0; + } else { + mp_left_type(p) = mp_explicit_knot; + set_number_from_double(p->left_x, x1); + set_number_from_double(p->left_y, y1); + return 1; + } +} + +int mp_set_knot_right_control (MP mp, mp_knot p, double x1, double y1) +{ + if (p == NULL) { + return 0; + } else if (out_of_range(mp, x1)) { + return 0; + } else if (out_of_range(mp, y1)) { + return 0; + } else { + mp_right_type(p) = mp_explicit_knot; + set_number_from_double(p->right_x, x1); + set_number_from_double(p->right_y, y1); + return 1; + } +} + +int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) +{ + if (q == NULL) { + return 0; + } else if (TOO_LARGE(x)) { + return 0; + } else if (TOO_LARGE(y)) { + return 0; + } else { + double value = 0; + if (!(x == 0 && y == 0)) { + value = atan2(y, x) * (180.0 / PI) * 16.0; + } + mp_right_type(q) = mp_given_knot; + set_number_from_double(q->right_curl, value); + if (mp_left_type(q) == mp_open_knot) { + mp_left_type(q) = mp_given_knot; + set_number_from_double(q->left_curl, value); + } + return 1; + } +} + +int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) +{ + if (p == NULL || q == NULL) { + return 0; + } else if (mp_set_knot_direction(mp,p, x1, y1)) { + return mp_set_knot_direction(mp,q, x2, y2); + } else { + return 0; + } +} + +@ @c +static int path_needs_fixing(mp_knot source) +{ + mp_knot sourcehead = source; + do { + source = source->next; + } while (source && source != sourcehead); + if (! source) { + return 1; + } else { + return 0; + } +} + +int mp_solve_path (MP mp, mp_knot first) +{ + if (first == NULL) { + return 0; + } else if (path_needs_fixing(first)) { + return 0; + } else { + int saved_arith_error = mp->arith_error; + int retval = 1; + jmp_buf *saved_jump_buf = mp->jump_buf; + mp->jump_buf = mp_memory_allocate(sizeof(jmp_buf)); + if (mp->jump_buf == NULL || setjmp(*(mp->jump_buf)) != 0) { + return 0; + } else { + mp->arith_error = 0; + mp_make_choices(mp, first); + if (mp->arith_error) { + retval = 0; + } + mp->arith_error = saved_arith_error; + mp_memory_free(mp->jump_buf); + mp->jump_buf = saved_jump_buf; + return retval; + } + } +} + +void mp_free_path (MP mp, mp_knot p) +{ + mp_toss_knot_list(mp, p); +} + +@ @<Exported function headers@>= +int mp_close_path_cycle (MP mp, mp_knot p, mp_knot q); +int mp_close_path (MP mp, mp_knot q, mp_knot first); +mp_knot mp_create_knot (MP mp); +int mp_set_knot (MP mp, mp_knot p, double x, double y); +mp_knot mp_append_knot (MP mp, mp_knot p, double x, double y); +mp_knot mp_append_knot_xy (MP mp, mp_knot p, double x, double y); +int mp_set_knot_curl (MP mp, mp_knot q, double value); +int mp_set_knot_left_curl (MP mp, mp_knot q, double value); +int mp_set_knot_right_curl (MP mp, mp_knot q, double value); +int mp_set_knot_simple_curl (MP mp, mp_knot q); +int mp_set_knotpair_curls (MP mp, mp_knot p, mp_knot q, double t1, double t2) ; +int mp_set_knotpair_tensions (MP mp, mp_knot p, mp_knot q, double t1, double t2) ; +int mp_set_knot_left_tension (MP mp, mp_knot p, double t1); +int mp_set_knot_right_tension (MP mp, mp_knot p, double t1); +int mp_set_knot_left_control (MP mp, mp_knot p, double t1, double t2); +int mp_set_knot_right_control (MP mp, mp_knot p, double t1, double t2); +int mp_set_knotpair_controls (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ; +int mp_set_knot_direction (MP mp, mp_knot q, double x, double y) ; +int mp_set_knotpair_directions (MP mp, mp_knot p, mp_knot q, double x1, double y1, double x2, double y2) ; +int mp_solve_path (MP mp, mp_knot first); +void mp_free_path (MP mp, mp_knot p); + +@ Simple accessors for |mp_knot|. + +@c +double mp_number_as_double (MP mp, mp_number n) { + (void) mp; + return number_to_double(n); +} + +@ @<Exported function headers@>= +double mp_number_as_double (MP mp, mp_number n); + +@* Measuring paths. + +\MP's |llcorner|, |lrcorner|, |ulcorner|, and |urcorner| operators allow +the user to measure the bounding box of anything that can go into a picture. It's +easy to get rough bounds on the $x$ and $y$ extent of a path by just finding the +bounding box of the knots and the control points. We need a more accurate version +of the bounding box, but we can still use the easy estimate to save time by +focusing on the interesting parts of the path. + +@ Computing an accurate bounding box involves a theme that will come up again and +again. Given a Bernshte{\u\i}n polynomial @^Bernshte{\u\i}n, Serge{\u\i} +Natanovich@> + +$$B(z_0,z_1,\ldots,z_n;t)=\sum_k{n\choose k}t^k(1-t)^{n-k}z_k,$$ + +we can conveniently bisect its range as follows: + +\smallskip \textindent{1)} Let $z_k^{(0)}=z_k$, for |0<=k<=n|. + +\smallskip \textindent{2)} Let $z_k^{(j+1)}={1\over2}(z_k^{(j)}+z\k^{(j)})$, for +|0<=k<n-j|, for |0<=j<n|. + +\smallskip\noindent Then + +$$B(z_0,z_1,\ldots,z_n;t)=B(z_0^{(0)},z_0^{(1)},\ldots,z_0^{(n)};2t) +=B(z_0^{(n)},z_1^{(n-1)},\ldots,z_n^{(0)};2t-1).$$ + +This formula gives us the coefficients of polynomials to use over the ranges $0\L +t|1\over2|$ and ${1\over2}\L t\L1$. + +@ Here is a routine that computes the $x$ or $y$ coordinate of the point on a +cubic corresponding to the |fraction| value~|t|. + +@c +static void mp_eval_cubic (MP mp, mp_number *r, mp_knot p, mp_knot q, int c, mp_number *t) +{ + mp_number x1, x2, x3; /* intermediate values */ + new_number(x1); + new_number(x2); + new_number(x3); + if (c == mp_x_code) { + set_number_from_of_the_way(x1, *t, p->x_coord, p->right_x); + set_number_from_of_the_way(x2, *t, p->right_x, q->left_x); + set_number_from_of_the_way(x3, *t, q->left_x, q->x_coord); + } else { + set_number_from_of_the_way(x1, *t, p->y_coord, p->right_y); + set_number_from_of_the_way(x2, *t, p->right_y, q->left_y); + set_number_from_of_the_way(x3, *t, q->left_y, q->y_coord); + } + set_number_from_of_the_way(x1, *t, x1, x2); + set_number_from_of_the_way(x2, *t, x2, x3); + set_number_from_of_the_way(*r, *t, x1, x2); + free_number(x1); + free_number(x2); + free_number(x3); +} + +@ The actual bounding box information is stored in global variables. Since it is +convenient to address the $x$ and $y$ information separately, we define arrays +indexed by |x_code..y_code| and use macros to give them more convenient names. + +@<Types...@>= +enum mp_bb_code { + mp_x_code, /* index for |minx| and |maxx| */ + mp_y_code /* index for |miny| and |maxy| */ +}; + +@ +@d mp_minx mp->bbmin[mp_x_code] +@d mp_maxx mp->bbmax[mp_x_code] +@d mp_miny mp->bbmin[mp_y_code] +@d mp_maxy mp->bbmax[mp_y_code] + +@<Glob...@>= +/* the result of procedures that compute bounding box information */ +mp_number bbmin[mp_y_code + 1]; +mp_number bbmax[mp_y_code + 1]; + +@ @<Initialize table ...@>= +for (int i = 0; i <= mp_y_code; i++) { + new_number(mp->bbmin[i]); + new_number(mp->bbmax[i]); +} + +@ @<Dealloc...@>= +for (int i = 0; i <= mp_y_code; i++) { + free_number(mp->bbmin[i]); + free_number(mp->bbmax[i]); +} + +@ Now we're ready for the key part of the bounding box computation. The +|bound_cubic| procedure updates |bbmin[c]| and |bbmax[c]| based on + +$$B(\hbox{|knot_coord(p)|}, \hbox{|right_coord(p)|}, \hbox{|left_coord(q)|}, +\hbox{|knot_coord(q)|};t) $$ + +for $0<t\le1$. In other words, the procedure adjusts the bounds to accommodate +|knot_coord(q)| and any extremes over the range $0<t<1$. The |c| parameter is +|x_code| or |y_code|. + +@c +static void mp_bound_cubic (MP mp, mp_knot p, mp_knot q, int c) +{ + int wavy; /* whether we need to look for extremes */ + mp_number del1, del2, del3, del, dmax; /* proportional to the control points of a quadratic derived from a cubic */ + mp_number t, tt; /* where a quadratic crosses zero */ + mp_number x; /* a value that |bbmin[c]| and |bbmax[c]| must accommodate */ + new_fraction(t); + new_fraction(tt); + if (c == mp_x_code) { + new_number_clone(x, q->x_coord); + } else { + new_number_clone(x, q->y_coord); + } + new_number(del1); + new_number(del2); + new_number(del3); + new_number(del); + new_number(dmax); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@> + @<Check the control points against the bounding box and set |wavy:=1| if any of them lie outside@> + if (wavy) { + if (c == mp_x_code) { + set_number_from_subtraction(del1, p->right_x, p->x_coord); + set_number_from_subtraction(del2, q->left_x, p->right_x); + set_number_from_subtraction(del3, q->x_coord, q->left_x); + } else { + set_number_from_subtraction(del1, p->right_y, p->y_coord); + set_number_from_subtraction(del2, q->left_y, p->right_y); + set_number_from_subtraction(del3, q->y_coord, q->left_y); + } + @<Scale up |del1|, |del2|, and |del3| for greater accuracy; also set |del| to the first nonzero element of |(del1,del2,del3)|@> + if (number_negative(del)) { + number_negate(del1); + number_negate(del2); + number_negate(del3); + } + crossing_point(t, del1, del2, del3); + if (number_less(t, fraction_one_t)) { + @<Test the extremes of the cubic against the bounding box@> + } + } + free_number(del3); + free_number(del2); + free_number(del1); + free_number(del); + free_number(dmax); + free_number(x); + free_number(t); + free_number(tt); +} + +@ @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@>= +if (number_less(x, mp->bbmin[c])) { + number_clone(mp->bbmin[c], x); +} +if (number_greater(x, mp->bbmax[c])) { + number_clone(mp->bbmax[c], x); +} + +@ @<Check the control points against the bounding box and set...@>= +wavy = 1; +if (c == mp_x_code) { + if (number_lessequal(mp->bbmin[c], p->right_x) && number_lessequal(p->right_x, mp->bbmax[c])) { + if (number_lessequal(mp->bbmin[c], q->left_x) && number_lessequal(q->left_x, mp->bbmax[c])) { + wavy = 0; + } + } +} else { + if (number_lessequal(mp->bbmin[c], p->right_y) && number_lessequal(p->right_y, mp->bbmax[c])) { + if (number_lessequal(mp->bbmin[c], q->left_y) && number_lessequal(q->left_y, mp->bbmax[c])) { + wavy = 0; + } + } +} + +@ If |del1=del2=del3=0|, it's impossible to obey the title of this section. We +just set |del=0| in that case. + +@<Scale up |del1|, |del2|, and |del3| for greater accuracy...@>= +if (number_nonzero(del1)) { + number_clone(del, del1); +} else if (number_nonzero(del2)) { + number_clone(del, del2); +} else { + number_clone(del, del3); +} +if (number_nonzero(del)) { + mp_number absval1; + new_number(absval1); + number_abs_clone(dmax, del1); + number_abs_clone(absval1, del2); + if (number_greater(absval1, dmax)) { + number_clone(dmax, absval1); + } + number_abs_clone(absval1, del3); + if (number_greater(absval1, dmax)) { + number_clone(dmax, absval1); + } + while (number_less(dmax, fraction_half_t)) { + number_double(dmax); + number_double(del1); + number_double(del2); + number_double(del3); + } + free_number(absval1); +} + +@ Since |crossing_point| has tried to choose |t| so that $B(|del1|, |del2|, +|del3|; \tau)$ crosses zero at $\tau = |t|$ with negative slope, the value of +|del2| computed below should not be positive. But rounding error could make it +slightly positive in which case we must cut it to zero to avoid confusion. + +@<Test the extremes of the cubic against the bounding box@>= +{ + mp_eval_cubic(mp, &x, p, q, c, &t); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@> + set_number_from_of_the_way(del2, t, del2, del3); + /* now |0,del2,del3| represent the derivative on the remaining interval */ + if (number_positive(del2)) { + set_number_to_zero(del2); + } + { + mp_number arg2, arg3; + new_number(arg2); + new_number(arg3); + number_negated_clone(arg2, del2); + number_negated_clone(arg3, del3); + crossing_point(tt, zero_t, arg2, arg3); + free_number(arg2); + free_number(arg3); + } + if (number_less(tt, fraction_one_t)) { + /* Test the second extreme against the bounding box. */ + mp_number arg; + new_number(arg); + set_number_from_of_the_way(arg, t, tt, fraction_one_t); + mp_eval_cubic(mp, &x, p, q, c, &arg); + free_number(arg); + @<Adjust |bbmin[c]| and |bbmax[c]| to accommodate |x|@> + } +} + +@ Finding the bounding box of a path is basically a matter of applying +|bound_cubic| twice for each pair of adjacent knots. + +@c +static void mp_path_bbox (MP mp, mp_knot h) +{ + mp_knot p = h; + number_clone(mp_minx, h->x_coord); + number_clone(mp_miny, h->y_coord); + number_clone(mp_maxx, mp_minx); + number_clone(mp_maxy, mp_miny); + do { + if (mp_right_type(p) == mp_endpoint_knot) { + return; + } else { + mp_knot q = mp_next_knot(p); + mp_bound_cubic(mp, p, q, mp_x_code); + mp_bound_cubic(mp, p, q, mp_y_code); + p = q; + } + } while (p != h); +} + +static void mp_path_xbox (MP mp, mp_knot h) +{ + mp_knot p = h; + number_clone(mp_minx, h->x_coord); + number_clone(mp_maxx, mp_minx); + set_number_to_zero(mp_miny); + set_number_to_zero(mp_maxy); + do { + if (mp_right_type(p) == mp_endpoint_knot) { + return; + } else { + mp_knot q = mp_next_knot(p); + mp_bound_cubic(mp, p, q, mp_x_code); + p = q; + } + } while (p != h); +} + +static void mp_path_ybox (MP mp, mp_knot h) +{ + mp_knot p = h; + set_number_to_zero(mp_minx); + set_number_to_zero(mp_maxx); + number_clone(mp_miny, h->y_coord); + number_clone(mp_maxy, mp_miny); + do { + if (mp_right_type(p) == mp_endpoint_knot) { + return; + } else { + mp_knot q = mp_next_knot(p); + mp_bound_cubic(mp, p, q, mp_y_code); + p = q; + } + } while (p != h); +} + +@ Another important way to measure a path is to find its arc length. This is best +done by using the general bisection algorithm to subdivide the path until +obtaining \quote {well behaved} subpaths whose arc lengths can be approximated by +simple means. + +Since the arc length is the integral with respect to time of the magnitude of the +velocity, it is natural to use Simpson's rule for the approximation. @^Simpson's +rule@> If $\dot B(t)$ is the spline velocity, Simpson's rule gives + +$$ \vb\dot B(0)\vb + 4\vb\dot B({1\over2})\vb + \vb\dot B(1)\vb \over 6 $$ + +for the arc length of a path of length~1. For a cubic spline +$B(z_0,z_1,z_2,z_3;t)$, the time derivative $\dot B(t)$ is +$3B(dz_0,dz_1,dz_2;t)$, where $dz_i=z_{i+1}-z_i$. Hence the arc length +approximation is + +$$ {\vb dz_0\vb \over 2} + 2\vb dz_{02}\vb + {\vb dz_2\vb \over 2}, $$ + +where + +$$ dz_{02}={1\over2}\left({dz_0+dz_1\over 2}+{dz_1+dz_2\over 2}\right)$$ + +is the result of the bisection algorithm. + +@ The remaining problem is how to decide when a subpath is \quote {well behaved.} This +could be done via the theoretical error bound for Simpson's rule, @^Simpson's +rule@> but this is impractical because it requires an estimate of the fourth +derivative of the quantity being integrated. It is much easier to just perform a +bisection step and see how much the arc length estimate changes. Since the error +for Simpson's rule is proportional to the fourth power of the sample spacing, the +remaining error is typically about $1\over16$ of the amount of the change. We say +\quote {typically} because the error has a pseudo-random behavior that could cause the +two estimates to agree when each contain large errors. + +To protect against disasters such as undetected cusps, the bisection process +should always continue until all the $dz_i$ vectors belong to a single $90^\circ$ +sector. This ensures that no point on the spline can have velocity less than 70\% +of the minimum of $\vb dz_0\vb$, $\vb dz_1\vb$ and $\vb dz_2\vb$. If such a +spline happens to produce an erroneous arc length estimate that is little changed +by bisection, the amount of the error is likely to be fairly small. We will try +to arrange things so that freak accidents of this type do not destroy the inverse +relationship between the |arclength| and |arctime| operations. +@:arclength_}{|arclength| primitive@> @:arctime_}{|arctime| primitive@> + +@ The |arclength| and |arctime| operations are both based on a recursive +@^recursion@> function that finds the arc length of a cubic spline given $dz_0$, +$dz_1$, $dz_2$. This |arc_test| routine also takes an arc length goal |a_goal| +and returns the time when the arc length reaches |a_goal| if there is such a +time. Thus the return value is either an arc length less than |a_goal| or, if the +arc length would be at least |a_goal|, it returns a time value decreased by +|two|. This allows the caller to use the sign of the result to distinguish +between arc lengths and time values. On certain types of overflow, it is possible +for |a_goal| and the result of |arc_test| both to be |EL_GORDO|. Otherwise, the +result is always less than |a_goal|. + +Rather than halving the control point coordinates on each recursive call to +|arc_test|, it is better to keep them proportional to velocity on the original +curve and halve the results instead. This means that recursive calls can +potentially use larger error tolerances in their arc length estimates. How much +larger depends on to what extent the errors behave as though they are independent +of each other. To save computing time, we use optimistic assumptions and increase +the tolerance by a factor of about $\sqrt2$ for each recursive call. + +In addition to the tolerance parameter, |arc_test| should also have parameters +for ${1\over3}\vb\dot B(0)\vb$, ${2\over3}\vb\dot B({1\over2})\vb$, and +${1\over3}\vb\dot B(1)\vb$. These quantities are relatively expensive to compute +and they are needed in different instances of |arc_test|. + +@c +static void mp_arc_test (MP mp, + mp_number *ret, mp_number *dx0, mp_number *dy0, mp_number *dx1, + mp_number *dy1, mp_number *dx2, mp_number *dy2, mp_number *v0, + mp_number *v02, mp_number *v2, mp_number *a_goal, mp_number *tol_orig +) +{ + int simple; /* are the control points confined to a $90^\circ$ sector? */ + mp_number dx01, dy01, dx12, dy12, dx02, dy02; /* bisection results */ + mp_number v002, v022; /* twice the velocity magnitudes at $t={1\over4}$ and $t={3\over4}$ */ + mp_number arc; /* best arc length estimate before recursion */ + mp_number arc1; /* arc length estimate for the first half */ + mp_number simply; + mp_number tol; + new_number(arc ); + new_number(arc1); + new_number(dx01); + new_number(dy01); + new_number(dx12); + new_number(dy12); + new_number(dx02); + new_number(dy02); + new_number(v002); + new_number(v022); + new_number(simply); + new_number_clone(tol, *tol_orig); + @<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|, |dx2|, |dy2|@> + @<Initialize |v002|, |v022|, and the arc length estimate |arc|; if it overflows set |arc_test| and |return|@> + @<Test if the control points are confined to one quadrant or rotating them $45^\circ$ would put them in one quadrant. Then set |simple| appropriately@> + set_number_half_from_addition(simply, *v0, *v2); + number_negate(simply); + number_add(simply, arc); + number_subtract(simply, *v02); + number_abs(simply); + if (simple && number_lessequal(simply, tol)) { + if (number_less(arc, *a_goal)){ + number_clone(*ret, arc); + } else { + @<Estimate when the arc length reaches |a_goal| and set |arc_test| to that time minus |two|@> + } + } else { + @<Use one or two recursive calls to compute the |arc_test| function@> + } + DONE: + free_number(arc); + free_number(arc1); + free_number(dx01); + free_number(dy01); + free_number(dx12); + free_number(dy12); + free_number(dx02); + free_number(dy02); + free_number(v002); + free_number(v022); + free_number(simply); + free_number(tol); +} + +@ The |tol| value should by multiplied by $\sqrt 2$ before making recursive +calls, but $1.5$ is an adequate approximation. It is best to avoid using +|make_fraction| in this inner loop. @^inner loop@> + +@<Use one or two recursive calls to compute the |arc_test| function@>= +mp_number a_new, a_aux; /* the sum of these gives the |a_goal| */ +mp_number a, b; /* results of recursive calls */ +mp_number half_v02; /* |half(v02)|, a recursion argument */ +new_number(a_new); +new_number(a_aux); +new_number(half_v02); +@<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is as large as possible@> +{ + mp_number half_tol; + new_number_clone(half_tol, tol); + number_half(half_tol); + number_add(tol, half_tol); + free_number(half_tol); +} +number_clone(half_v02, *v02); +number_half(half_v02); +new_number(a); +mp_arc_test(mp, &a, dx0, dy0, &dx01, &dy01, &dx02, &dy02, v0, &v002, &half_v02, &a_new, &tol); +if (number_negative(a)) { + set_number_to_unity(*ret); + number_double(*ret); /* two */ + number_subtract(*ret, a); /* two - a */ + number_half(*ret); + number_negate(*ret); /* -half(two - a) */ +} else { + @<Update |a_new| to reduce |a_new+a_aux| by |a|@> + new_number(b); + mp_arc_test(mp, &b, &dx02, &dy02, &dx12, &dy12, dx2, dy2, &half_v02, &v022, v2, &a_new, &tol); + if (number_negative(b)) { + mp_number tmp ; + new_number(tmp); + number_negated_clone(tmp, b); + number_half(tmp); + number_negate(tmp); + number_clone(*ret, tmp); + set_number_to_unity(tmp); + number_half(tmp); + number_subtract(*ret, tmp); /* (-(half(-b)) - 1/2) */ + free_number(tmp); + } else { + set_number_from_subtraction(*ret, b, a); + number_half(*ret); + set_number_from_addition(*ret, a, *ret); /* (a + half(b - a)) */ + } + free_number(b); +} +free_number(half_v02); +free_number(a_aux); +free_number(a_new); +free_number(a); + +@ @<Set |a_new| and |a_aux| so their sum is |2*a_goal| and |a_new| is...@>= +set_number_to_inf(a_aux); +number_subtract(a_aux, *a_goal); +if (number_greater(*a_goal, a_aux)) { + set_number_from_subtraction(a_aux, *a_goal, a_aux); + set_number_to_inf(a_new); +} else { + set_number_from_addition(a_new, *a_goal, *a_goal); + set_number_to_zero(a_aux); +} + +@ There is no need to maintain |a_aux| at this point so we use it as a temporary +to force the additions and subtractions to be done in an order that avoids +overflow. + +@<Update |a_new| to reduce |a_new+a_aux| by |a|@>= +if (number_greater(a, a_aux)) { + number_subtract(a_aux, a); + number_add(a_new, a_aux); +} + +@ This code assumes all {\it dx} and {\it dy} variables have magnitude less than +|fraction_four|. To simplify the rest of the |arc_test| routine, we strengthen +this assumption by requiring the norm of each $({\it dx},{\it dy})$ pair to obey +this bound. Note that recursive calls will maintain this invariant. + +@<Bisect the B\'ezier quadratic given by |dx0|, |dy0|, |dx1|, |dy1|,...@>= +set_number_half_from_addition(dx01, *dx0, *dx1); +set_number_half_from_addition(dx12, *dx1, *dx2); +set_number_half_from_addition(dx02, dx01, dx12); +set_number_half_from_addition(dy01, *dy0, *dy1); +set_number_half_from_addition(dy12, *dy1, *dy2); +set_number_half_from_addition(dy02, dy01, dy12); + +@ We should be careful to keep |arc<EL_GORDO| so that calling |arc_test| with +|a_goal=EL_GORDO| is guaranteed to yield the arc length. + +@<Initialize |v002|, |v022|, and the arc length estimate |arc|;...@>= +{ + mp_number tmp, arg1, arg2 ; + new_number(tmp); + new_number(arg1); + new_number(arg2); + set_number_half_from_addition(arg1, *dx0, dx02); + number_add(arg1, dx01); + set_number_half_from_addition(arg2, *dy0, dy02); + number_add(arg2, dy01); + pyth_add(v002, arg1, arg2); + + set_number_half_from_addition(arg1, dx02, *dx2); + number_add(arg1, dx12); + set_number_half_from_addition(arg2, dy02, *dy2); + number_add(arg2, dy12); + pyth_add(v022, arg1, arg2); + free_number(arg1); + free_number(arg2); + + number_clone(tmp, *v02); + number_add_scaled(tmp, 2); + number_half(tmp); + + set_number_half_from_addition(arc1, *v0, tmp); + number_subtract(arc1, v002); + number_half(arc1); + set_number_from_addition(arc1, v002, arc1); + + set_number_half_from_addition(arc, *v2, tmp); + number_subtract(arc, v022); + number_half(arc); + set_number_from_addition(arc, v022, arc); + + /* reuse |tmp| for the next |if| test: */ + set_number_to_inf(tmp); + number_subtract(tmp,arc1); + if (number_less(arc, tmp)) { + free_number(tmp); + number_add(arc, arc1); + } else { + free_number(tmp); + mp->arith_error = 1; + if (number_infinite(*a_goal)) { + set_number_to_inf(*ret); + } else { + set_number_to_unity(*ret); + number_double(*ret); + number_negate(*ret); /* -two */ + } + goto DONE; + } +} + +@ @<Test if the control points are confined to one quadrant or rotating...@>= +simple = (number_nonnegative(*dx0) && number_nonnegative(*dx1) && number_nonnegative(*dx2)) + || (number_nonpositive(*dx0) && number_nonpositive(*dx1) && number_nonpositive(*dx2)); +if (simple) { + simple = (number_nonnegative(*dy0) && number_nonnegative(*dy1) && number_nonnegative(*dy2)) + || (number_nonpositive(*dy0) && number_nonpositive(*dy1) && number_nonpositive(*dy2)); +} +if (!simple) { + simple = (number_greaterequal(*dx0, *dy0) && number_greaterequal(*dx1, *dy1) && number_greaterequal(*dx2, *dy2)) + || (number_lessequal (*dx0, *dy0) && number_lessequal (*dx1, *dy1) && number_lessequal (*dx2, *dy2)); + if (simple) { + mp_number neg_dx0, neg_dx1, neg_dx2; + new_number(neg_dx0); + new_number(neg_dx1); + new_number(neg_dx2); + number_negated_clone(neg_dx0, *dx0); + number_negated_clone(neg_dx1, *dx1); + number_negated_clone(neg_dx2, *dx2); + simple = (number_greaterequal(neg_dx0, *dy0) && number_greaterequal(neg_dx1, *dy1) && number_greaterequal(neg_dx2, *dy2)) + || (number_lessequal (neg_dx0, *dy0) && number_lessequal (neg_dx1, *dy1) && number_lessequal (neg_dx2, *dy2)); + free_number(neg_dx0); + free_number(neg_dx1); + free_number(neg_dx2); + } +} + +@ Since Simpson's rule is based on approximating the integrand by a parabola, +@^Simpson's rule@> it is appropriate to use the same approximation to decide when +the integral reaches the intermediate value |a_goal|. At this point + +$$\eqalign{ + {\vb\dot B(0)\vb\over 3} &= \hbox{|v0|}, \qquad + {\vb\dot B({1\over4})\vb\over 3} = {\hbox{|v002|}\over 2}, \qquad + {\vb\dot B({1\over2})\vb\over 3} = {\hbox{|v02|}\over 2}, \cr + {\vb\dot B({3\over4})\vb\over 3} &= {\hbox{|v022|}\over 2}, \qquad + {\vb\dot B(1)\vb\over 3} = \hbox{|v2|} \cr +} +$$ + +and + +$$ {\vb\dot B(t)\vb\over 3} \approx + \cases{B\left(\hbox{|v0|}, + \hbox{|v002|}-{1\over 2}\hbox{|v0|}-{1\over 4}\hbox{|v02|}, + {1\over 2}\hbox{|v02|}; 2t \right)& + if $t\le{1\over 2}$\cr + B\left({1\over 2}\hbox{|v02|}, + \hbox{|v022|}-{1\over 4}\hbox{|v02|}-{1\over 2}\hbox{|v2|}, + \hbox{|v2|}; 2t-1 \right)& + if $t\ge{1\over 2}$.\cr} + \eqno (*) +$$ + +We can integrate $\vb\dot B(t)\vb$ by using + +$$\int 3B(a,b,c;\tau)\,dt = + {B(0,a,a+b,a+b+c;\tau) + {\rm constant} \over {d\tau\over dt}}. +$$ + +This construction allows us to find the time when the arc length reaches |a_goal| +by solving a cubic equation of the form $$ B(0,a,a+b,a+b+c;\tau) = x, $$ where +$\tau$ is $2t$ or $2t+1$, $x$ is |a_goal| or |a_goal-arc1|, and $a$, $b$, and $c$ +are the Bernshte{\u\i}n coefficients from $(*)$ divided by @^Bernshte{\u\i}n, +Serge{\u\i} Natanovich@> $d\tau\over dt$. We shall define a function +|solve_rising_cubic| that finds $\tau$ given $a$, $b$, $c$, and $x$. + +@<Estimate when the arc length reaches |a_goal| and set |arc_test| to...@>= +mp_number tmp; +mp_number tmp2; +mp_number tmp3; +mp_number tmp4; +mp_number tmp5; +new_number_clone(tmp, *v02); +new_number(tmp2); +new_number(tmp3); +new_number(tmp4); +new_number(tmp5); +number_add_scaled(tmp, 2); +number_half(tmp); +number_half(tmp); /* (v02+2) / 4 */ +if (number_lessequal(*a_goal, arc1)) { + number_clone(tmp2, *v0); + number_half(tmp2); + set_number_from_subtraction(tmp3, arc1, tmp2); + number_subtract(tmp3, tmp); + mp_solve_rising_cubic(mp, &tmp5, &tmp2, &tmp3, &tmp, a_goal); + number_half(tmp5); + set_number_to_unity(tmp3); + number_subtract(tmp5, tmp3); + number_subtract(tmp5, tmp3); + number_clone(*ret, tmp5); +} else { + number_clone(tmp2, *v2); + number_half(tmp2); + set_number_from_subtraction(tmp3, arc, arc1); + number_subtract(tmp3, tmp); + number_subtract(tmp3, tmp2); + set_number_from_subtraction(tmp4, *a_goal, arc1); + mp_solve_rising_cubic(mp, &tmp5, &tmp, &tmp3, &tmp2, &tmp4); + number_half(tmp5); + set_number_to_unity(tmp2); + set_number_to_unity(tmp3); + number_half(tmp2); + number_subtract(tmp2, tmp3); + number_subtract(tmp2, tmp3); + set_number_from_addition(*ret, tmp2, tmp5); +} +free_number(tmp); +free_number(tmp2); +free_number(tmp3); +free_number(tmp4); +free_number(tmp5); + +@ Here is the |solve_rising_cubic| routine that finds the time~$t$ when $$ B(0, +a, a+b, a+b+c; t) = x. $$ This routine is based on |crossing_point| but is +simplified by the assumptions that $B(a,b,c;t)\ge0$ for $0\le t\le1$ and that +|0<=x<=a+b+c|. If rounding error causes this condition to be violated slightly, +we just ignore it and proceed with binary search. This finds a time when the +function value reaches |x| and the slope is positive. + +@<Declarations@>= +static void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number *a_orig, mp_number *b_orig, mp_number *c_orig, mp_number *x_orig); + +@ @c +void mp_solve_rising_cubic (MP mp, mp_number *ret, mp_number *a_orig, mp_number *b_orig, mp_number *c_orig, mp_number *x_orig) +{ + mp_number abc; + mp_number a, b, c, x; /* local versions of arguments */ + mp_number ab, bc, ac; /* bisection results */ + mp_number t; /* $2^k+q$ where unscaled answer is in $[q2^{-k},(q+1)2^{-k})$ */ + mp_number xx; /* temporary for updating |x| */ + mp_number neg_x; /* temporary for an |if| */ + if (number_negative(*a_orig) || number_negative(*c_orig)) { + mp_confusion(mp, "rising cubic"); + @:this can't happen rising?}{\quad rising?@> + } + new_number(t); + new_number(abc); + new_number_clone(a, *a_orig); + new_number_clone(b, *b_orig); + new_number_clone(c, *c_orig); + new_number_clone(x, *x_orig); + new_number(ab); + new_number(bc); + new_number(ac); + new_number(xx); + new_number(neg_x); + set_number_from_addition(abc, a, b); + number_add(abc, c); + if (number_nonpositive(x)) { + set_number_to_zero(*ret); + } else if (number_greaterequal(x, abc)) { + set_number_to_unity(*ret); + } else { + number_clone(t, epsilon_t); + @<Rescale if necessary to make sure |a|, |b|, and |c| are all less than |EL_GORDO div 3|@> + do { + number_add(t, t); + @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@> + number_clone(xx,x); + number_subtract(xx, a); + number_subtract(xx, ab); + number_subtract(xx, ac); + number_negated_clone(neg_x, x); + if (number_less(xx, neg_x)) { + number_double(x); + number_clone(b, ab); + number_clone(c, ac); + } else { + number_add(x, xx); + number_clone(a, ac); + number_clone(b, bc); + number_add(t, epsilon_t); + } + } while (number_less(t, unity_t)); + set_number_from_subtraction(*ret, t, unity_t); + } + free_number(abc); + free_number(t); + free_number(a); + free_number(b); + free_number(c); + free_number(ab); + free_number(bc); + free_number(ac); + free_number(xx); + free_number(x); + free_number(neg_x); +} + +@ @<Subdivide the B\'ezier quadratic defined by |a|, |b|, |c|@>= +set_number_half_from_addition(ab, a, b); +set_number_half_from_addition(bc, b, c); +set_number_half_from_addition(ac, ab, bc); + +@ The upper bound on |a|, |b|, and |c|: + +@d one_third_inf_t mp->math->md_one_third_inf_t + +@<Rescale if necessary to make sure |a|, |b|, and |c| are all less than...@>= +while (number_greater(a, one_third_inf_t) || number_greater(b, one_third_inf_t) || number_greater(c, one_third_inf_t)) { + number_half(a); + number_half(b); + number_half(c); + number_half(x); +} + +@ It is convenient to have a simpler interface to |arc_test| that requires no +unnecessary arguments and ensures that each $({\it dx},{\it dy})$ pair has +length less than |fraction_four|. + +@c +static void mp_do_arc_test (MP mp, + mp_number *ret, mp_number *dx0, mp_number *dy0, mp_number *dx1, + mp_number *dy1, mp_number *dx2, mp_number *dy2, mp_number *a_goal +) +{ + mp_number v0, v1, v2; /* length of each $({\it dx},{\it dy})$ pair */ + mp_number v02; /* twice the norm of the quadratic at $t={1\over2}$ */ + new_number(v0); + new_number(v1); + new_number(v2); + pyth_add(v0, *dx0, *dy0); + pyth_add(v1, *dx1, *dy1); + pyth_add(v2, *dx2, *dy2); + if ((number_greaterequal(v0, fraction_four_t)) || (number_greaterequal(v1, fraction_four_t)) || (number_greaterequal(v2, fraction_four_t))) { + mp->arith_error = 1; + if (number_infinite(*a_goal)) { + set_number_to_inf(*ret); + } else { + set_number_to_unity(*ret); + number_double(*ret); + number_negate(*ret); + } + } else { + mp_number arg1, arg2; + new_number(v02); + new_number(arg1); + new_number(arg2); + set_number_half_from_addition(arg1, *dx0, *dx2); + number_add(arg1, *dx1); + set_number_half_from_addition(arg2, *dy0, *dy2); + number_add(arg2, *dy1); + pyth_add(v02, arg1, arg2); + free_number(arg1); + free_number(arg2); + mp_arc_test(mp, ret, dx0, dy0, dx1, dy1, dx2, dy2, &v0, &v02, &v2, a_goal, &arc_tol_k); + free_number(v02); + } + free_number(v0); + free_number(v1); + free_number(v2); +} + +@ Now it is easy to find the arc length of an entire path. + +@c +static void mp_get_arc_length (MP mp, mp_number *ret, mp_knot h) +{ + mp_number a; /* current arc length */ + mp_number a_tot; /* total arc length */ + mp_number arg1, arg2, arg3, arg4, arg5, arg6; + mp_number arcgoal; + mp_knot p = h; /* for traversing the path */ + new_number(a_tot); + new_number(arg1); + new_number(arg2); + new_number(arg3); + new_number(arg4); + new_number(arg5); + new_number(arg6); + new_number(a); + new_number(arcgoal); + set_number_to_inf(arcgoal); + while (mp_right_type(p) != mp_endpoint_knot) { + mp_knot q = mp_next_knot(p); + @<Add arclength of path segment@> + if (q == h) { + break; + } else { + p = q; + } + } + free_number(arcgoal); + free_number(a); + free_number(arg1); + free_number(arg2); + free_number(arg3); + free_number(arg4); + free_number(arg5); + free_number(arg6); + check_arith(); + number_clone(*ret, a_tot); + free_number(a_tot); +} + +static void mp_get_subarc_length (MP mp, mp_number *ret, mp_knot h, mp_number *first, mp_number *last) +{ + mp_number a; + mp_number a_tot, a_cnt; + mp_number arg1, arg2, arg3, arg4, arg5, arg6; + mp_number arcgoal; + mp_knot p = h; + new_number(a_tot); + new_number(a_cnt); + new_number(arg1); + new_number(arg2); + new_number(arg3); + new_number(arg4); + new_number(arg5); + new_number(arg6); + new_number(a); + new_number(arcgoal); + set_number_to_inf(arcgoal); + while (mp_right_type(p) != mp_endpoint_knot) { + mp_knot q = mp_next_knot(p); + if (number_greaterequal(a_cnt, *last)) { + break; + } else if (number_greaterequal(a_cnt, *first)) { + @<Add arclength of path segment@> + } + if (q == h) { + break; + } else { + p = q; + number_add(a_cnt, unity_t); + } + } + free_number(arcgoal); + free_number(a); + free_number(arg1); + free_number(arg2); + free_number(arg3); + free_number(arg4); + free_number(arg5); + free_number(arg6); + check_arith(); + number_clone(*ret, a_tot); + free_number(a_cnt); + free_number(a_tot); +} + +@<Add arclength of path segment@>= +set_number_from_subtraction(arg1, p->right_x, p->x_coord); +set_number_from_subtraction(arg2, p->right_y, p->y_coord); +set_number_from_subtraction(arg3, q->left_x, p->right_x); +set_number_from_subtraction(arg4, q->left_y, p->right_y); +set_number_from_subtraction(arg5, q->x_coord, q->left_x); +set_number_from_subtraction(arg6, q->y_coord, q->left_y); +mp_do_arc_test(mp, &a, &arg1, &arg2, &arg3, &arg4, &arg5, &arg6, &arcgoal); +slow_add(a_tot, a, a_tot); + +@ The inverse operation of finding the time on a path~|h| when the arc length +reaches some value |arc0| can also be accomplished via |do_arc_test|. Some care +is required to handle very large times or negative times on cyclic paths. For +non-cyclic paths, |arc0| values that are negative or too large cause +|get_arc_time| to return 0 or the length of path~|h|. + +If |arc0| is greater than the arc length of a cyclic path~|h|, the result is a +time value greater than the length of the path. Since it could be much greater, +we must be prepared to compute the arc length of path~|h| and divide this into +|arc0| to find how many multiples of the length of path~|h| to add. + +@c +static mp_knot mp_get_arc_time(MP mp, mp_number *ret, mp_knot h, mp_number *arc0_orig, int local) +{ + if (number_negative(*arc0_orig)) { + @<Deal with a negative |arc0_orig| value and |return|@> + } else { + mp_knot p, q, k; /* for traversing the path */ + mp_number t_tot; /* accumulator for the result */ + mp_number t; /* the result of |do_arc_test| */ + mp_number arc, arc0; /* portion of |arc0| not used up so far */ + mp_number arg1, arg2, arg3, arg4, arg5, arg6; /* |do_arc_test| arguments */ + new_number(t_tot); + new_number_clone(arc0, *arc0_orig); + if (number_infinite(arc0)) { + number_add_scaled(arc0, -1); + } + new_number_clone(arc, arc0); + p = h; + k = h; + new_number(arg1); + new_number(arg2); + new_number(arg3); + new_number(arg4); + new_number(arg5); + new_number(arg6); + new_number(t); + while ((mp_right_type(p) != mp_endpoint_knot) && number_positive(arc)) { + k = p; + q = mp_next_knot(p); + set_number_from_subtraction(arg1, p->right_x, p->x_coord); + set_number_from_subtraction(arg2, p->right_y, p->y_coord); + set_number_from_subtraction(arg3, q->left_x, p->right_x); + set_number_from_subtraction(arg4, q->left_y, p->right_y); + set_number_from_subtraction(arg5, q->x_coord, q->left_x); + set_number_from_subtraction(arg6, q->y_coord, q->left_y); + mp_do_arc_test(mp, &t, &arg1, &arg2, &arg3, &arg4, &arg5, &arg6, &arc); + @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@> + if (q == h) { + @<Update |t_tot| and |arc| to avoid going around the cyclic path too many times but set |arith_error:=1| and |goto done| on overflow@> + } + p = q; + } + check_arith(); + if (local) { + number_add(t, two_t); + number_clone(*ret, t); + } else { + number_clone(*ret, t_tot); + } + h = k; + RETURN: + free_number(t_tot); + free_number(t); + free_number(arc); + free_number(arc0); + free_number(arg1); + free_number(arg2); + free_number(arg3); + free_number(arg4); + free_number(arg5); + free_number(arg6); + } + return h; +} + +@ @<Update |arc| and |t_tot| after |do_arc_test| has just returned |t|@>= +if (number_negative(t)) { + number_add(t_tot, t); + number_add(t_tot, two_t); + set_number_to_zero(arc); +} else { + number_add(t_tot, unity_t); + number_subtract(arc, t); +} + +@ @<Deal with a negative |arc0_orig| value and |return|@>= +if (mp_left_type(h) == mp_endpoint_knot) { + set_number_to_zero(*ret); +} else { + mp_number neg_arc0; + mp_knot p = mp_htap_ypoc(mp, h); + new_number(neg_arc0); + number_negated_clone(neg_arc0, *arc0_orig); + mp_get_arc_time(mp, ret, p, &neg_arc0, 0); + number_negate(*ret); + mp_toss_knot_list(mp, p); + free_number(neg_arc0); +} +check_arith(); + +@ @<Update |t_tot| and |arc| to avoid going around the cyclic...@>= +if (number_positive(arc)) { + mp_number n, n1, d1, v1; + new_number(n); + new_number(n1); + new_number(d1); + new_number(v1); + + set_number_from_subtraction(d1, arc0, arc); /* d1 = arc0 - arc */ + set_number_from_div(n1, arc, d1); /* n1 = (arc / d1) */ + number_clone(n, n1); + set_number_from_mul(n1, n1, d1); /* n1 = (n1 * d1) */ + number_subtract(arc, n1); /* arc = arc - n1 */ + + number_clone(d1, inf_t); /* reuse d1 */ + number_clone(v1, n); /* v1 = n */ + number_add(v1, epsilon_t); /* v1 = n1+1 */ + set_number_from_div(d1, d1, v1); /* |d1 = EL_GORDO / v1| */ + if (number_greater(t_tot, d1)) { + mp->arith_error = 1; + check_arith(); + set_number_to_inf(*ret); + free_number(n); + free_number(n1); + free_number(d1); + free_number(v1); + goto RETURN; + } + set_number_from_mul(t_tot, t_tot, v1); + free_number(n); + free_number(n1); + free_number(d1); + free_number(v1); +} + +@* Data structures for pens. + +A Pen in \MP\ can be either elliptical or polygonal. Elliptical pens result in +\ps\ |stroke| commands, while anything drawn with a polygonal pen is +@:stroke}{|stroke| command@> converted into an area fill as described in the +next part of this program. The mathematics behind this process is based on simple +aspects of the theory of tracings developed by Leo Guibas, Lyle Ramshaw, and +Jorge Stolfi [\quote {A kinematic framework for computational geometry,} Proc.\ IEEE +Symp.\ Foundations of Computer Science {\bf 24} (1983), 100--111]. + +Polygonal pens are created from paths via \MP's |makepen| primitive. +@:makepen_}{|makepen| primitive@> This path representation is almost sufficient +for our purposes except that a pen path should always be a convex polygon with +the vertices in counter-clockwise order. Since we will need to scan pen polygons +both forward and backward, a pen should be represented as a doubly linked ring of +knot nodes. There is room for the extra back pointer because we do not need the +|mp_left_type| or |mp_right_type| fields. In fact, we don't need the |left_x|, +|left_y|, |right_x|, or |right_y| fields either but we leave these alone so that +certain procedures can operate on both pens and paths. In particular, pens can be +copied using |copy_path| and recycled using |toss_knot_list|. + +@ The |make_pen| procedure turns a path into a pen by initializing the +|prev_knot| pointers and making sure the knots form a convex polygon. Thus each +cubic in the given path becomes a straight line and the control points are +ignored. If the path is not cyclic, the ends are connected by a straight line. + +@d mp_copy_pen(mp,A) mp_make_pen(mp, mp_copy_path(mp, (A)),0) + +@c +static mp_knot mp_make_pen (MP mp, mp_knot h, int need_hull) +{ + mp_knot q = h; + /* this can go ... we are already double linked */ + do { + mp_knot p = q; + q = mp_next_knot(q); + mp_prev_knot(q) = p; + } while (q != h); + if (need_hull) { + h = mp_convex_hull(mp, h); + @<Make sure |h| isn't confused with an elliptical pen@> + } + return h; +} + +@ The only information required about an elliptical pen is the overall +transformation that has been applied to the original |pencircle|. +@:pencircle_}{|pencircle| primitive@> Since it suffices to keep track of how +the three points $(0,0)$, $(1,0)$, and $(0,1)$ are transformed, an elliptical pen +can be stored in a single knot node and transformed as if it were a path. + +@d mp_pen_is_elliptical(A) ((A)==mp_next_knot((A))) + +@ @c +static mp_knot mp_get_pen_circle (MP mp, mp_number *diam) +{ + mp_knot h = mp_new_knot(mp); /* the knot node to return */ + mp_next_knot(h) = h; + mp_prev_knot(h) = h; + mp_originator(h) = mp_program_code; + mp_knotstate(h) = mp_regular_knot; + set_number_to_zero(h->x_coord); + set_number_to_zero(h->y_coord); + number_clone(h->left_x, *diam); + set_number_to_zero(h->left_y); + set_number_to_zero(h->right_x); + number_clone(h->right_y, *diam); + return h; +} + +@ If the polygon being returned by |make_pen| has only one vertex, it will be +interpreted as an elliptical pen. This is no problem since a degenerate polygon +can equally well be thought of as a degenerate ellipse. We need only initialize +the |left_x|, |left_y|, |right_x|, and |right_y| fields. + + +@<Make sure |h| isn't confused with an elliptical pen@>= +if (mp_pen_is_elliptical(h)) { + number_clone(h->left_x, h->x_coord); + number_clone(h->left_y, h->y_coord); + number_clone(h->right_x, h->x_coord); + number_clone(h->right_y, h->y_coord); +} + +@ Printing a polygonal pen is very much like printing a path + +@<Declarations@>= +static void mp_pr_pen (MP mp, mp_knot h); + +@ @c +void mp_pr_pen (MP mp, mp_knot h) +{ + if (mp_pen_is_elliptical(h)) { + @<Print the elliptical pen |h|@> + } else { + mp_knot p = h; + do { + /* Advance |p| making sure the links are OK and |return| if there is a problem. */ + mp_knot q = mp_next_knot(p); + mp_print_two(mp, &(p->x_coord), &(p->y_coord)); + mp_print_nl(mp, " .. "); + if ((q == NULL) || (mp_prev_knot(q) != p)) { + mp_print_nl(mp, "???"); + return; /* this won't happen */ + @.???@> + } + p = q; + } while (p != h); + mp_print_str(mp, "cycle"); + } +} + +@ @<Print the elliptical pen |h|@>= +{ + mp_number v1; + new_number(v1); + mp_print_str(mp, "pencircle transformed ("); + print_number(h->x_coord); + mp_print_chr(mp, ','); + print_number(h->y_coord); + mp_print_chr(mp, ','); + set_number_from_subtraction(v1, h->left_x, h->x_coord); + print_number(v1); + mp_print_chr(mp, ','); + set_number_from_subtraction(v1, h->right_x, h->x_coord); + print_number(v1); + mp_print_chr(mp, ','); + set_number_from_subtraction(v1, h->left_y, h->y_coord); + print_number(v1); + mp_print_chr(mp, ','); + set_number_from_subtraction(v1, h->right_y, h->y_coord); + print_number(v1); + mp_print_chr(mp, ')'); + free_number(v1); +} + +@ Here us another version of |pr_pen| that prints the pen as a diagnostic +message. + +@<Declarations@>= +static void mp_print_pen (MP mp, mp_knot h, const char *s, int nuline); + +@ @c +void mp_print_pen (MP mp, mp_knot h, const char *s, int nuline) { + mp_print_diagnostic(mp, "Pen", s, nuline); + mp_print_ln(mp); + @.Pen at line...@> + mp_pr_pen(mp, h); + mp_end_diagnostic(mp, 1); +} + +@ Making a polygonal pen into a path involves restoring the |mp_left_type| and +|mp_right_type| fields and setting the control points so as to make a polygonal +path. + +@c +static void mp_make_path (MP mp, mp_knot h) +{ + if (mp_pen_is_elliptical(h)) { + @<Make the elliptical pen |h| into a path@> + } else { + mp_knot p = h; + do { + mp_left_type(p) = mp_explicit_knot; + mp_right_type(p) = mp_explicit_knot; + number_clone(p->left_x, p->x_coord); + number_clone(p->left_y, p->y_coord); + number_clone(p->right_x, p->x_coord); + number_clone(p->right_y, p->y_coord); + p = mp_next_knot(p); + } while (p != h); + } +} + +@ We need an eight knot path to get a good approximation to an ellipse. + +@<Make the elliptical pen |h| into a path@>= +mp_knot p; /* for traversing the knot list */ +mp_number center_x, center_y; /* translation parameters for an elliptical pen */ +mp_number width_x, width_y; /* the effect of a unit change in $x$ */ +mp_number height_x, height_y; /* the effect of a unit change in $y$ */ +mp_number dx, dy; /* the vector from knot |p| to its right control point */ +new_number(width_x); +new_number(width_y); +new_number(height_x); +new_number(height_y); +new_number(dx); +new_number(dy); +new_number_clone(center_x, h->x_coord); +new_number_clone(center_y, h->y_coord); +set_number_from_subtraction(width_x, h->left_x, center_x); +set_number_from_subtraction(width_y, h->left_y, center_y); +set_number_from_subtraction(height_x, h->right_x, center_x); +set_number_from_subtraction(height_y, h->right_y, center_y); +p = h; +for (int k = 0; k <= 7; k++) { + @<Initialize |p| as the |k|th knot of a circle of unit diameter, transforming it appropriately@> + if (k == 7) { + mp_prev_knot(h) = p; + mp_next_knot(p) = h; + } else { + mp_knot k = mp_new_knot(mp); + mp_prev_knot(k) = p; + mp_next_knot(p) = k; + } + p = mp_next_knot(p); +} +free_number(dx); +free_number(dy); +free_number(center_x); +free_number(center_y); +free_number(width_x); +free_number(width_y); +free_number(height_x); +free_number(height_y); + +@ The only tricky thing here are the tables |half_cos| and |d_cos| used to find +the point $k/8$ of the way around the circle and the direction vector to use +there. With |kk| we track |k| advancing $270^\circ$ around the ring (cf. $\sin +\theta = \cos (\theta+270)$). + +@<Initialize |p| as the |k|th knot of a circle of unit diameter,...@>= +/* This is the body of a loop with variable k: */ +int kk = (k + 6) % 8; +mp_number r1, r2; +new_fraction(r1); +new_fraction(r2); +take_fraction(r1, mp->half_cos[k], width_x); +take_fraction(r2, mp->half_cos[kk], height_x); +number_add(r1, r2); +set_number_from_addition(p->x_coord, center_x, r1); +take_fraction(r1, mp->half_cos[k], width_y); +take_fraction(r2, mp->half_cos[kk], height_y); +number_add(r1, r2); +set_number_from_addition(p->y_coord, center_y, r1); +take_fraction(r1, mp->d_cos[kk], width_x); +take_fraction(r2, mp->d_cos[k], height_x); +number_negated_clone(dx, r1); +number_add(dx, r2); +take_fraction(r1, mp->d_cos[kk], width_y); +take_fraction(r2, mp->d_cos[k], height_y); +number_negated_clone(dy, r1); +number_add(dy, r2); +set_number_from_addition(p->right_x, p->x_coord, dx); +set_number_from_addition(p->right_y, p->y_coord, dy); +set_number_from_subtraction(p->left_x, p->x_coord, dx); +set_number_from_subtraction(p->left_y, p->y_coord, dy); +free_number(r1); +free_number(r2); +mp_left_type(p) = mp_explicit_knot; +mp_right_type(p) = mp_explicit_knot; +mp_originator(p) = mp_program_code; +mp_knotstate(p) = mp_regular_knot; + +@ @<Glob...@>= +mp_number half_cos[8]; /* ${1\over2}\cos(45k)$ */ +mp_number d_cos[8]; /* a magic constant times $\cos(45k)$ */ + +@ The magic constant for |d_cos| is the distance between $({1\over2},0)$ and +$({1\over4}\sqrt2,{1\over4}\sqrt2)$ times the result of the |velocity| function +for $\theta=\phi=22.5^\circ$. This comes out to be + +$$ d = {\sqrt{2-\sqrt2}\over 3+3\cos22.5^\circ} \approx 0.132608244919772. $$ + +@<Set init...@>= +for (int k = 0; k <= 7; k++) { + new_fraction(mp->half_cos[k]); + new_fraction(mp->d_cos[k]); +} + +number_clone(mp->half_cos[0], fraction_half_t); +number_clone(mp->half_cos[1], twentysixbits_sqrt2_t); +number_clone(mp->half_cos[2], zero_t); +number_clone(mp->d_cos[0], twentyeightbits_d_t); +number_clone(mp->d_cos[1], twentysevenbits_sqrt2_d_t); +number_clone(mp->d_cos[2], zero_t); + +for (int k = 3; k <= 4; k++) { + number_negated_clone(mp->half_cos[k], mp->half_cos[4 - k]); + number_negated_clone(mp->d_cos[k], mp->d_cos[4 - k]); +} + +for (int k = 5; k <= 7; k++) { + number_clone(mp->half_cos[k], mp->half_cos[8 - k]); + number_clone(mp->d_cos[k], mp->d_cos[8 - k]); +} + +@ @<Dealloc...@>= +for (int k = 0; k <= 7; k++) { + free_number(mp->half_cos[k]); + free_number(mp->d_cos[k]); +} + +@ The |convex_hull| function forces a pen polygon to be convex when it is +returned by |make_pen| and after any subsequent transformation where rounding +error might allow the convexity to be lost. The convex hull algorithm used here +is described by F.~P. Preparata and M.~I. Shamos [{\sl Computational Geometry}, +Springer-Verlag, 1985]. + +@<Declarations@>= +static mp_knot mp_convex_hull (MP mp, mp_knot h); + +@ @c +mp_knot mp_convex_hull (MP mp, mp_knot h) +{ + if (mp_pen_is_elliptical(h)) { + return h; + } else { + /* Make a polygonal pen convex */ + mp_knot l, r; /* the leftmost and rightmost knots */ + mp_knot p, q; /* knots being scanned */ + mp_knot s; /* the starting point for an upcoming scan */ + mp_number dx, dy; /* a temporary pointer */ + new_number(dx); + new_number(dy); + @<Set |l| to the leftmost knot in polygon~|h|@> + @<Set |r| to the rightmost knot in polygon~|h|@> + if (l != r) { + mp_knot s = mp_next_knot(r); + @<Find any knots on the path from |l| to |r| above the |l|-|r| line and move them past~|r|@> + @<Find any knots on the path from |s| to |l| below the |l|-|r| line and move them past~|l|@> + @<Sort the path from |l| to |r| by increasing $x$@> + @<Sort the path from |r| to |l| by decreasing $x$@> + } + if (l != mp_next_knot(l)) { + @<Do a Gramm scan and remove vertices where there is no left turn@> + } + free_number(dx); + free_number(dy); + return l; + } +} + +@<Declarations@>= +void mp_simplify_path (MP mp, mp_knot h); + +@ @c +void mp_simplify_path (MP mp, mp_knot h) +{ + mp_knot p = h; + (void) mp; + do { + p->left_x = p->x_coord; + p->left_y = p->y_coord; + p->right_x = p->x_coord; + p->right_y = p->y_coord; + p = mp_next_knot(p); + } while (p != h); +} + +@ All comparisons are done primarily on $x$ and secondarily on $y$. + +@<Set |l| to the leftmost knot in polygon~|h|@>= +l = h; +p = mp_next_knot(h); +while (p != h) { + if (number_lessequal(p->x_coord, l->x_coord) && (number_less(p->x_coord, l->x_coord) || number_less(p->y_coord, l->y_coord))) { + l = p; + } + p = mp_next_knot(p); +} + +@ @<Set |r| to the rightmost knot in polygon~|h|@>= +r = h; +p = mp_next_knot(h); +while (p != h) { + if (number_greaterequal(p->x_coord, r->x_coord) && (number_greater(p->x_coord, r->x_coord) || number_greater(p->y_coord, r->y_coord))) { + r = p; + } + p = mp_next_knot(p); +} + +@ @<Find any knots on the path from |l| to |r| above the |l|-|r| line...@>= +{ + mp_number arg1, arg2; + new_number(arg1); + new_number(arg2); + set_number_from_subtraction(dx, r->x_coord, l->x_coord); + set_number_from_subtraction(dy, r->y_coord, l->y_coord); + p = mp_next_knot(l); + while (p != r) { + q = mp_next_knot(p); + set_number_from_subtraction(arg1, p->y_coord, l->y_coord); + set_number_from_subtraction(arg2, p->x_coord, l->x_coord); + if (ab_vs_cd(dx, arg1, dy, arg2) > 0) { + mp_move_knot(mp, p, r); + } + p = q; + } + free_number(arg1); + free_number(arg2); +} + +@ The |move_knot| procedure removes |p| from a doubly linked list and inserts +it after |q|. + +@ @<Declarations@>= +static void mp_move_knot (MP mp, mp_knot p, mp_knot q); + +@ @c +void mp_move_knot (MP mp, mp_knot p, mp_knot q) +{ + (void) mp; + mp_next_knot(mp_prev_knot(p)) = mp_next_knot(p); + mp_prev_knot(mp_next_knot(p)) = mp_prev_knot(p); + mp_prev_knot(p) = q; + mp_next_knot(p) = mp_next_knot(q); + mp_next_knot(q) = p; + mp_prev_knot(mp_next_knot(p)) = p; +} + +@ @<Find any knots on the path from |s| to |l| below the |l|-|r| line...@>= +{ + mp_number arg1, arg2; + new_number(arg1); + new_number(arg2); + p = s; + while (p != l) { + q = mp_next_knot(p); + set_number_from_subtraction(arg1, p->y_coord, l->y_coord); + set_number_from_subtraction(arg2, p->x_coord, l->x_coord); + if (ab_vs_cd(dx, arg1, dy, arg2) < 0) { + mp_move_knot(mp, p, l); + } + p = q; + } + free_number(arg1); + free_number(arg2); +} + +@ The list is likely to be in order already so we just do linear insertions. +Secondary comparisons on $y$ ensure that the sort is consistent with the choice +of |l| and |r|. + +@<Sort the path from |l| to |r| by increasing $x$@>= +p = mp_next_knot(l); +while (p != r) { + q = mp_prev_knot(p); + while (number_greater(q->x_coord, p->x_coord)) { + q = mp_prev_knot(q); + } + while (number_equal(q->x_coord, p->x_coord)) { + if (number_greater(q->y_coord, p->y_coord)) { + q = mp_prev_knot(q); + } else { + break; + } + } + if (q == mp_prev_knot(p)) { + p = mp_next_knot(p); + } else { + p = mp_next_knot(p); + mp_move_knot(mp, mp_prev_knot(p), q); + } +} + +@ @<Sort the path from |r| to |l| by decreasing $x$@>= +p = mp_next_knot(r); +while (p != l) { + q = mp_prev_knot(p); + while (number_less(q->x_coord, p->x_coord)) { + q = mp_prev_knot(q); + } + while (number_equal(q->x_coord, p->x_coord)) { + if (number_less(q->y_coord, p->y_coord)) { + q = mp_prev_knot(q); + } else { + break; + } + } + if (q == mp_prev_knot(p)) { + p = mp_next_knot(p); + } else { + p = mp_next_knot(p); + mp_move_knot(mp, mp_prev_knot(p), q); + } +} + +@ The condition involving |ab_vs_cd| tests if there is not a left turn at knot +|q|. There usually will be a left turn so we streamline the case where the |then| +clause is not executed. + +@<Do a Gramm scan and remove vertices where there...@>= +mp_number arg1, arg2; +new_number(arg1); +new_number(arg2); +p = l; +q = mp_next_knot(l); +while (1) { + set_number_from_subtraction(dx, q->x_coord, p->x_coord); + set_number_from_subtraction(dy, q->y_coord, p->y_coord); + p = q; + q = mp_next_knot(q); + if (p == l) { + break; + } else if (p != r) { + set_number_from_subtraction(arg1, q->y_coord, p->y_coord); + set_number_from_subtraction(arg2, q->x_coord, p->x_coord); + if (ab_vs_cd(dx, arg1, dy, arg2) <= 0) { + /* Remove knot |p| and back up |p| and |q| but don't go past |l|. */ + s = mp_prev_knot(p); + mp_memory_free(p); + mp_next_knot(s) = q; + mp_prev_knot(q) = s; + if (s == l) { + p = s; + } else { + p = mp_prev_knot(s); + q = s; + } + } + } +} +free_number(arg1); +free_number(arg2); + +@ The |find_offset| procedure sets global variables |(cur_x,cur_y)| to the offset +associated with the given direction |(x,y)|. If two different offsets apply, it +chooses one of them. + +@c +static void mp_find_offset (MP mp, mp_number *x_orig, mp_number *y_orig, mp_knot h) +{ + if (mp_pen_is_elliptical(h)) { + mp_fraction xx, yy; /* untransformed offset for an elliptical pen */ + mp_number wx, wy, hx, hy; /* the transformation matrix for an elliptical pen */ + mp_fraction d; /* a temporary register */ + new_fraction(xx); + new_fraction(yy); + new_number(wx); + new_number(wy); + new_number(hx); + new_number(hy); + new_fraction(d); + @<Find the offset for |(x,y)| on the elliptical pen~|h|@> + free_number(xx); + free_number(yy); + free_number(wx); + free_number(wy); + free_number(hx); + free_number(hy); + free_number(d); + } else { + mp_knot p, q; /* consecutive knots */ + mp_number arg1, arg2; + new_number(arg1); + new_number(arg2); + q = h; + do { + p = q; + q = mp_next_knot(q); + set_number_from_subtraction(arg1, q->x_coord, p->x_coord); + set_number_from_subtraction(arg2, q->y_coord, p->y_coord); + } while (ab_vs_cd(arg1, *y_orig, arg2, *x_orig) < 0); + do { + p = q; + q = mp_next_knot(q); + set_number_from_subtraction(arg1, q->x_coord, p->x_coord); + set_number_from_subtraction(arg2, q->y_coord, p->y_coord); + } while (ab_vs_cd(arg1, *y_orig, arg2, *x_orig) > 0); + number_clone(mp->cur_x, p->x_coord); + number_clone(mp->cur_y, p->y_coord); + free_number(arg1); + free_number(arg2); + } +} + +@ @<Glob...@>= +mp_number cur_x; +mp_number cur_y; /* all-purpose return value registers */ + +@ @<Initialize table entries@>= +new_number(mp->cur_x); +new_number(mp->cur_y); + +@ @<Dealloc...@>= +free_number(mp->cur_x); +free_number(mp->cur_y); + +@ @<Find the offset for |(x,y)| on the elliptical pen~|h|@>= +if (number_zero(*x_orig) && number_zero(*y_orig)) { + number_clone(mp->cur_x, h->x_coord); + number_clone(mp->cur_y, h->y_coord); +} else { + mp_number x, y, abs_x, abs_y; + new_number_clone(x, *x_orig); + new_number_clone(y, *y_orig); + @<Find the non-constant part of the transformation for |h|@> + new_number_abs(abs_x, x); + new_number_abs(abs_y, y); + while (number_less(abs_x, fraction_half_t) && number_less(abs_y, fraction_half_t)) { + number_double(x); + number_double(y); + number_abs_clone(abs_x, x); + number_abs_clone(abs_y, y); + } + @<Make |(xx,yy)| the offset on the untransformed |pencircle| for the untransformed version of |(x,y)|@> + { + mp_number r1, r2; + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, xx, wx); + take_fraction(r2, yy, hx); + number_add(r1, r2); + set_number_from_addition(mp->cur_x, h->x_coord, r1); + take_fraction(r1, xx, wy); + take_fraction(r2, yy, hy); + number_add(r1, r2); + set_number_from_addition(mp->cur_y, h->y_coord, r1); + free_number(r1); + free_number(r2); + } + free_number(abs_x); + free_number(abs_y); + free_number(x); + free_number(y); +} + +@ @<Find the non-constant part of the transformation for |h|@>= +set_number_from_subtraction(wx, h->left_x, h->x_coord); +set_number_from_subtraction(wy, h->left_y, h->y_coord); +set_number_from_subtraction(hx, h->right_x, h->x_coord); +set_number_from_subtraction(hy, h->right_y, h->y_coord); + +@ @<Make |(xx,yy)| the offset on the untransformed |pencircle| for the...@>= +{ + mp_number r1, r2, arg1; + new_number(arg1); + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, x, hy); + number_negated_clone(arg1, hx); + take_fraction(r2, y, arg1); + number_add(r1, r2); + number_negate(r1); + number_clone(yy, r1); + number_negated_clone(arg1, wy); + take_fraction(r1, x, arg1); + take_fraction(r2, y, wx); + number_add(r1, r2); + number_clone(xx, r1); + free_number(arg1); + free_number(r1); + free_number(r2); +} +pyth_add(d, xx, yy); +if (number_positive(d)) { + mp_number ret; + new_fraction(ret); + make_fraction(ret, xx, d); + number_half(ret); + number_clone(xx, ret); + make_fraction(ret, yy, d); + number_half(ret); + number_clone(yy, ret); + free_number(ret); +} + +@ Finding the bounding box of a pen is easy except if the pen is elliptical. But +we can handle that case by just calling |find_offset| twice. The answer is stored +in the global variables |minx|, |maxx|, |miny|, and |maxy|. + +@c +static void mp_pen_bbox (MP mp, mp_knot h) +{ + if (mp_pen_is_elliptical(h)) { + mp_number arg1, arg2; + new_number(arg1); + new_fraction(arg2); + number_clone(arg2, fraction_one_t); + mp_find_offset(mp, &arg1, &arg2, h); + number_clone(mp_maxx, mp->cur_x); + number_clone(mp_minx, h->x_coord); + number_double(mp_minx); + number_subtract(mp_minx, mp->cur_x); + number_negate(arg2); + mp_find_offset(mp, &arg2, &arg1, h); + number_clone(mp_maxy, mp->cur_y); + number_clone(mp_miny, h->y_coord); + number_double(mp_miny); + number_subtract(mp_miny, mp->cur_y); + free_number(arg1); + free_number(arg2); + } else { + mp_knot p = mp_next_knot(h); /* for scanning the knot list */ + number_clone(mp_minx, h->x_coord); + number_clone(mp_maxx, mp_minx); + number_clone(mp_miny, h->y_coord); + number_clone(mp_maxy, mp_miny); + while (p != h) { + if (number_less(p->x_coord, mp_minx)) { + number_clone(mp_minx, p->x_coord); + } + if (number_less(p->y_coord, mp_miny)) { + number_clone(mp_miny, p->y_coord); + } + if (number_greater(p->x_coord, mp_maxx)) { + number_clone(mp_maxx, p->x_coord); + } + if (number_greater(p->y_coord, mp_maxy)) { + number_clone(mp_maxy, p->y_coord); + } + p = mp_next_knot(p); + } + } +} + +@* Numerical values. + +This first set goes into the header + +@<MPlib internal header stuff@>= +@d mp_fraction mp_number +@d mp_angle mp_number + +@d new_number(A) mp->math->md_allocate(mp, &(A), mp_scaled_type) +@d new_fraction(A) mp->math->md_allocate(mp, &(A), mp_fraction_type) +@d new_angle(A) mp->math->md_allocate(mp, &(A), mp_angle_type) + +@d new_number_clone(A,B) mp->math->md_allocate_clone(mp, &(A), mp_scaled_type, &(B)) +@d new_fraction_clone(A,B) mp->math->md_allocate_clone(mp, &(A), mp_fraction_type, &(B)) +@d new_angle_clone(A,B) mp->math->md_allocate_clone(mp, &(A), mp_angle_type, &(B)) + +@d new_number_from_double(mp,A,B) mp->math->md_allocate_double(mp, &(A), B) +@d new_number_abs(A,B) mp->math->md_allocate_abs(mp, &(A), mp_scaled_type, &(B)) + +@d free_number(A) mp->math->md_free(mp, &(A)) + +@d set_precision() mp->math->md_set_precision(mp) +@d free_math() mp->math->md_free_math(mp) +@d scan_numeric_token(A) mp->math->md_scan_numeric(mp,A) +@d scan_fractional_token(A) mp->math->md_scan_fractional(mp,A) +@d set_number_from_of_the_way(A,t,B,C) mp->math->md_from_oftheway(mp,&(A),&(t),&(B),&(C)) +@d set_number_from_int(A,B) mp->math->md_from_int(&(A),B) +@d set_number_from_scaled(A,B) mp->math->md_from_scaled(&(A),B) +@d set_number_from_boolean(A,B) mp->math->md_from_boolean(&(A),B) +@d set_number_from_double(A,B) mp->math->md_from_double(&(A),B) +@d set_number_from_addition(A,B,C) mp->math->md_from_addition(&(A),&(B),&(C)) +@d set_number_half_from_addition(A,B,C) mp->math->md_half_from_addition(&(A),&(B),&(C)) +@d set_number_from_subtraction(A,B,C) mp->math->md_from_subtraction(&(A),&(B),&(C)) +@d set_number_half_from_subtraction(A,B,C) mp->math->md_half_from_subtraction(&(A),&(B),&(C)) +@d set_number_from_div(A,B,C) mp->math->md_from_div(&(A),&(B),&(C)) +@d set_number_from_mul(A,B,C) mp->math->md_from_mul(&(A),&(B),&(C)) +@d number_int_div(A,C) mp->math->md_from_int_div(&(A),&(A),C) +@d set_number_from_int_mul(A,B,C) mp->math->md_from_int_mul(&(A),&(B),C) + +@d set_number_to_unity(A) mp->math->md_clone(&(A), &unity_t) +@d set_number_to_zero(A) mp->math->md_clone(&(A), &zero_t) +@d set_number_to_inf(A) mp->math->md_clone(&(A), &inf_t) +@d set_number_to_negative_inf(A) mp->math->md_clone(&(A), &negative_inf_t) +@d old_set_number_to_neg_inf(A) do { set_number_to_inf(A); number_negate(A); } while (0) + +@d init_randoms(A) mp->math->md_init_randoms(mp,A) +@d print_number(A) mp->math->md_print(mp,&(A)) +@d number_tostring(A) mp->math->md_tostring(mp,&(A)) +@d make_scaled(R,A,B) mp->math->md_make_scaled(mp,&(R),&(A),&(B)) +@d take_scaled(R,A,B) mp->math->md_take_scaled(mp,&(R),&(A),&(B)) +@d make_fraction(R,A,B) mp->math->md_make_fraction(mp,&(R),&(A),&(B)) +@d take_fraction(R,A,B) mp->math->md_take_fraction(mp,&(R),&(A),&(B)) +@d pyth_add(R,A,B) mp->math->md_pyth_add(mp,&(R),&(A),&(B)) +@d pyth_sub(R,A,B) mp->math->md_pyth_sub(mp,&(R),&(A),&(B)) +@d power_of(R,A,B) mp->math->md_power_of(mp,&(R),&(A),&(B)) +@d n_arg(R,A,B) mp->math->md_n_arg(mp,&(R),&(A),&(B)) +@d m_log(R,A) mp->math->md_m_log(mp,&(R),&(A)) +@d m_exp(R,A) mp->math->md_m_exp(mp,&(R),&(A)) +@d m_unif_rand(R,A) mp->math->md_m_unif_rand(mp,&(R),&(A)) +@d m_norm_rand(R) mp->math->md_m_norm_rand(mp,&(R)) +@d velocity(R,A,B,C,D,E) mp->math->md_velocity(mp,&(R),&(A),&(B),&(C),&(D),&(E)) +@d ab_vs_cd(A,B,C,D) mp->math->md_ab_vs_cd(&(A),&(B),&(C),&(D)) +@d crossing_point(R,A,B,C) mp->math->md_crossing_point(mp,&(R),&(A),&(B),&(C)) +@d n_sin_cos(A,S,C) mp->math->md_sin_cos(mp,&(A),&(S),&(C)) +@d square_rt(A,S) mp->math->md_sqrt(mp,&(A),&(S)) +@d slow_add(R,A,B) mp->math->md_slow_add(mp,&(R),&(A),&(B)) +@d round_unscaled(A) mp->math->md_round_unscaled(&(A)) +@d floor_scaled(A) mp->math->md_floor_scaled(&(A)) +@d fraction_to_round_scaled(A) mp->math->md_fraction_to_round_scaled(&(A)) +@d number_to_int(A) mp->math->md_to_int(&(A)) +@d number_to_boolean(A) mp->math->md_to_boolean(&(A)) +@d number_to_scaled(A) mp->math->md_to_scaled(&(A)) +@d number_to_double(A) mp->math->md_to_double(&(A)) +@d number_negate(A) mp->math->md_negate(&(A)) +@d number_add(A,B) mp->math->md_add(&(A),&(B)) +@d number_subtract(A,B) mp->math->md_subtract(&(A),&(B)) +@d number_half(A) mp->math->md_half(&(A)) +@d number_double(A) mp->math->md_do_double(&(A)) +@d number_add_scaled(A,B) mp->math->md_add_scaled(&(A),B) +@d number_multiply_int(A,B) mp->math->md_multiply_int(&(A),B) +@d number_divide_int(A,B) mp->math->md_divide_int(&(A),B) +@d number_abs(A) mp->math->md_abs(&(A)) +@d number_modulo(A,B) mp->math->md_modulo(&(A),&(B)) +@d number_nonequalabs(A,B) mp->math->md_nonequalabs(&(A),&(B)) +@d number_odd(A) mp->math->md_odd(&(A)) +@d number_equal(A,B) mp->math->md_equal(&(A),&(B)) +@d number_greater(A,B) mp->math->md_greater(&(A),&(B)) +@d number_less(A,B) mp->math->md_less(&(A),&(B)) +@d number_clone(A,B) mp->math->md_clone(&(A),&(B)) +@d number_negated_clone(A,B) mp->math->md_negated_clone(&(A),&(B)) +@d number_abs_clone(A,B) mp->math->md_abs_clone(&(A),&(B)) +@d number_swap(A,B) mp->math->md_swap(&(A),&(B)); +@d convert_scaled_to_angle(A) mp->math->md_scaled_to_angle(&(A)); +@d convert_angle_to_scaled(A) mp->math->md_angle_to_scaled(&(A)); +@d convert_fraction_to_scaled(A) mp->math->md_fraction_to_scaled(&(A)); +@d convert_scaled_to_fraction(A) mp->math->md_scaled_to_fraction(&(A)); + +@d number_zero(A) number_equal(A, zero_t) +@d number_infinite(A) number_equal(A, inf_t) +@d number_unity(A) number_equal(A, unity_t) +@d number_negative(A) number_less(A, zero_t) +@d number_nonnegative(A) (! number_negative(A)) +@d number_positive(A) number_greater(A, zero_t) +@d number_nonpositive(A) (! number_positive(A)) +@d number_nonzero(A) (! number_zero(A)) +@d number_greaterequal(A,B) (! number_less(A,B)) +@d number_lessequal(A,B) (! number_greater(A,B)) + +@* Edge structures. + +Now we come to \MP's internal scheme for representing pictures. The +representation is very different from \MF's edge structures because \MP\ pictures +contain \ps\ graphics objects instead of pixel images. However, the basic idea is +somewhat similar in that shapes are represented via their boundaries. + +The main purpose of edge structures is to keep track of graphical objects until +it is time to translate them into \ps. Since \MP\ does not need to know anything +about an edge structure other than how to translate it into \ps\ and how to find +its bounding box, edge structures can be just linked lists of graphical objects. +\MP\ has no easy way to determine whether two such objects overlap, but it +suffices to draw the first one first and let the second one overwrite it if +necessary. + +@<MPlib header stuff@>= +enum mp_graphical_object_code { + mp_unset_code, + mp_fill_code, + mp_stroked_code, + mp_start_clip_code, /* |type| of a node that starts clipping */ + mp_start_group_code, /* |type| of a node that gives a |setgroup| path */ + mp_start_bounds_code, /* |type| of a node that gives a |setbounds| path */ + mp_stop_clip_code, /* |type| of a node that stops clipping */ + mp_stop_group_code, /* |type| of a node that stops grouping */ + mp_stop_bounds_code, /* |type| of a node that stops |setbounds| */ + mp_final_graphic +}; + +@ Let's consider the types of graphical objects one at a time. First of all, a +filled contour is represented by a eight-word node. The first word contains +|type| and |link| fields, and the next six words contain a pointer to a cyclic +path and the value to use for \ps' |currentrgbcolor| parameter. If a pen is +used for filling |pen_p|, |linejoin| and |miterlimit| give the relevant information. + +We can actually be more sparse: |color_model|, |line_join| and |pen_type| can be +chars: a todo. + +We don't save that much by distinguishing between a stroke and a fill object and +we can save some code when we make then the same. Todo: use char for some. + +@<MPlib internal header stuff@>= +typedef struct mp_shape_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int stacking; + struct mp_node_data *link; + /*common */ + mp_string pre_script; + mp_string post_script; + union { + mp_number red; + mp_number cyan; + }; + union { + mp_number green; + mp_number magenta; + }; + union { + mp_number blue; + mp_number yellow; + }; + union { + mp_number black; + mp_number grey; + }; + /*specific to paths */ + mp_knot path; + mp_knot pen; + mp_node dash; + mp_number dashscale; + mp_number miterlimit; + unsigned char color_model; + unsigned char linejoin; + unsigned char linecap; + unsigned char pen_type; +} mp_shape_node_data; + +typedef struct mp_shape_node_data *mp_shape_node; + +@d mp_path_ptr(A) (A)->path +@d mp_pen_ptr(A) (A)->pen +@d mp_dash_ptr(A) ((mp_shape_node) (A))->dash +@d mp_line_cap(A) ((mp_shape_node) (A))->linecap +@d mp_line_join(A) ((mp_shape_node) (A))->linejoin +@d mp_miterlimit(A) ((mp_shape_node) (A))->miterlimit + +@d mp_set_linecap(A,B) ((mp_shape_node) (A))->linecap = (short) (B) +@d mp_set_linejoin(A,B) ((mp_shape_node) (A))->linejoin = (short) (B) + +@d mp_pre_script(A) ((mp_shape_node) (A))->pre_script +@d mp_post_script(A) ((mp_shape_node) (A))->post_script +@d mp_color_model(A) ((mp_shape_node) (A))->color_model +@d mp_stacking(A) ((mp_shape_node) (A))->stacking +@d mp_pen_type(A) ((mp_shape_node) (A))->pen_type + +@d mp_cyan_color(A) ((mp_shape_node) (A))->cyan +@d mp_magenta_color(A) ((mp_shape_node) (A))->magenta +@d mp_yellow_color(A) ((mp_shape_node) (A))->yellow +@d mp_black_color(A) ((mp_shape_node) (A))->black +@d mp_red_color(A) ((mp_shape_node) (A))->red +@d mp_green_color(A) ((mp_shape_node) (A))->green +@d mp_blue_color(A) ((mp_shape_node) (A))->blue +@d mp_gray_color(A) ((mp_shape_node) (A))->grey +@d mp_grey_color(A) ((mp_shape_node) (A))->grey + +@ Make a shape node. A fill node is a cyclic path |p|. A stroked path is a node +that is like a filled contour node except that it contains the current |linecap| +value, a scale factor for the dash pattern, and a pointer that is non-NULL if the +stroke is to be dashed. The purpose of the scale factor is to allow a picture to +be transformed without touching the picture that |dash_p| points to. + +@c +static mp_node mp_new_shape_node (MP mp, mp_knot p, int type) +{ + mp_shape_node t = mp_allocate_node(mp, sizeof(mp_shape_node_data)); + mp_type(t) = type; + mp_path_ptr(t) = p; + mp_pen_ptr(t) = NULL; /* |NULL| means don't use a pen */ + mp_dash_ptr(t) = NULL; + new_number(t->red); + new_number(t->green); + new_number(t->blue); + new_number(t->black); + new_number(t->miterlimit); + new_number(t->dashscale); + set_number_to_unity(t->dashscale); + mp_color_model(t) = mp_uninitialized_model; + mp_pen_type(t) = 0; + mp_pre_script(t) = NULL; + mp_post_script(t) = NULL; + /* Set the |linejoin| and |miterlimit| fields in object |t| */ + if (number_greater(internal_value(mp_linejoin_internal), unity_t)) { + t->linejoin = mp_beveled_linejoin_code; + } else if (number_positive(internal_value(mp_linejoin_internal))) { + t->linejoin = mp_rounded_linejoin_code; + } else { + t->linejoin = mp_mitered_linejoin_code; + } + t->stacking = round_unscaled(internal_value(mp_stacking_internal)); + if (number_less(internal_value(mp_miterlimit_internal), unity_t)) { + set_number_to_unity(t->miterlimit); + } else { + number_clone(t->miterlimit, internal_value(mp_miterlimit_internal)); + } + if (number_greater(internal_value(mp_linecap_internal), unity_t)) { + t->linecap = mp_squared_linecap_code; + } else if (number_positive(internal_value(mp_linecap_internal))) { + t->linecap = mp_rounded_linecap_code; + } else { + t->linecap = mp_butt_linecap_code; + } + return (mp_node) t; +} + +@ @c +static mp_edge_header_node mp_free_shape_node (MP mp, mp_shape_node p) +{ + mp_edge_header_node e = NULL; + mp_toss_knot_list(mp, mp_path_ptr(p)); + if (mp_pen_ptr(p) != NULL) { + mp_toss_knot_list(mp, mp_pen_ptr(p)); + } + if (mp_pre_script(p) != NULL) { + delete_str_ref(mp_pre_script(p)); + } + if (mp_post_script(p) != NULL) { + delete_str_ref(mp_post_script(p)); + } + e = (mp_edge_header_node) mp_dash_ptr(p); + free_number(p->red); + free_number(p->green); + free_number(p->blue); + free_number(p->black); + free_number(p->miterlimit); + free_number(p->dashscale); + mp_free_node(mp, (mp_node) p, sizeof(mp_shape_node_data)); + return e ; +} + +@ When a dashed line is computed in a transformed coordinate system, the dash +lengths get scaled like the pen shape and we need to compensate for this. Since +there is no unique scale factor for an arbitrary transformation, we use the the +square root of the determinant. The properties of the determinant make it easier +to maintain the |dashscale|. The computation is fairly straight-forward except +for the initialization of the scale factor |s|. The factor of 64 is needed +because |square_rt| scales its result by $2^8$ while we need $2^{14}$ to +counteract the effect of |take_fraction|. + +@c +void mp_sqrt_det (MP mp, mp_number *ret, mp_number *a_orig, mp_number *b_orig, mp_number *c_orig, mp_number *d_orig) +{ + mp_number a, b, c, d; + mp_number maxabs; /* $max(|a|,|b|,|c|,|d|)$ */ + unsigned s = 64; /* amount by which the result of |square_rt| needs to be scaled */ + mp_number tmp; + new_number_clone(a, *a_orig); + new_number_clone(b, *b_orig); + new_number_clone(c, *c_orig); + new_number_clone(d, *d_orig); + /* Initialize |maxabs| */ + new_number_abs(maxabs, a); + new_number_abs(tmp, b); + if (number_greater(tmp, maxabs)) { + number_clone(maxabs, tmp); + } + number_abs_clone(tmp, c); + if (number_greater(tmp, maxabs)) { + number_clone(maxabs, tmp); + } + number_abs_clone(tmp, d); + if (number_greater(tmp, maxabs)) { + number_clone(maxabs, tmp); + } + free_number(tmp); + while ((number_less(maxabs, fraction_one_t)) && (s > 1)) { + number_double(a); + number_double(b); + number_double(c); + number_double(d); + number_double(maxabs); + s = s/2; + } + { + mp_number r1, r2; + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, a, d); + take_fraction(r2, b, c); + number_subtract(r1, r2); + number_abs(r1); + square_rt(*ret, r1); + number_multiply_int(*ret, s); + free_number(r1); + free_number(r2); + } + free_number(a); + free_number(b); + free_number(c); + free_number(d); + free_number(maxabs); +} + +static void mp_get_pen_scale (MP mp, mp_number *ret, mp_knot p) +{ + if (p == NULL) { + set_number_to_zero(*ret); + } else { + mp_number a, b, c, d; + new_number(a); + new_number(b); + new_number(c); + new_number(d); + set_number_from_subtraction(a, p->left_x, p->x_coord); + set_number_from_subtraction(b, p->right_x, p->x_coord); + set_number_from_subtraction(c, p->left_y, p->y_coord); + set_number_from_subtraction(d, p->right_y, p->y_coord); + mp_sqrt_det(mp, ret, &a, &b, &c, &d); + free_number(a); + free_number(b); + free_number(c); + free_number(d); + } +} + +@ @<Declarations@>= +static void mp_sqrt_det (MP mp, mp_number *ret, mp_number *a_orig, mp_number *b_orig, mp_number *c_orig, mp_number *d_orig); + +@ The last two types of graphical objects that can occur in an edge structure are +clipping paths and |setbounds| paths. These are slightly more difficult +@:set_bounds_}{|setbounds| primitive@> to implement because we must keep track +of exactly what is being clipped or bounded when pictures get merged together. +For this reason, each clipping or |setbounds| operation is represented by a +pair of nodes: first comes a node whose |path_ptr| gives the relevant path, then +there is the list of objects to clip or bound followed by a closing node. + +@d mp_has_color(A) (mp_type((A))<mp_start_clip_node_type) /* does a graphical object have color fields? */ +@d mp_has_script(A) (mp_type((A))<=mp_start_bounds_node_type) /* does a graphical object have color fields? */ +@d mp_has_pen(A) (mp_type((A))<=mp_stroked_node_type) /* does a graphical object have a |mp_pen_ptr| field? */ + +@d mp_is_start_or_stop(A) (mp_type((A))>=mp_start_clip_node_type) +@d mp_is_stop(A) (mp_type((A))>=mp_stop_clip_node_type) + +@<MPlib internal header stuff@>= +typedef struct mp_start_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int stacking; + struct mp_node_data *link; + /*specific */ + mp_string pre_script; + mp_string post_script; + mp_knot path; +} mp_start_node_data; + +typedef struct mp_start_node_data *mp_start_node; + +typedef struct mp_stop_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int stacking; + struct mp_node_data *link; + /*specific */ +} mp_stop_node_data; + +typedef struct mp_stop_node_data *mp_stop_node; + +@ Make a node of type |c| where |p| is the clipping or |setbounds| path. + +@c +static mp_node mp_new_bounds_node (MP mp, mp_knot p, int c) +{ + switch (c) { + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + { + mp_start_node t = (mp_start_node) mp_allocate_node(mp, sizeof(mp_start_node_data)); + mp_type(t) = c; + t->path = p; + t->link = NULL; + t->stacking = round_unscaled(internal_value(mp_stacking_internal)); + mp_pre_script(t) = NULL; + mp_post_script(t) = NULL; + return (mp_node) t; + } + break; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + { + mp_stop_node t = (mp_stop_node) mp_allocate_node(mp, sizeof(mp_stop_node_data)); + mp_type(t) = c; + t->link = NULL; + t->stacking = round_unscaled(internal_value(mp_stacking_internal)); + return (mp_node) t; + } + break; + default: + /* maybe some message */ + break; + } + return NULL; +} + +@ @c +static void mp_free_start_node (MP mp, mp_start_node p) +{ + mp_toss_knot_list(mp, mp_path_ptr(p)); + if (mp_pre_script(p) != NULL) { + delete_str_ref(mp_pre_script(p)); + } + if (mp_post_script(p) != NULL) { + delete_str_ref(mp_post_script(p)); + } + mp_free_node(mp, (mp_node) p, sizeof(mp_start_node_data)); +} + +static void mp_free_stop_node (MP mp, mp_stop_node p) +{ + mp_free_node(mp, (mp_node) p, sizeof(mp_stop_node_data)); +} + +@ All the essential information in an edge structure is encoded as a linked list +of graphical objects as we have just seen, but it is helpful to add some +redundant information. A single edge structure might be used as a dash pattern +many times, and it would be nice to avoid scanning the same structure repeatedly. +Thus, an edge structure known to be a suitable dash pattern has a header that +gives a list of dashes in a sorted order designed for rapid translation into \ps. + +Each dash is represented by a three-word node containing the initial and final +$x$~coordinates as well as the usual |link| field. The |link| fields points to +the dash node with the next higher $x$-coordinates and the final link points to a +special location called |null_dash|. (There should be no overlap between dashes). +Since the $y$~coordinate of the dash pattern is needed to determine the period of +repetition, this needs to be stored in the edge header along with a pointer to +the list of dash nodes. + +The |dash_info| is explained below. + +@d mp_get_dash_list(A) (mp_dash_node) (((mp_dash_node) (A))->link) /* in an edge header this points to the first dash node */ +@d mp_set_dash_list(A,B) ((mp_dash_node) (A))->link = (mp_node) ((B)) /* in an edge header this points to the first dash node */ + +@<MPlib internal header stuff@>= +typedef struct mp_dash_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_number start_x; /* the starting $x$~coordinate in a dash node */ + mp_number stop_x; /* the ending $x$~coordinate in a dash node */ + mp_number dash_y; /* $y$ value for the dash list in an edge header */ + mp_node dash_info; +} mp_dash_node_data; + +@ @<Types...@>= +typedef struct mp_dash_node_data *mp_dash_node; + +@ @<Initialize table entries@>= +mp->null_dash = mp_get_dash_node(mp); + +@ @<Free table entries@>= +mp_free_node(mp, (mp_node) mp->null_dash, sizeof(mp_dash_node_data)); + +@c +static mp_dash_node mp_get_dash_node (MP mp) +{ + mp_dash_node p = (mp_dash_node) mp_allocate_node(mp, sizeof(mp_dash_node_data)); + p->hasnumber = 0; + new_number(p->start_x); + new_number(p->stop_x); + new_number(p->dash_y); + mp_type(p) = mp_dash_node_type; + return p; +} + +@ It is also convenient for an edge header to contain the bounding box +information needed by the |llcorner| and |urcorner| operators so that this +does not have to be recomputed unnecessarily. This is done by adding fields for +the $x$~and $y$ extremes as well as a pointer that indicates how far the bounding +box computation has gotten. Thus if the user asks for the bounding box and then +adds some more text to the picture before asking for more bounding box +information, the second computation need only look at the additional text. + +When the bounding box has not been computed, the |bblast| pointer points to a +dummy link at the head of the graphical object list while the |minx_val| and +|miny_val| fields contain |EL_GORDO| and the |maxx_val| and |maxy_val| fields +contain |-EL_GORDO|. + +Since the bounding box of pictures containing objects of type +|mp_start_bounds_node| depends on the value of |truecorners|, the bounding box +@:mp_true_corners_}{|truecorners| primitive@> data might not be valid for all +values of this parameter. Hence, the |bbtype| field is needed to keep track of +this. + +@d mp_bblast(A) ((mp_edge_header_node) (A))->bblast /* last item considered in bounding box computation */ +@d mp_edge_list(A) ((mp_edge_header_node) (A))->list /* where the object list begins in an edge header */ + +@<MPlib internal header stuff@>= +typedef struct mp_edge_header_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int padding; + struct mp_node_data *link; + /*specific */ + mp_number start_x; + mp_number stop_x; + mp_number dash_y; + mp_node dash_info; + mp_number minx; + mp_number miny; + mp_number maxx; + mp_number maxy; + mp_node bblast; + int bbtype; /* tells how bounding box data depends on |truecorners| */ + int ref_count; /* explained below */ + mp_node list; + mp_node obj_tail; /* explained below */ +} mp_edge_header_node_data; + +typedef struct mp_edge_header_node_data *mp_edge_header_node; + +typedef enum mp_bound_codes { + mp_no_bounds_code, /* |bbtype| value when bounding box data is valid for all |truecorners| values */ + mp_bounds_set_code, /* |bbtype| value when bounding box data is for |truecorners|${}\le 0$ */ + mp_bounds_unset_code, /* |bbtype| value when bounding box data is for |truecorners|${}>0$ */ +} mp_bound_codes; + +@ @c +static void mp_init_bbox (MP mp, mp_edge_header_node h) +{ + /* Initialize the bounding box information in edge structure |h| */ + (void) mp; + mp_bblast(h) = mp_edge_list(h); + h->bbtype = mp_no_bounds_code; + set_number_to_inf(h->minx); + set_number_to_inf(h->miny); + set_number_to_negative_inf(h->maxx); + set_number_to_negative_inf(h->maxy); +} + +@ The only other entries in an edge header are a reference count in the first +word and a pointer to the tail of the object list in the last word. + +@d mp_obj_tail(A) ((mp_edge_header_node) (A))->obj_tail /* points to the last entry in the object list */ +@d mp_edge_ref_count(A) ((mp_edge_header_node) (A))->ref_count + +@ @c +static mp_edge_header_node mp_get_edge_header_node (MP mp) +{ + mp_edge_header_node p = (mp_edge_header_node) mp_allocate_node(mp, sizeof(mp_edge_header_node_data)); + mp_type(p) = mp_edge_header_node_type; + new_number(p->start_x); + new_number(p->stop_x); + new_number(p->dash_y); + new_number(p->minx); + new_number(p->miny); + new_number(p->maxx); + new_number(p->maxy); + p->list = mp_new_token_node(mp); /* or whatever, just a need a link handle */ + return p; +} + +static void mp_init_edges (MP mp, mp_edge_header_node h) +{ + /* initialize an edge header to NULL values */ + mp_set_dash_list(h, mp->null_dash); + mp_obj_tail(h) = mp_edge_list(h); + mp_link(mp_edge_list(h)) = NULL; + mp_edge_ref_count(h) = 0; + mp_init_bbox(mp, h); +} + +@ Here is how edge structures are deleted. The process can be recursive because +of the need to dereference edge structures that are used as dash patterns. +@^recursion@> + +@d mp_add_edge_ref(mp,A) mp_edge_ref_count((A)) += 1 + +@d mp_delete_edge_ref(mp,A) { + if (mp_edge_ref_count((A)) == 0) { + mp_toss_edges(mp, (mp_edge_header_node) (A)); + } else { + mp_edge_ref_count((A)) -= 1; + } +} + +@<Declarations@>= +static void mp_flush_dash_list (MP mp, mp_edge_header_node h); +static mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p); +static void mp_toss_edges (MP mp, mp_edge_header_node h); + +@ @c +void mp_toss_edges (MP mp, mp_edge_header_node h) +{ + mp_node q; /* pointers that scan the list being recycled */ + mp_edge_header_node r; /* an edge structure that object |p| refers to */ + mp_flush_dash_list(mp, h); + q = mp_link(mp_edge_list(h)); + while (q != NULL) { + mp_node p = q; + q = mp_link(q); + r = mp_toss_gr_object(mp, p); + if (r != NULL) { + mp_delete_edge_ref(mp, r); + } + } + free_number(h->start_x); + free_number(h->stop_x); + free_number(h->dash_y); + free_number(h->minx); + free_number(h->miny); + free_number(h->maxx); + free_number(h->maxy); + mp_free_token_node(mp, h->list); + mp_free_node(mp, (mp_node) h, sizeof(mp_edge_header_node_data)); +} + +void mp_flush_dash_list (MP mp, mp_edge_header_node h) +{ + mp_dash_node q = mp_get_dash_list(h); + while (q != mp->null_dash) { + mp_dash_node p = q; + q = (mp_dash_node) mp_link(q); + mp_free_node(mp, (mp_node) p, sizeof(mp_dash_node_data)); + } + mp_set_dash_list(h, mp->null_dash); +} + +mp_edge_header_node mp_toss_gr_object (MP mp, mp_node p) +{ + /* returns an edge structure that needs to be dereferenced */ + switch (mp_type(p)) { + case mp_fill_node_type: + case mp_stroked_node_type: + return mp_free_shape_node(mp, (mp_shape_node) p); + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + mp_free_start_node(mp, (mp_start_node) p); + return NULL; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + mp_free_stop_node(mp, (mp_stop_node) p); + return NULL; + default: + return NULL; + } +} + +@ If we use |add_edge_ref| to \quote {copy} edge structures, the real copying needs to +be done before making a significant change to an edge structure. Much of the work +is done in a separate routine |copy_objects| that copies a list of graphical +objects into a new edge header. + +@c +static mp_edge_header_node mp_private_edges (MP mp, mp_edge_header_node h) +{ + /* make a private copy of the edge structure headed by |h| */ + if (mp_edge_ref_count(h) == 0) { + return h; + } else { + mp_edge_header_node hh; /* the edge header for the new copy */ + mp_dash_node p, pp; /* pointers for copying the dash list */ + mp_edge_ref_count(h) -= 1; + hh = (mp_edge_header_node) mp_copy_objects (mp, mp_link(mp_edge_list(h)), NULL); + @<Copy the dash list from |h| to |hh|@> + @<Copy the bounding box information from |h| to |hh| and make |mp_bblast(hh)| point into the new object list@> + return hh; + } +} + +@ Here we use the fact that |mp_get_dash_list(hh)=mp_link(hh)|. @^data structure +assumptions@> + +@<Copy the dash list from |h| to |hh|@>= +pp = (mp_dash_node) hh; +p = mp_get_dash_list(h); +while ((p != mp->null_dash)) { + mp_link(pp) = (mp_node) mp_get_dash_node(mp); + pp = (mp_dash_node) mp_link(pp); + number_clone(pp->start_x, p->start_x); + number_clone(pp->stop_x, p->stop_x); + p = (mp_dash_node) mp_link(p); +} +mp_link(pp) = (mp_node) mp->null_dash; +number_clone(hh->dash_y, h->dash_y); + +@ |h| is an edge structure + +@c +static mp_dash_object *mp_export_dashes (MP mp, mp_shape_node q, mp_number *w) +{ + mp_dash_node h = (mp_dash_node) mp_dash_ptr(q); + if (h == NULL || mp_get_dash_list(h) == mp->null_dash) { + return NULL; + } else { + mp_dash_object *d; + mp_dash_node p; + mp_number scf; /* scale factor */ + mp_number dashoff; + double *dashes = NULL; + int num_dashes = 1; + new_number(scf); + p = mp_get_dash_list(h); + mp_get_pen_scale(mp, &scf, mp_pen_ptr(q)); + if (number_zero(scf)) { + if (number_zero(*w)) { + number_clone(scf, q->dashscale); + } else { + free_number(scf); + return NULL; + } + } else { + mp_number ret; + new_number(ret); + make_scaled(ret, *w, scf); + take_scaled(scf, ret, q->dashscale); + free_number(ret); + } + number_clone(*w, scf); + d = mp_allocate_dash(mp); + set_number_from_addition(mp->null_dash->start_x, p->start_x, h->dash_y); + { + mp_number ret, arg1; + new_number(ret); + new_number(arg1); + new_number(dashoff); + while (p != mp->null_dash) { + dashes = mp_memory_reallocate(dashes, (size_t) (num_dashes + 2) * sizeof(double)); + set_number_from_subtraction(arg1, p->stop_x, p->start_x); + take_scaled(ret, arg1, scf); + dashes[(num_dashes - 1)] = number_to_double(ret); + set_number_from_subtraction(arg1, ((mp_dash_node) mp_link(p))->start_x, p->stop_x); + take_scaled(ret, arg1, scf); + dashes[(num_dashes)] = number_to_double(ret); + dashes[(num_dashes + 1)] = -1.0; /* terminus */ + num_dashes += 2; + p = (mp_dash_node) mp_link(p); + } + d->array = dashes; + mp_dash_offset(mp, &dashoff, h); + take_scaled(ret, dashoff, scf); + d->offset = number_to_double(ret); + free_number(ret); + free_number(arg1); + } + free_number(dashoff); + free_number(scf); + return d; + } +} + +@ @<Copy the bounding box information from |h| to |hh|...@>= +number_clone(hh->minx, h->minx); +number_clone(hh->miny, h->miny); +number_clone(hh->maxx, h->maxx); +number_clone(hh->maxy, h->maxy); +hh->bbtype = h->bbtype; +p = (mp_dash_node) mp_edge_list(h); +pp = (mp_dash_node) mp_edge_list(hh); +while ((p != (mp_dash_node) mp_bblast(h))) { + if (p == NULL) { + mp_confusion(mp, "boundingbox last"); + @:this can't happen bblast}{\quad bblast@> + } else { + p = (mp_dash_node) mp_link(p); + pp = (mp_dash_node) mp_link(pp); + } +} +mp_bblast(hh) = (mp_node) pp; + +@ Here is the promised routine for copying graphical objects into a new edge +structure. It starts copying at object~|p| and stops just before object~|q|. If +|q| is NULL, it copies the entire sublist headed at |p|. The resulting edge +structure requires further initialization by |init_bbox|. + +@<Declarations@>= +static mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q); + +@ @c +mp_edge_header_node mp_copy_objects (MP mp, mp_node p, mp_node q) { + mp_node pp; /* the last newly copied object */ + int k = 0; /* temporary register */ + mp_edge_header_node hh = mp_get_edge_header_node(mp); /* the new edge header */ + mp_set_dash_list(hh, mp->null_dash); + mp_edge_ref_count(hh) = 0; + pp = mp_edge_list(hh); + while (p != q) { + @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@> + } + mp_obj_tail(hh) = pp; + mp_link(pp) = NULL; + return hh; +} + +@ @<Make |mp_link(pp)| point to a copy of object |p|, and update |p| and |pp|@>= +{ + switch (mp_type(p)) { + case mp_fill_node_type: + case mp_stroked_node_type: + k = sizeof(mp_shape_node_data); + break; + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + k = sizeof(mp_start_node_data); + break; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + k = sizeof(mp_stop_node_data); + break; + default: + break; + } + mp_link(pp) = mp_allocate_node(mp, (size_t) k); /* |gr_object| */ + pp = mp_link(pp); + memcpy(pp, p, (size_t) k); + pp->link = NULL; + @<Fix anything in graphical object |pp| that should differ from the corresponding field in |p|@> + p = mp_link(p); +} + +@ @<Fix anything in graphical object |pp| that should differ from the...@>= +switch (mp_type(p)) { + case mp_fill_node_type: + case mp_stroked_node_type: + { + mp_shape_node tt = (mp_shape_node) pp; + mp_shape_node t = (mp_shape_node) p; + new_number_clone(tt->red, t->red); + new_number_clone(tt->green, t->green); + new_number_clone(tt->blue, t->blue); + new_number_clone(tt->black, t->black); + new_number_clone(tt->miterlimit, t->miterlimit); + new_number_clone(tt->dashscale, t->dashscale); + mp_path_ptr(tt) = mp_copy_path(mp, mp_path_ptr(t)); + if (mp_pre_script(p) != NULL) { + add_str_ref(mp_pre_script(p)); + } + if (mp_post_script(p) != NULL) { + add_str_ref(mp_post_script(p)); + } + if (mp_pen_ptr(t) != NULL) { + mp_pen_ptr(tt) = mp_copy_pen(mp, mp_pen_ptr(t)); + } + if (mp_dash_ptr(p) != NULL) { + mp_add_edge_ref(mp, mp_dash_ptr(pp)); + } + } + break; + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + { + mp_start_node tt = (mp_start_node) pp; + mp_start_node t = (mp_start_node) p; + mp_path_ptr(tt) = mp_copy_path(mp, mp_path_ptr(t)); + if (mp_pre_script(p) != NULL) { + add_str_ref(mp_pre_script(p)); + } + if (mp_post_script(p) != NULL) { + add_str_ref(mp_post_script(p)); + } + } + break; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + break; + default: + break; +} + +@ Here is one way to find an acceptable value for the second argument to +|copy_objects|. Given a non-NULL graphical object list, |skip_1component| skips +past one picture component, where a \quote {picture component} is a single graphical +object, or a start bounds or start clip object and everything up through the +matching stop bounds or stop clip object. + +@c +static mp_node mp_skip_1component (MP mp, mp_node p) +{ + int lev = 0; /* current nesting level */ + (void) mp; + do { + if (mp_is_start_or_stop (p)) { + if (mp_is_stop(p)) { + --lev; + } else { + ++lev; + } + } + p = mp_link(p); + } while (lev != 0); + return p; +} + +@ Here is a diagnostic routine for printing an edge structure in symbolic form. + +@<Declarations@>= +static void mp_print_edges (MP mp, mp_node h, const char *s, int nuline); + +@ @c +void mp_print_edges (MP mp, mp_node h, const char *s, int nuline) +{ + mp_node p = mp_edge_list(h); /* a graphical object to be printed */ + mp_number scf; /* a scale factor for the dash pattern */ + new_number(scf); + mp_print_diagnostic(mp, "Edge structure", s, nuline); + while (mp_link(p) != NULL) { + p = mp_link(p); + mp_print_ln(mp); + switch (mp_type(p)) { + @<Cases for printing graphical object node |p|@> + default: + mp_print_str(mp, "[unknown object type!]"); + break; + } + } + mp_print_nl(mp, "End edges"); + if (p != mp_obj_tail(h)) { + mp_print_str(mp, "?"); + @.End edges?@> + } + mp_end_diagnostic(mp, 1); + free_number(scf); +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_fill_node_type: + mp_print_str(mp, "Filled contour "); + mp_print_obj_color (mp, p); + mp_print_chr(mp, ':'); + mp_print_ln(mp); + mp_pr_path(mp, mp_path_ptr((mp_shape_node) p)); + mp_print_ln(mp); + if ((mp_pen_ptr((mp_shape_node) p) != NULL)) { + @<Print join type for graphical object |p|@> + mp_print_str(mp, " with pen"); + mp_print_ln(mp); + mp_pr_pen(mp, mp_pen_ptr((mp_shape_node) p)); + } + break; + +@ @<Print join type for graphical object |p|@>= +switch (((mp_shape_node) p)->linejoin) { + case mp_mitered_linejoin_code: + mp_print_str(mp, "mitered joins limited "); + print_number(((mp_shape_node) p)->miterlimit); + break; + case mp_rounded_linejoin_code: + mp_print_str(mp, "round joins"); + break; + case mp_beveled_linejoin_code: + mp_print_str(mp, "beveled joins"); + break; + default: + mp_print_str(mp, "?? joins"); + break; + @.??@> +} + +@ For stroked nodes, we need to print |linecap_val(p)| as well. + +@<Print join and cap types for stroked node |p|@>= +switch (((mp_shape_node) p)->linecap) { + case mp_butt_linecap_code: + mp_print_str(mp, "butt"); + break; + case mp_rounded_linecap_code: + mp_print_str(mp, "round"); + break; + case mp_squared_linecap_code: + mp_print_str(mp, "square"); + break; + default: + mp_print_str(mp, "??"); + break; + @.??@> +} +mp_print_str(mp, " ends, "); +@<Print join type for graphical object |p|@> + +@ Here is a routine that prints the color of a graphical object if it isn't black +(the default color). + +@<Declarations@>= +static void mp_print_obj_color (MP mp, mp_node p); + +@ @c +void mp_print_obj_color (MP mp, mp_node p) +{ + mp_shape_node p0 = (mp_shape_node) p; + switch (mp_color_model(p)) { + case mp_grey_model: + if (number_positive(p0->grey)) { + mp_print_str(mp, "greyed "); + mp_print_chr(mp, '('); + print_number(p0->grey); + mp_print_chr(mp, ')'); + }; + break; + case mp_cmyk_model: + if (number_positive(p0->cyan) || number_positive(p0->magenta) + || number_positive(p0->yellow) || number_positive(p0->black)) { + mp_print_str(mp, "processcolored "); + mp_print_chr(mp, '('); + print_number(p0->cyan); + mp_print_chr(mp, ','); + print_number(p0->magenta); + mp_print_chr(mp, ','); + print_number(p0->yellow); + mp_print_chr(mp, ','); + print_number(p0->black); + mp_print_chr(mp, ')'); + }; + break; + case mp_rgb_model: + if (number_positive(p0->red) || number_positive(p0->green) || number_positive(p0->blue)) { + mp_print_str(mp, "colored "); + mp_print_chr(mp, '('); + print_number(p0->red); + mp_print_chr(mp, ','); + print_number(p0->green); + mp_print_chr(mp, ','); + print_number(p0->blue); + mp_print_chr(mp, ')'); + } + break; + default: + break; + } +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_stroked_node_type: + mp_print_str(mp, "Filled pen stroke "); + mp_print_obj_color (mp, p); + mp_print_chr(mp, ':'); + mp_print_ln(mp); + mp_pr_path(mp, mp_path_ptr((mp_shape_node) p)); + if (mp_dash_ptr(p) != NULL) { + @<Finish printing the dash pattern that |p| refers to@> + } + mp_print_ln(mp); + @<Print join and cap types for stroked node |p|@> + mp_print_str(mp, " with pen"); + mp_print_ln(mp); + if (mp_pen_ptr((mp_shape_node) p) == NULL) { + mp_print_str(mp, "???"); /* shouldn't happen */ + @.???@> + } else { + mp_pr_pen(mp, mp_pen_ptr((mp_shape_node) p)); + } + break; + +@ Normally, the |dash_list| field in an edge header is set to |null_dash| when it +is not known to define a suitable dash pattern. This is disallowed here because +the |mp_dash_ptr| field should never point to such an edge header. Note that memory +is allocated for |start_x(null_dash)| and we are free to give it any convenient +value. + +@<Finish printing the dash pattern that |p| refers to@>= +mp_dash_node ppd, hhd; +int ok_to_dash = mp_pen_is_elliptical(mp_pen_ptr((mp_shape_node) p)); +mp_print_nl(mp, "dashed ("); +if (! ok_to_dash) { + set_number_to_unity(scf); +} else { + number_clone(scf, ((mp_shape_node) p)->dashscale); +} +hhd = (mp_dash_node) mp_dash_ptr(p); +ppd = mp_get_dash_list(hhd); +if ((ppd == mp->null_dash) || number_negative(hhd->dash_y)) { + mp_print_str(mp, " ??"); +} else { + mp_number dashoff; + mp_number ret, arg1; + new_number(ret); + new_number(arg1); + new_number(dashoff); + set_number_from_addition(mp->null_dash->start_x, ppd->start_x, hhd->dash_y ); + while (ppd != mp->null_dash) { + mp_print_str(mp, "on "); + set_number_from_subtraction(arg1, ppd->stop_x, ppd->start_x); + take_scaled(ret, arg1, scf); + print_number( ret); + mp_print_str(mp, " off "); + set_number_from_subtraction(arg1, ((mp_dash_node) mp_link(ppd))->start_x, ppd->stop_x); + take_scaled(ret, arg1, scf); + print_number(ret); + ppd = (mp_dash_node) mp_link(ppd); + if (ppd != mp->null_dash) { + mp_print_chr(mp, ' '); + } + } + mp_print_str(mp, ") shifted "); + mp_dash_offset(mp, &dashoff, hhd); + take_scaled(ret, dashoff, scf); + number_negate(ret); + print_number(ret); + free_number(dashoff); + free_number(ret); + free_number(arg1); + if (!ok_to_dash || number_zero(hhd->dash_y)) { + mp_print_str(mp, " (this will be ignored)"); + } +} + +@ @<Declarations@>= +static void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h); + +@ @c +void mp_dash_offset (MP mp, mp_number *x, mp_dash_node h) +{ + if (mp_get_dash_list(h) == mp->null_dash || number_negative(h->dash_y)) { + mp_confusion(mp, "dash offset"); + @:this can't happen dash0}{\quad dash0@> + } else if (number_zero(h->dash_y)) { + set_number_to_zero(*x); + } else { + number_clone(*x, (mp_get_dash_list(h))->start_x); + number_modulo(*x, h->dash_y); + number_negate(*x); + if (number_negative(*x)) { + number_add(*x, h->dash_y); + } + } +} + +@ @<Cases for printing graphical object node |p|@>= +case mp_start_clip_node_type: + mp_print_str(mp, "clipping path:"); + goto COMMONSTART; +case mp_start_group_node_type: + mp_print_str(mp, "setgroup path:"); + goto COMMONSTART; +case mp_start_bounds_node_type: + mp_print_str(mp, "setbounds path:"); + COMMONSTART: + mp_print_ln(mp); + mp_pr_path(mp, mp_path_ptr((mp_start_node) p)); + break; +case mp_stop_clip_node_type: + mp_print_str(mp, "stop clipping"); + break; +case mp_stop_group_node_type: + mp_print_str(mp, "stop group"); + break; +case mp_stop_bounds_node_type: + mp_print_str(mp, "end of setbounds"); + break; + +@ To initialize the |dash_list| field in an edge header~|h|, we need a subroutine +that scans an edge structure and tries to interpret it as a dash pattern. This +can only be done when there are no filled regions or clipping paths and all the +pen strokes have the same color. The first step is to let $y_0$ be the initial +$y$~coordinate of the first pen stroke. Then we implicitly project all the pen +stroke paths onto the line $y=y_0$ and require that there be no retracing. If the +resulting paths cover a range of $x$~coordinates of length $\Delta x$, we set +|dash_y(h)| to the length of the dash pattern by finding the maximum of $\Delta +x$ and the absolute value of~$y_0$. + +@c +static mp_edge_header_node mp_make_dashes (MP mp, mp_edge_header_node h) +{ + if (mp_get_dash_list(h) != mp->null_dash) { + return h; + } else { + /* returns |h| or |NULL| */ + mp_node p; /* this scans the stroked nodes in the object list */ + mp_node p0; /* if not |NULL| this points to the first stroked node */ + mp_knot pp, qq, rr; /* pointers into |mp_path_ptr(p)| */ + mp_dash_node d, dd; /* pointers used to create the dash list */ + mp_number y0; + @<Other local variables in |make_dashes|@> + new_number(y0); /* the initial $y$ coordinate */ + p0 = NULL; + p = mp_link(mp_edge_list(h)); + while (p != NULL) { + if (mp_type(p) != mp_stroked_node_type) { + @<Complain that the edge structure contains a node of the wrong type and |goto not_found|@> + } + pp = mp_path_ptr((mp_shape_node) p); + if (p0 == NULL) { + p0 = p; + number_clone(y0, pp->y_coord); + } + @<Make |d| point to a new dash node created from stroke |p| and path |pp| or |goto not_found| if there is an error@> + @<Insert |d| into the dash list and |goto not_found| if there is an error@> + p = mp_link(p); + } + if (mp_get_dash_list(h) == mp->null_dash) { + goto NOT_FOUND; /* No error message */ + } else { + @<Scan |mp_get_dash_list(h)| and deal with any dashes that are themselves dashed@> + @<Set |dash_y(h)| and merge the first and last dashes if necessary@> + free_number(y0); + return h; + } + NOT_FOUND: + free_number(y0); + @<Flush the dash list, recycle |h| and return |NULL|@> + } +} + +@ @<Complain that the edge structure contains a node of the wrong type...@>= +mp_back_error( + mp, + "Picture is too complicated to use as a dash pattern", + "When you say 'dashed p', picture p should not contain any text, filled regions,\n" + "or clipping paths. This time it did so I'll just make it a solid line instead." +); +mp_get_x_next(mp); +goto NOT_FOUND; + +@ A similar error occurs when monotonicity fails. + +@<Declarations@>= +static void mp_x_retrace_error (MP mp); + +@ @c +void mp_x_retrace_error (MP mp) +{ + mp_back_error( + mp, + "Picture is too complicated to use as a dash pattern", + "When you say 'dashed p', every path in p should be monotone in x and there must\n" + "be no overlapping. This failed so I'll just make it a solid line instead." + ); + mp_get_x_next(mp); +} + +@ We stash |p| in |dash_info(d)| if |mp_dash_ptr(p)<>0| so that subsequent +processing can handle the case where the pen stroke |p| is itself dashed. + +@d mp_dash_info(A) ((mp_dash_node) (A))->dash_info /* in an edge header this points to the first dash node */ + +@<Make |d| point to a new dash node created from stroke |p| and path...@>= +@<Make sure |p| and |p0| are the same color and |goto not_found| if there is an error@> +rr = pp; +if (mp_next_knot(pp) != pp) { + do { + qq = rr; + rr = mp_next_knot(rr); + @<Check for retracing between knots |qq| and |rr| and |goto not_found| if there is a problem@> + } while (mp_right_type(rr) != mp_endpoint_knot); +} +d = (mp_dash_node) mp_get_dash_node(mp); +if (mp_dash_ptr(p) == NULL) { + mp_dash_info(d) = NULL; +} else { + mp_dash_info(d) = p; +} +if (number_less(pp->x_coord, rr->x_coord)) { + number_clone(d->start_x, pp->x_coord); + number_clone(d->stop_x, rr->x_coord); +} else { + number_clone(d->start_x, rr->x_coord); + number_clone(d->stop_x, pp->x_coord); +} + +@ We also need to check for the case where the segment from |qq| to |rr| is +monotone in $x$ but is reversed relative to the path from |pp| to |qq|. + +@<Check for retracing between knots |qq| and |rr| and |goto not_found|...@>= +{ + mp_number x0, x1, x2, x3; /* $x$ coordinates of the segment from |qq| to |rr| */ + new_number_clone(x0, qq->x_coord); + new_number_clone(x1, qq->right_x); + new_number_clone(x2, rr->left_x); + new_number_clone(x3, rr->x_coord); + if (number_greater(x0, x1) || number_greater(x1, x2) || number_greater(x2, x3)) { + if (number_less(x0, x1) || number_less(x1, x2) || number_less(x2, x3)) { + mp_number a1, a2, a3, a4; + int test; + new_number(a1); + new_number(a2); + new_number(a3); + new_number(a4); + set_number_from_subtraction(a1, x2, x1); + set_number_from_subtraction(a2, x2, x1); + set_number_from_subtraction(a3, x1, x0); + set_number_from_subtraction(a4, x3, x2); + test = ab_vs_cd(a1, a2, a3, a4); + free_number(a1); + free_number(a2); + free_number(a3); + free_number(a4); + if (test > 0) { + mp_x_retrace_error(mp); + free_number(x0); + free_number(x1); + free_number(x2); + free_number(x3); + goto NOT_FOUND; + } + } + } + if (number_greater(pp->x_coord, x0) || number_greater(x0, x3)) { + if (number_less(pp->x_coord, x0) || number_less(x0, x3)) { + mp_x_retrace_error(mp); + free_number(x0); + free_number(x1); + free_number(x2); + free_number(x3); + goto NOT_FOUND; + } + } + free_number(x0); + free_number(x1); + free_number(x2); + free_number(x3); +} + +@ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>= +if (! number_equal(((mp_shape_node) p)->red, ((mp_shape_node) p0)->red) + || ! number_equal(((mp_shape_node) p)->black, ((mp_shape_node) p0)->black) + || ! number_equal(((mp_shape_node) p)->green, ((mp_shape_node) p0)->green) + || ! number_equal(((mp_shape_node) p)->blue, ((mp_shape_node) p0)->blue) + ) { + mp_back_error( + mp, + "Picture is too complicated to use as a dash pattern", + "When you say 'dashed p', everything in picture p should be the same color. I\n" + "can't handle your color changes so I'll just make it a solid line instead." + ); + mp_get_x_next(mp); + goto NOT_FOUND; +} + +@ @<Insert |d| into the dash list and |goto not_found| if there is an error@>= +number_clone(mp->null_dash->start_x, d->stop_x); +dd = (mp_dash_node) h; /* this makes |mp_link(dd)=mp_get_dash_list(h)| */ +while (number_less(((mp_dash_node) mp_link(dd))->start_x, d->stop_x)) { + dd = (mp_dash_node) mp_link(dd); +} +if ((dd != (mp_dash_node) h) && number_greater(dd->stop_x, d->start_x)) { + mp_x_retrace_error(mp); + goto NOT_FOUND; +} +mp_link(d) = mp_link(dd); +mp_link(dd) = (mp_node) d; + +@ @<Set |dash_y(h)| and merge the first and last dashes if necessary@>= +d = mp_get_dash_list(h); +while (mp_link(d) != (mp_node) mp->null_dash) { + d = (mp_dash_node) mp_link(d); +} +dd = mp_get_dash_list(h); +set_number_from_subtraction(h->dash_y, d->stop_x, dd->start_x); +{ + mp_number absval; + new_number(absval); + number_abs_clone(absval, y0); + if (number_greater(absval, h->dash_y) ) { + number_clone(h->dash_y, absval); + } else if (d != dd) { + mp_set_dash_list(h, mp_link(dd)); + set_number_from_addition(d->stop_x, dd->stop_x, h->dash_y); + mp_free_node(mp, (mp_node) dd, sizeof(mp_dash_node_data)); + } + free_number(absval); +} + +@ We get here when the argument is a NULL picture or when there is an error. +Recovering from an error involves making |mp_get_dash_list(h)| empty to indicate that +|h| is not known to be a valid dash pattern. We also dereference |h| since it is +not being used for the return value. + +@<Flush the dash list, recycle |h| and return |NULL|@>= +mp_flush_dash_list(mp, h); +mp_delete_edge_ref(mp, h); +return NULL; + +@ Having carefully saved the dashed stroked nodes in the corresponding dash +nodes, we must be prepared to break up these dashes into smaller dashes. + +@<Scan |mp_get_dash_list(h)| and deal with any dashes that are themselves dashed@>= +{ +mp_number hsf; /* the dash pattern from |hh| gets scaled by this */ +new_number(hsf); +d = (mp_dash_node) h; /* now |mp_link(d)=mp_get_dash_list(h)| */ +while (mp_link(d) != (mp_node) mp->null_dash) { + ds = mp_dash_info(mp_link(d)); + if (ds == NULL) { + d = (mp_dash_node) mp_link(d); + } else { + hh = (mp_edge_header_node) mp_dash_ptr(ds); + number_clone(hsf, ((mp_shape_node) ds)->dashscale); + if (hh == NULL) { + mp_confusion(mp, "dash pattern"); + @:this can't happen dash0}{\quad dash1@> + return NULL; + } else if (number_zero(((mp_dash_node) hh)->dash_y )) { + d = (mp_dash_node) mp_link(d); + } else if (mp_get_dash_list (hh) == NULL) { + mp_confusion(mp, "dash list"); + @:this can't happen dash1}{\quad dash1@> + return NULL; + } else { + @<Replace |mp_link(d)| by a dashed version as determined by edge header |hh| and scale factor |ds|@> + } + } +} +free_number(hsf); +} + +@ @<Other local variables in |make_dashes|@>= +mp_dash_node dln; /* |mp_link(d)| */ +mp_edge_header_node hh; /* an edge header that tells how to break up |dln| */ +mp_node ds; /* the stroked node from which |hh| and |hsf| are derived */ + +@ @<Replace |mp_link(d)| by a dashed version as determined by edge header...@>= +mp_number xoff; /* added to $x$ values in |mp_get_dash_list(hh)| to match |dln| */ +mp_number dashoff; +mp_number r1, r2; +new_number(r1); +new_number(r2); +dln = (mp_dash_node) mp_link(d); +dd = mp_get_dash_list(hh); +new_number(xoff); +new_number(dashoff); +mp_dash_offset(mp, &dashoff, (mp_dash_node) hh); +take_scaled(r1, hsf, dd->start_x); +take_scaled(r2, hsf, dashoff); +number_add(r1, r2); +set_number_from_subtraction(xoff, dln->start_x, r1); +free_number(dashoff); +take_scaled(r1, hsf, dd->start_x); +take_scaled(r2, hsf, hh->dash_y); +set_number_from_addition(mp->null_dash->start_x, r1, r2); +number_clone(mp->null_dash->stop_x, mp->null_dash->start_x); +@<Advance |dd| until finding the first dash that overlaps |dln| when offset by |xoff|@> +while (number_lessequal(dln->start_x, dln->stop_x)) { + @<If |dd| has `fallen off the end', back up to the beginning and fix |xoff|@> + @<Insert a dash between |d| and |dln| for the overlap with the offset version of |dd|@> + dd = (mp_dash_node) mp_link(dd); + take_scaled(r1, hsf, dd->start_x); + set_number_from_addition(dln->start_x , xoff, r1); +} +free_number(xoff); +free_number(r1); +free_number(r2); +mp_link(d) = mp_link(dln); +mp_free_node(mp, (mp_node) dln, sizeof(mp_dash_node_data)); + +@ The name of this module is a bit of a lie because we just find the first |dd| +where |take_scaled(hsf, stop_x(dd))| is large enough to make an overlap +possible. It could be that the unoffset version of dash |dln| falls in the gap +between |dd| and its predecessor. + +@<Advance |dd| until finding the first dash that overlaps |dln| when...@>= +{ + mp_number r1; + new_number(r1); + take_scaled(r1, hsf, dd->stop_x); + number_add(r1, xoff); + while (number_less(r1, dln->start_x)) { + dd = (mp_dash_node) mp_link(dd); + take_scaled(r1, hsf, dd->stop_x); + number_add(r1, xoff); + } + free_number(r1); +} + +@ @<If |dd| has `fallen off the end', back up to the beginning and fix...@>= +if (dd == mp->null_dash) { + mp_number ret; + new_number(ret); + dd = mp_get_dash_list(hh); + take_scaled(ret, hsf, hh->dash_y); + number_add(xoff, ret); + free_number(ret); +} + +@ At this point we already know that |start_x(dln)<=xoff+take_scaled(hsf,stop_x(dd))|. + +@<Insert a dash between |d| and |dln| for the overlap with the offset...@>= +{ + mp_number r1; + new_number(r1); + take_scaled(r1, hsf, dd->start_x); + number_add(r1, xoff); + if (number_lessequal(r1, dln->stop_x)) { + mp_link(d) = (mp_node) mp_get_dash_node(mp); + d = (mp_dash_node) mp_link(d); + mp_link(d) = (mp_node) dln; + take_scaled(r1, hsf, dd->start_x ); + number_add(r1, xoff); + if (number_greater(dln->start_x, r1)) { + number_clone(d->start_x, dln->start_x); + } else { + number_clone(d->start_x, r1); + } + take_scaled(r1, hsf, dd->stop_x); + number_add(r1, xoff); + if (number_less(dln->stop_x, r1)) { + number_clone(d->stop_x, dln->stop_x ); + } else { + number_clone(d->stop_x, r1); + } + } + free_number(r1); +} + +@ The next major task is to update the bounding box information in an edge +header~|h|. This is done via a procedure |adjust_bbox| that enlarges an edge +header's bounding box to accommodate the box computed by |path_bbox| or +|pen_bbox|. (This is stored in global variables |minx|, |miny|, |maxx|, and +|maxy|.) + +@c +static void mp_adjust_bbox (MP mp, mp_edge_header_node h) +{ + if (number_less(mp_minx, h->minx)) { + number_clone(h->minx, mp_minx); + } + if (number_less(mp_miny, h->miny)) { + number_clone(h->miny, mp_miny); + } + if (number_greater(mp_maxx, h->maxx)) { + number_clone(h->maxx, mp_maxx); + } + if (number_greater(mp_maxy, h->maxy)) { + number_clone(h->maxy, mp_maxy); + } +} + +@ Here is a special routine for updating the bounding box information in edge +header~|h| to account for the squared-off ends of a non-cyclic path~|p| that is +to be stroked with the pen~|pp|. + +@c +static void mp_box_ends (MP mp, mp_knot p, mp_knot pp, mp_edge_header_node h) +{ + if (mp_right_type(p) != mp_endpoint_knot) { + mp_fraction dx, dy; /* a unit vector in the direction out of the path at~|p| */ + mp_number d; /* a factor for adjusting the length of |(dx,dy)| */ + mp_number z; /* a coordinate being tested against the bounding box */ + mp_number xx, yy; /* the extreme pen vertex in the |(dx,dy)| direction */ + new_fraction(dx); + new_fraction(dy); + new_number(xx); + new_number(yy); + new_number(z); + new_number(d); + mp_knot q = mp_next_knot(p); /* a knot node adjacent to knot |p| */ + while (1) { + @<Make |(dx,dy)| the final direction for the path segment from |q| to~|p|; set~|d|@> + pyth_add(d, dx, dy); + if (number_positive(d)) { + @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@> + for (int i = 1; i <= 2; i++) { + @<Use |(dx,dy)| to generate a vertex of the square end cap and update the bounding box to accommodate it@> + number_negate(dx); + number_negate(dy); + } + } + if (mp_right_type(p) == mp_endpoint_knot) { + goto DONE; + } else { + @<Advance |p| to the end of the path and make |q| the previous knot@> + } + } + DONE: + free_number(dx); + free_number(dy); + free_number(xx); + free_number(yy); + free_number(z); + free_number(d); + } +} + +@ @<Make |(dx,dy)| the final direction for the path segment from...@>= +if (q == mp_next_knot(p)) { + set_number_from_subtraction(dx, p->x_coord, p->right_x); + set_number_from_subtraction(dy, p->y_coord, p->right_y); + if (number_zero(dx) && number_zero(dy)) { + set_number_from_subtraction(dx, p->x_coord, q->left_x); + set_number_from_subtraction(dy, p->y_coord, q->left_y); + } +} else { + set_number_from_subtraction(dx, p->x_coord, p->left_x); + set_number_from_subtraction(dy, p->y_coord, p->left_y); + if (number_zero(dx) && number_zero(dy)) { + set_number_from_subtraction(dx, p->x_coord, q->right_x); + set_number_from_subtraction(dy, p->y_coord, q->right_y); + } +} +set_number_from_subtraction(dx, p->x_coord, q->x_coord); +set_number_from_subtraction(dy, p->y_coord, q->y_coord); + +@ @<Normalize the direction |(dx,dy)| and find the pen offset |(xx,yy)|@>= +mp_number arg1, r; +new_fraction(r); +new_number(arg1); +make_fraction(r, dx, d); +number_clone(dx, r); +make_fraction(r, dy, d); +number_clone(dy, r); +free_number(r); +number_negated_clone(arg1, dy); +mp_find_offset(mp, &arg1, &dx, pp); +free_number(arg1); +number_clone(xx, mp->cur_x); +number_clone(yy, mp->cur_y); + +@ @<Use |(dx,dy)| to generate a vertex of the square end cap and...@>= +mp_number r1, r2, arg1; +new_number(arg1); +new_fraction(r1); +new_fraction(r2); +mp_find_offset(mp, &dx, &dy, pp); +set_number_from_subtraction(arg1, xx, mp->cur_x); +take_fraction(r1, arg1, dx); +set_number_from_subtraction(arg1, yy, mp->cur_y); +take_fraction(r2, arg1, dy); +set_number_from_addition(d, r1, r2); +if ((number_negative(d) && (i == 1)) || (number_positive(d) && (i == 2))) { + mp_confusion(mp, "box ends"); + @:this can't happen box ends}{\quad|box\_ends|@> +} +take_fraction(r1, d, dx); +set_number_from_addition(z, p->x_coord, mp->cur_x); +number_add(z, r1); +if (number_less(z, h->minx)) { + number_clone(h->minx, z); +} +if (number_greater(z, h->maxx)) { + number_clone(h->maxx, z); +} +take_fraction(r1, d, dy); +set_number_from_addition(z, p->y_coord, mp->cur_y); +number_add(z, r1); +if (number_less(z, h->miny)) { + number_clone(h->miny, z); +} +if (number_greater(z, h->maxy)) { + number_clone(h->maxy, z); +} +free_number(r1); +free_number(r2); +free_number(arg1); + +@ @<Advance |p| to the end of the path and make |q| the previous knot@>= +do { + q = p; + p = mp_next_knot(p); +} while (mp_right_type(p) != mp_endpoint_knot); + +@ The major difficulty in finding the bounding box of an edge structure is the +effect of clipping paths. We treat them conservatively by only clipping to the +clipping path's bounding box, but this still requires recursive calls to +|set_bbox| in order to find the bounding box of @^recursion@> the objects to be +clipped. Such calls are distinguished by the fact that the boolean parameter +|top_level| is false. + +@c +void mp_set_bbox (MP mp, mp_edge_header_node h, int top_level) +{ + /* + Wipe out any existing bounding box information if |bbtype(h)| is + incompatible with |internal[mp_true_corners]| + */ + switch (h->bbtype ) { + case mp_no_bounds_code: + break; + case mp_bounds_set_code: + if (number_positive(internal_value(mp_true_corners_internal))) { + mp_init_bbox(mp, h); + } + break; + case mp_bounds_unset_code: + if (number_nonpositive(internal_value(mp_true_corners_internal))) { + mp_init_bbox(mp, h); + } + break; + } + + while (mp_link(mp_bblast(h)) != NULL) { + mp_node p = mp_link(mp_bblast(h)); /* a graphical object being considered */ + mp_bblast(h) = p; + switch (mp_type(p)) { + case mp_stop_clip_node_type: + if (top_level) { + mp_confusion(mp, "clip"); + break; + } else { + return; + @:this can't happen bbox}{\quad bbox@> + } + @<Other cases for updating the bounding box based on the type of object |p|@> + default: + break; + } + } + if (! top_level) { + mp_confusion(mp, "boundingbox"); + } +} + +@ @<Declarations@>= +static void mp_set_bbox (MP mp, mp_edge_header_node h, int top_level); + +@ @<Other cases for updating the bounding box...@>= +case mp_start_bounds_node_type: + if (number_positive(internal_value(mp_true_corners_internal))) { + h->bbtype = mp_bounds_unset_code; + } else { + h->bbtype = mp_bounds_set_code; + mp_path_bbox(mp, mp_path_ptr((mp_start_node) p)); + mp_adjust_bbox(mp, h); + @<Scan to the matching |mp_stop_bounds_node| node and update |p| and |mp_bblast(h)|@> + } + break; +case mp_stop_bounds_node_type: + if (number_nonpositive (internal_value(mp_true_corners_internal))) { + mp_confusion(mp, "bounds"); + @:this can't happen bbox2}{\quad bbox2@> + } + break; + +@ @<Scan to the matching |mp_stop_bounds_node| node and update |p| and...@>= +{ + int lev = 1; + while (lev != 0) { + if (mp_link(p) == NULL) { + mp_confusion(mp, "bounds"); + @:this can't happen bbox2}{\quad bbox2@> + } else { + p = mp_link(p); + if (mp_type(p) == mp_start_bounds_node_type) { + ++lev; + } else if (mp_type(p) == mp_stop_bounds_node_type) { + --lev; + } + } + } + mp_bblast(h) = p; +} + +@ It saves a lot of grief here to be slightly conservative and not account for +omitted parts of dashed lines. We also don't worry about the material omitted +when using butt end caps. The basic computation is for round end caps and +|box_ends| augments it for square end caps. + +@<Other cases for updating the bounding box...@>= +case mp_fill_node_type: +case mp_stroked_node_type: + { + mp_number x0a, y0a, x1a, y1a; + mp_path_bbox(mp, mp_path_ptr((mp_shape_node) p)); + /* Stroked paths always have a pen */ + if (mp_pen_ptr((mp_shape_node) p) != NULL) { + new_number_clone(x0a, mp_minx); + new_number_clone(y0a, mp_miny); + new_number_clone(x1a, mp_maxx); + new_number_clone(y1a, mp_maxy); + mp_pen_bbox(mp, mp_pen_ptr((mp_shape_node) p)); + number_add(mp_minx, x0a); + number_add(mp_miny, y0a); + number_add(mp_maxx, x1a); + number_add(mp_maxy, y1a); + free_number(x0a); + free_number(y0a); + free_number(x1a); + free_number(y1a); + } + mp_adjust_bbox(mp, h); + /* Stroked paths can be open, so: */ + if ((mp_left_type(mp_path_ptr((mp_shape_node) p)) == mp_endpoint_knot) && (((mp_shape_node) p)->linecap == 2)) { + mp_box_ends(mp, mp_path_ptr((mp_shape_node) p), mp_pen_ptr((mp_shape_node) p), h); + } + } + break; + +@ This case involves a recursive call that advances |mp_bblast(h)| to the node of +type |mp_stop_clip_node| that matches |p|. + +@<Other cases for updating the bounding box...@>= +case mp_start_clip_node_type: + { + mp_number sminx, sminy, smaxx, smaxy; + /* for saving the bounding box during recursive calls */ + mp_number x0a, y0a, x1a, y1a; + mp_path_bbox(mp, mp_path_ptr((mp_start_node) p)); + new_number_clone(x0a, mp_minx); + new_number_clone(y0a, mp_miny); + new_number_clone(x1a, mp_maxx); + new_number_clone(y1a, mp_maxy); + new_number_clone(sminx, h->minx); + new_number_clone(sminy, h->miny); + new_number_clone(smaxx, h->maxx); + new_number_clone(smaxy, h->maxy); + @<Reinitialize the bounding box in header |h| and call |set_bbox| recursively starting at |mp_link(p)|@> + @<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|, |y0a|, |y1a|@> + number_clone(mp_minx, sminx); + number_clone(mp_miny, sminy); + number_clone(mp_maxx, smaxx); + number_clone(mp_maxy, smaxy); + mp_adjust_bbox(mp, h); + free_number(sminx); + free_number(sminy); + free_number(smaxx); + free_number(smaxy); + free_number(x0a); + free_number(y0a); + free_number(x1a); + free_number(y1a); + } + break; + +@ @<Reinitialize the bounding box in header |h| and call |set_bbox|...@>= +set_number_to_inf(h->minx); +set_number_to_inf(h->miny); +set_number_to_negative_inf(h->maxx); +set_number_to_negative_inf(h->maxy); +mp_set_bbox(mp, h, 0); + +@ @<Clip the bounding box in |h| to the rectangle given by |x0a|, |x1a|,...@>= +if (number_less(h->minx, x0a)) { + number_clone(h->minx, x0a); +} +if (number_less(h->miny, y0a)) { + number_clone(h->miny, y0a); +} +if (number_greater(h->maxx, x1a)) { + number_clone(h->maxx, x1a); +} +if (number_greater(h->maxy, y1a)) { + number_clone(h->maxy, y1a); +} + +@* Finding an envelope. + +When \MP\ has a path and a polygonal pen, it needs to express the desired shape +in terms of things \ps\ can understand. The present task is to compute a new path +that describes the region to be filled. It is convenient to define this as a two +step process where the first step is determining what offset to use for each +segment of the path. + +@ Given a pointer |c| to a cyclic path, and a pointer~|h| to the first knot of a +pen polygon, the |offset_prep| routine changes the path into cubics that are +associated with particular pen offsets. Thus if the cubic between |p| and~|q| is +associated with the |k|th offset and the cubic between |q| and~|r| has offset |l| +then |mp_info(q) = zero_off + l - k|. (The constant |zero_off| is added to +because |l - k| could be negative.) + +After overwriting the type information with offset differences, we no longer have +a true path so we refer to the knot list returned by |offset_prep| as an +\quote {envelope spec.} @^envelope spec@> Since an envelope spec only determines +relative changes in pen offsets, |offset_prep| sets a global variable +|spec_offset| to the relative change from |h| to the first offset. + +@d zero_off 0 /* 16384 */ /* added to offset changes to make them positive */ + +@<Glob...@>= +int spec_offset; /* number of pen edges between |h| and the initial offset */ +int spec_padding; /* be nice */ + +@ The next function calculates $1/3 B'(t) = (-p + (3c_1 + (-3c_2 + q)))*t^2 + (2p ++ (-4c_1 + 2*c_2))t + (-p + c_1)$, for cubic curve |B(t)| given by +|p|,|c1|,|c2|,|q| and it's used for |t| near 0 and |t| near 1. We use double +mode, otherwise we have to take care of overflow. + +@ @c +static mp_knot mp_offset_prep (MP mp, mp_knot c, mp_knot h) +{ + int n; /* the number of vertices in the pen polygon */ + mp_knot c0, p, q, q0, r, w, ww; /* for list manipulation */ + int k_needed; /* amount to be added to |mp_info(p)| when it is computed */ + mp_knot w0; /* a pointer to pen offset to use just before |p| */ + mp_number dxin, dyin; /* the direction into knot |p| */ + int turn_amt; /* change in pen offsets for the current cubic */ + mp_number max_coef; /* used while scaling */ + mp_number ss; + mp_number x0, x1, x2, y0, y1, y2; /* representatives of derivatives */ + mp_number t0, t1, t2; /* coefficients of polynomial for slope testing */ + mp_number du, dv, dx, dy; /* for directions of the pen and the curve */ + mp_number dx0, dy0; /* initial direction for the first cubic in the curve */ + mp_number x0a, x1a,x2a, y0a, y1a, y2a; /* intermediate values */ + mp_number t; /* where the derivative passes through zero */ + mp_number s; /* a temporary value */ + mp_number dx_m; /* signal a pertubation of dx */ + mp_number dy_m; /* signal a pertubation of dx */ + mp_number dxin_m; /* signal a pertubation of dxin */ + mp_number u0, u1, v0, v1; /* intermediate values for $d(t)$ calculation */ + int d_sign; /* sign of overall change in direction for this cubic */ + new_number(max_coef); + new_number(dxin); + new_number(dyin); + new_number(dx0); + new_number(dy0); + new_number(x0); + new_number(y0); + new_number(x1); + new_number(y1); + new_number(x2); + new_number(y2); + new_number(du); + new_number(dv); + new_number(dx); + new_number(dy); + new_number(x0a); + new_number(y0a); + new_number(x1a); + new_number(y1a); + new_number(x2a); + new_number(y2a); + new_number(t0); + new_number(t1); + new_number(t2); + new_number(u0); + new_number(u1); + new_number(v0); + new_number(v1); + new_number(dx_m); + new_number(dy_m); + new_number(dxin_m); + new_fraction(ss); + new_fraction(s); + new_fraction(t); + @<Initialize the pen size~|n|@> + @<Initialize the incoming direction and pen offset at |c|@> + p = c; + c0 = c; + k_needed = 0; + do { + q = mp_next_knot(p); + @<Split the cubic between |p| and |q|, if necessary, into cubics associated with single offsets, after which |q| should point to the end of the final such cubic@> + NOT_FOUND: + @<Advance |p| to node |q|, removing any \quote {dead} cubics that might have been introduced by the splitting process@> + } while (q != c); + @<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of |offset_prep|@> + free_number(ss); + free_number(s); + free_number(dxin); + free_number(dyin); + free_number(dx0); + free_number(dy0); + free_number(x0); + free_number(y0); + free_number(x1); + free_number(y1); + free_number(x2); + free_number(y2); + free_number(max_coef); + free_number(du); + free_number(dv); + free_number(dx); + free_number(dy); + free_number(x0a); + free_number(y0a); + free_number(x1a); + free_number(y1a); + free_number(x2a); + free_number(y2a); + free_number(t0); + free_number(t1); + free_number(t2); + free_number(u0); + free_number(u1); + free_number(v0); + free_number(v1); + free_number(dx_m); + free_number(dy_m); + free_number(dxin_m); + free_number(t); + return c; +} + +@ We shall want to keep track of where certain knots on the cyclic path wind up +in the envelope spec. It doesn't suffice just to keep pointers to knot nodes +because some nodes are deleted while removing dead cubics. Thus |offset_prep| +updates the following pointers + +@<Glob...@>= +mp_knot spec_p1; +mp_knot spec_p2; /* pointers to distinguished knots */ + +@ @<Set init...@>= +mp->spec_p1 = NULL; +mp->spec_p2 = NULL; + +@ @<Initialize the pen size~|n|@>= +n = 0; +p = h; +do { + ++n; + p = mp_next_knot(p); +} while (p != h); + +@ Since the true incoming direction isn't known yet, we just pick a direction +consistent with the pen offset~|h|. If this is wrong, it can be corrected later. + +@<Initialize the incoming direction and pen offset at |c|@>= +{ + mp_knot hn = mp_next_knot(h); + mp_knot hp = mp_prev_knot(h); + set_number_from_subtraction(dxin, hn->x_coord, hp->x_coord); + set_number_from_subtraction(dyin, hn->y_coord, hp->y_coord); + if (number_zero(dxin) && number_zero(dyin)) { + set_number_from_subtraction(dxin, hp->y_coord, h->y_coord); + set_number_from_subtraction(dyin, h->x_coord, hp->x_coord); + } +} +w0 = h; + +@ We must be careful not to remove the only cubic in a cycle. + +But we must also be careful for another reason. If the user-supplied path starts +with a set of degenerate cubics, the target node |q| can be collapsed to the +initial node |p| which might be the same as the initial node |c| of the curve. +This would cause the |offset_prep| routine to bail out too early, causing +distress later on. (See for example the testcase reported by Bogus||aw +Jackowski in tracker id 267, case 52c on Sarovar.) + +@<Advance |p| to node |q|, removing any \quote {dead} cubics...@>= +q0 = q; +do { + r = mp_next_knot(p); + if (r != p && r != q + && number_equal(p->x_coord, p->right_x) + && number_equal(p->y_coord, p->right_y) + && number_equal(p->x_coord, r->left_x) + && number_equal(p->y_coord, r->left_y) + && number_equal(p->x_coord, r->x_coord) + && number_equal(p->y_coord, r->y_coord)) { + @<Remove the cubic following |p| and update the data structures to merge |r| into |p|@> + } + p = r; +} while (p != q); +/* Check if we removed too much */ +if ((q != q0) && (q != c || c == c0)) { + q = mp_next_knot(q); +} + +@ @<Remove the cubic following |p| and update the data structures...@>= +{ + k_needed = mp_knot_info(p) - zero_off; + if (r == q) { + q = p; + } else { + mp_knot_info(p) = k_needed + mp_knot_info(r); + k_needed = 0; + } + if (r == c) { + mp_knot_info(p) = mp_knot_info(c); + c = p; + } + if (r == mp->spec_p1) { + mp->spec_p1 = p; + } + if (r == mp->spec_p2) { + mp->spec_p2 = p; + } + r = p; + mp_remove_cubic(mp, p); +} + +@ Not setting the |info| field of the newly created knot allows the splitting +routine to work for paths. + +@<Declarations@>= +static void mp_split_cubic (MP mp, mp_knot p, mp_number *t); +static mp_knot mp_split_cubic_knot (MP mp, mp_knot p, mp_number *t); + +@ @c +void mp_split_cubic (MP mp, mp_knot p, mp_number *t) +{ + /* splits the cubic after |p| */ + mp_number v; /* an intermediate value */ + mp_knot q = mp_next_knot(p); + mp_knot r = mp_new_knot(mp); + mp_prev_knot(r) = p; + mp_next_knot(p) = r; + mp_prev_knot(q) = r; + mp_next_knot(r) = q; + mp_originator(r) = mp_program_code; + mp_knotstate(r) = mp_regular_knot; + mp_left_type(r) = mp_explicit_knot; + mp_right_type(r) = mp_explicit_knot; + new_number(v); + set_number_from_of_the_way(v, *t, p->right_x, q->left_x); + set_number_from_of_the_way(p->right_x, *t, p->x_coord, p->right_x); + set_number_from_of_the_way(q->left_x, *t, q->left_x, q->x_coord); + set_number_from_of_the_way(r->left_x, *t, p->right_x, v); + set_number_from_of_the_way(r->right_x, *t, v, q->left_x); + set_number_from_of_the_way(r->x_coord, *t, r->left_x, r->right_x); + set_number_from_of_the_way(v, *t, p->right_y, q->left_y); + set_number_from_of_the_way(p->right_y, *t, p->y_coord, p->right_y); + set_number_from_of_the_way(q->left_y, *t, q->left_y, q->y_coord); + set_number_from_of_the_way(r->left_y, *t, p->right_y, v); + set_number_from_of_the_way(r->right_y, *t, v, q->left_y); + set_number_from_of_the_way(r->y_coord, *t, r->left_y, r->right_y); + free_number(v); +} + +static mp_knot mp_split_cubic_knot (MP mp, mp_knot p, mp_number *t) /* can be less as we only need x y */ +{ + mp_number v; + mp_knot k = mp_new_knot(mp); + mp_knot r = mp_copy_knot(mp, mp_next_knot(p)); + mp_knot l = mp_copy_knot(mp, p); + mp_originator(k) = mp_program_code; + mp_knotstate(k) = mp_regular_knot; + mp_left_type(k) = mp_explicit_knot; + mp_right_type(k) = mp_explicit_knot; + new_number(v); + set_number_from_of_the_way(v, *t, l->right_x, r->left_x); + set_number_from_of_the_way(l->right_x, *t, l->x_coord, l->right_x); + set_number_from_of_the_way(r->left_x, *t, r->left_x, r->x_coord); + set_number_from_of_the_way(k->left_x, *t, l->right_x, v); + set_number_from_of_the_way(k->right_x, *t, v, r->left_x); + set_number_from_of_the_way(k->x_coord, *t, k->left_x, k->right_x); + set_number_from_of_the_way(v, *t, l->right_y, r->left_y); + set_number_from_of_the_way(l->right_y, *t, l->y_coord, l->right_y); + set_number_from_of_the_way(r->left_y, *t, r->left_y, r->y_coord); + set_number_from_of_the_way(k->left_y, *t, l->right_y, v); + set_number_from_of_the_way(k->right_y, *t, v, r->left_y); + set_number_from_of_the_way(k->y_coord, *t, k->left_y, k->right_y); + free_number(v); + mp_toss_knot(mp, l); + mp_toss_knot(mp, r); + return k; +} + +@ This does not set |mp_knot_info(p)| or |mp_right_type(p)|. + +@<Declarations@>= +static void mp_remove_cubic (MP mp, mp_knot p); + +@ @c +void mp_remove_cubic (MP mp, mp_knot p) +{ + /* removes the dead cubic following~|p| */ + mp_knot q = mp_next_knot(p); /* the node that disappears */ + mp_prev_knot(q) = mp_next_knot(p); + mp_next_knot(p) = mp_next_knot(q); + number_clone(p->right_x, q->right_x); + number_clone(p->right_y, q->right_y); + /* was: mp_memory_free(q); */ + mp_toss_knot(mp, q); +} + +@ Let $d\prec d'$ mean that the counter-clockwise angle from $d$ to~$d'$ is +strictly between zero and $180^\circ$. Then we can define $d\preceq d'$ to mean +that the angle could be zero or $180^\circ$. If $w_k=(u_k,v_k)$ is the $k$th pen +offset, the $k$th pen edge direction is defined by the formula +$$d_k=(u\k-u_k,\,v\k-v_k).$$ When listed by increasing $k$, these directions +occur in counter-clockwise order so that $d_k\preceq d\k$ for all~$k$. The goal +of |offset_prep| is to find an offset index~|k| to associate with each cubic, +such that the direction $d(t)$ of the cubic satisfies $$d_{k-1}\preceq +d(t)\preceq d_k\qquad\hbox{for $0\le t\le 1$.}\eqno(*)$$ We may have to split a +cubic into many pieces before each piece corresponds to a unique offset. + +@<Split the cubic between |p| and |q|, if necessary, into cubics...@>= +mp_knot_info(p) = zero_off + k_needed; +k_needed = 0; +@<Prepare for derivative computations; |goto not_found| if the current cubic is dead@> +@<Find the initial direction |(dx,dy)|@> +@<Update |mp_knot_info(p)| and find the offset $w_k$ such that $d_{k-1}\preceq(|dx|,|dy|)\prec d_k$; also advance |w0| for the direction change at |p|@> +@<Find the final direction |(dxin,dyin)|@> +@<Decide on the net change in pen offsets and set |turn_amt|@> +@<Complete the offset splitting process@> +w0 = mp_pen_walk (mp, w0, turn_amt); + +@ @<Declarations@>= +static mp_knot mp_pen_walk (MP mp, mp_knot w, int k); + +@ @c +mp_knot mp_pen_walk (MP mp, mp_knot w, int k) +{ + /* walk |k| steps around a pen from |w| */ + (void) mp; + while (k > 0) { + w = mp_next_knot(w); + --k; + } + while (k < 0) { + w = mp_prev_knot(w); + ++k; + } + return w; +} + +@ The direction of a cubic $B(z_0,z_1,z_2,z_3;t)=\bigl(x(t),y(t)\bigr)$ can be +calculated from the quadratic polynomials +${1\over3}x'(t)=B(x_1-x_0,x_2-x_1,x_3-x_2;t)$ and +${1\over3}y'(t)=B(y_1-y_0,y_2-y_1,y_3-y_2;t)$. +Since we may be calculating directions from several cubics +split from the current one, it is desirable to do these calculations +without losing too much precision. \quote {Scaled up} values of the +derivatives, which will be less tainted by accumulated errors than +derivatives found from the cubics themselves, are maintained in +local variables |x0|, |x1|, and |x2|, representing $X_0=2^l(x_1-x_0)$, +$X_1=2^l(x_2-x_1)$, and $X_2=2^l(x_3-x_2)$; similarly |y0|, |y1|, and~|y2| +represent $Y_0=2^l(y_1-y_0)$, $Y_1=2^l(y_2-y_1)$, and $Y_2=2^l(y_3-y_2)$. + +@ @<Prepare for derivative computations...@>= +set_number_from_subtraction(x0, p->right_x, p->x_coord); +set_number_from_subtraction(x2, q->x_coord, q->left_x); +set_number_from_subtraction(x1, q->left_x, p->right_x); +set_number_from_subtraction(y0, p->right_y, p->y_coord); +set_number_from_subtraction(y2, q->y_coord, q->left_y); +set_number_from_subtraction(y1, q->left_y, p->right_y); +{ + /* somewhat weird: these copies to absval */ + mp_number absval; + new_number_abs(absval, x1); + number_abs_clone(max_coef, x0); + if (number_greater(absval, max_coef)) { + number_clone(max_coef, absval); + } + number_abs_clone(absval, x2); + if (number_greater(absval, max_coef)) { + number_clone(max_coef, absval); + } + number_abs_clone(absval, y0); + if (number_greater(absval, max_coef)) { + number_clone(max_coef, absval); + } + number_abs_clone(absval, y1); + if (number_greater(absval, max_coef)) { + number_clone(max_coef, absval); + } + number_abs_clone(absval, y2); + if (number_greater(absval, max_coef)) { + number_clone(max_coef, absval); + } + free_number(absval); + if (number_zero(max_coef)) { + goto NOT_FOUND; + } +} +while (number_less(max_coef, fraction_half_t)) { + number_double(max_coef); + number_double(x0); + number_double(x1); + number_double(x2); + number_double(y0); + number_double(y1); + number_double(y2); +} + +@ Let us first solve a special case of the problem: Suppose we know an index~$k$ +such that either (i)~$d(t)\succeq d_{k-1}$ for all~$t$ and $d(0)\prec d_k$, or +(ii)~$d(t)\preceq d_k$ for all~$t$ and $d(0)\succ d_{k-1}$. Then, in a sense, +we're halfway done, since one of the two relations in $(*)$ is satisfied, and the +other couldn't be satisfied for any other value of~|k|. Actually, the conditions +can be relaxed somewhat since a relation such as + +$d(t)\succeq d_{k-1}$ restricts $d(t)$ to a half plane when all that really +matters is whether $d(t)$ crosses the ray in the $d_{k-1}$ direction from the +origin. The condition for case~(i) becomes $d_{k-1}\preceq d(0)\prec d_k$ and +$d(t)$ never crosses the $d_{k-1}$ ray in the clockwise direction. Case~(ii) is +similar except $d(t)$ cannot cross the $d_k$ ray in the counterclockwise +direction. + +The |fin_offset_prep| subroutine solves the stated subproblem. It has a parameter +called |rise| that is |1| in case~(i), |-1| in case~(ii). Parameters |x0| through +|y2| represent the derivative of the cubic following |p|. The |w| parameter +should point to offset~$w_k$ and |mp_info(p)| should already be set properly. The +|turn_amt| parameter gives the absolute value of the overall net change in pen +offsets. + +@<Declarations@>= +static void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number *x0, mp_number *x1, mp_number *x2, mp_number *y0, mp_number *y1, mp_number *y2, int rise, int turn_amt); + +@ @c +void mp_fin_offset_prep (MP mp, mp_knot p, mp_knot w, mp_number *x0, mp_number *x1, mp_number *x2, mp_number *y0, mp_number *y1, mp_number *y2, int rise, int turn_amt) +{ + mp_number du, dv; /* for slope calculation */ + mp_number t0, t1, t2; /* test coefficients */ + mp_number t; /* place where the derivative passes a critical slope */ + mp_number s; /* slope or reciprocal slope */ + mp_number v; /* intermediate value for updating |x0..y2| */ + mp_knot q = mp_next_knot(p); + new_number(du); + new_number(dv); + new_number(v); + new_number(t0); + new_number(t1); + new_number(t2); + new_fraction(s); + new_fraction(t); + while (1) { + mp_knot ww = rise > 0 ? mp_next_knot(w) : mp_prev_knot(w); + @<Compute (case 1) test coefficients |(t0,t1,t2)| for $d(t)$ versus $d_k$ or $d_{k-1}$@> + crossing_point(t, t0, t1, t2); + if (number_greaterequal(t, fraction_one_t)) { + if (turn_amt > 0) { + number_clone(t, fraction_one_t); + } else { + goto RETURN; + } + } + @<Split the cubic at $t$, and split off another cubic if the derivative crosses back@> + w = ww; + } + RETURN: + free_number(s); + free_number(t); + free_number(du); + free_number(dv); + free_number(v); + free_number(t0); + free_number(t1); + free_number(t2); +} + +@ We want $B(|t0|,|t1|,|t2|;t)$ to be the dot product of $d(t)$ with a +$-90^\circ$ rotation of the vector from |w| to |ww|. This makes the resulting +function cross from positive to negative when $d_{k-1}\preceq d(t)\preceq d_k$ +begins to fail. + +@<Compute (case 1) test coefficients |(t0,t1,t2)| for $d(t)$ versus $d_k$ or $d_{k-1}$...@>= +{ + mp_number abs_du, abs_dv; + new_number(abs_du); + new_number(abs_dv); + set_number_from_subtraction(du, ww->x_coord, w->x_coord); + set_number_from_subtraction(dv, ww->y_coord, w->y_coord); + number_abs_clone(abs_du, du); + number_abs_clone(abs_dv, dv); + if (number_greaterequal(abs_du, abs_dv)) { + mp_number r1; + new_fraction(r1); + make_fraction(s, dv, du); + take_fraction(r1, *x0, s); + set_number_from_subtraction(t0, r1, *y0); + take_fraction(r1, *x1, s); + set_number_from_subtraction(t1, r1, *y1); + take_fraction(r1, *x2, s); + set_number_from_subtraction(t2, r1, *y2); + if (number_negative(du)) { + number_negate(t0); + number_negate(t1); + number_negate(t2); + } + free_number(r1); + } else { + mp_number r1; + new_fraction(r1); + make_fraction(s, du, dv); + take_fraction(r1, *y0, s); + set_number_from_subtraction(t0, *x0, r1); + take_fraction(r1, *y1, s); + set_number_from_subtraction(t1, *x1, r1); + take_fraction(r1, *y2, s); + set_number_from_subtraction(t2, *x2, r1); + if (number_negative(dv)) { + number_negate(t0); + number_negate(t1); + number_negate(t2); + } + free_number(r1); + } + free_number(abs_du); + free_number(abs_dv); + if (number_negative(t0)) { + set_number_to_zero(t0); /* should be positive without rounding error */ + } +} + +@ @<Compute (case 2) test coefficients |(t0,t1,t2)| for $d(t)$ versus $d_k$ or $d_{k-1}$...@>= +{ + mp_number abs_du, abs_dv; + new_number(abs_du); + new_number(abs_dv); + set_number_from_subtraction(du, ww->x_coord, w->x_coord); + set_number_from_subtraction(dv, ww->y_coord, w->y_coord); + number_abs_clone(abs_du, du); + number_abs_clone(abs_dv, dv); + if (number_greaterequal(abs_du, abs_dv)) { + mp_number r1; + new_fraction(r1); + make_fraction(s, dv, du); + take_fraction(r1, x0, s); + set_number_from_subtraction(t0, r1, y0); + take_fraction(r1, x1, s); + set_number_from_subtraction(t1, r1, y1); + take_fraction(r1, x2, s); + set_number_from_subtraction(t2, r1, y2); + if (number_negative(du)) { + number_negate(t0); + number_negate(t1); + number_negate(t2); + } + free_number(r1); + } else { + mp_number r1; + new_fraction(r1); + make_fraction(s, du, dv); + take_fraction(r1, y0, s); + set_number_from_subtraction(t0, x0, r1); + take_fraction(r1, y1, s); + set_number_from_subtraction(t1, x1, r1); + take_fraction(r1, y2, s); + set_number_from_subtraction(t2, x2, r1); + if (number_negative(dv)) { + number_negate(t0); + number_negate(t1); + number_negate(t2); + } + free_number(r1); + } + free_number(abs_du); + free_number(abs_dv); + if (number_negative(t0)) { + set_number_to_zero(t0); /* should be positive without rounding error */ + } +} + +@ The curve has crossed $d_k$ or $d_{k-1}$; its initial segment satisfies $(*)$, +and it might cross again and return towards $s_{k-1}$ or $s_k$, respectively, +yielding another solution of $(*)$. + +@<Split the cubic at $t$, and split off another...@>= +{ + mp_split_cubic(mp, p, &t); + p = mp_next_knot(p); + mp_knot_info(p) = zero_off + rise; + --turn_amt; + set_number_from_of_the_way(v, t, *x0, *x1); + set_number_from_of_the_way(*x1, t, *x1, *x2); + set_number_from_of_the_way(*x0, t, v, *x1); + set_number_from_of_the_way(v, t, *y0, *y1); + set_number_from_of_the_way(*y1, t, *y1, *y2); + set_number_from_of_the_way(*y0, t, v, *y1); + if (turn_amt < 0) { + mp_number arg1, arg2, arg3; + new_number(arg1); + new_number(arg2); + new_number(arg3); + set_number_from_of_the_way(t1, t, t1, t2); + if (number_positive(t1)) { + set_number_to_zero(t1); /* without rounding error, |t1| would be |<=0| */ + } + number_negated_clone(arg2, t1); + number_negated_clone(arg3, t2); + crossing_point(t, arg1, arg2, arg3); /* arg1 is zero */ + free_number(arg1); + free_number(arg2); + free_number(arg3); + if (number_greater(t, fraction_one_t)) { + number_clone(t, fraction_one_t); + } + ++turn_amt; + if (number_equal(t,fraction_one_t) && (mp_next_knot(p) != q)) { + mp_knot_info(mp_next_knot(p)) = mp_knot_info(mp_next_knot(p)) - rise; + } else { + mp_split_cubic(mp, p, &t); + mp_knot_info(mp_next_knot(p)) = zero_off - rise; + set_number_from_of_the_way(v, t, *x1, *x2); + set_number_from_of_the_way(*x1, t, *x0, *x1); + set_number_from_of_the_way(*x2, t, *x1, v); + set_number_from_of_the_way(v, t, *y1, *y2); + set_number_from_of_the_way(*y1, t, *y0, *y1); + set_number_from_of_the_way(*y2, t, *y1, v); + } + } +} + +@ Now we must consider the general problem of |offset_prep|, when nothing is +known about a given cubic. We start by finding its direction in the vicinity of +|t=0|. + +If $z'(t)=0$, the given cubic is numerically unstable but |offset_prep| has not +yet introduced any more numerical errors. Thus we can compute the true initial +direction for the given cubic, even if it is almost degenerate. + +@<Find the initial direction |(dx,dy)|@>= +number_clone(dx_m, zero_t); +number_clone(dy_m, zero_t); +/* todo: just if else and test before assignment */ +number_clone(dx, x0); +number_clone(dy, y0); +if (number_zero(dx) && number_zero(dy)) { + number_clone(dx, x1); + number_clone(dy, y1); + if (number_zero(dx) && number_zero(dy)) { + number_clone(dx, x2); + number_clone(dy, y2); + } +} +if (p == c) { + number_clone(dx0, dx); + number_clone(dy0, dy); +} + +@ @<Find the final direction |(dxin,dyin)|@>= +number_clone(dxin, x2); +number_clone(dyin, y2); +if (number_zero(dxin) && number_zero(dyin)) { + number_clone(dxin, x1); + number_clone(dyin, y1); + if (number_zero(dxin) && number_zero(dyin)) { + number_clone(dxin, x0); + number_clone(dyin, y0); + } +} + +@ The next step is to bracket the initial direction between consecutive edges of +the pen polygon. We must be careful to turn clockwise only if this makes the turn +less than $180^\circ$. (A $180^\circ$ turn must be counter-clockwise in order to +make |doublepath| envelopes come out @:double_path_}{|doublepath| primitive@> +right.) This code depends on |w0| being the offset for |(dxin,dyin)|. + +@<Update |mp_knot_info(p)| and find the offset $w_k$ such that...@>= +{ + turn_amt = mp_get_turn_amt(mp, w0, &dx, &dy, ab_vs_cd(dy, dxin, dx, dyin) >= 0); + w = mp_pen_walk(mp, w0, turn_amt); + w0 = w; + mp_knot_info(p) = mp_knot_info(p) + turn_amt; +} + +@ Decide how many pen offsets to go away from |w| in order to find the offset for +|(dx,dy)|, going counterclockwise if |ccw| is |true|. This assumes that |w| is +the offset for some direction $(x',y')$ from which the angle to |(dx,dy)| in the +sense determined by |ccw| is less than or equal to $180^\circ$. + +If the pen polygon has only two edges, they could both be parallel to |(dx,dy)|. +In this case, we must be careful to stop after crossing the first such edge in +order to avoid an infinite loop. + +@<Declarations@>= +static int mp_get_turn_amt (MP mp, mp_knot w, mp_number *dx, mp_number *dy, int ccw); + +@ @c +int mp_get_turn_amt (MP mp, mp_knot w, mp_number *dx, mp_number *dy, int ccw) +{ + int s = 0; /* turn amount so far */ + mp_number arg1, arg2; + new_number(arg1); + new_number(arg2); + if (ccw) { + int t; + mp_knot ww = mp_next_knot(w); + do { + set_number_from_subtraction(arg1, ww->x_coord, w->x_coord); + set_number_from_subtraction(arg2, ww->y_coord, w->y_coord); + t = ab_vs_cd(*dy, arg1, *dx, arg2); + if (t < 0) { + break; + } else { + ++s; + w = ww; + ww = mp_next_knot(ww); + } + } while (t > 0); + } else { + mp_knot ww = mp_prev_knot(w); + set_number_from_subtraction(arg1, w->x_coord, ww->x_coord); + set_number_from_subtraction(arg2, w->y_coord, ww->y_coord); + while (ab_vs_cd(*dy, arg1, *dx, arg2) < 0) { + --s; + w = ww; + ww = mp_prev_knot(ww); + set_number_from_subtraction(arg1, w->x_coord, ww->x_coord); + set_number_from_subtraction(arg2, w->y_coord, ww->y_coord); + } + } + free_number(arg1); + free_number(arg2); + return s; +} + +@ When we're all done, the final offset is |w0| and the final curve direction is +|(dxin,dyin)|. With this knowledge of the incoming direction at |c|, we can +correct |mp_info(c)| which was erroneously based on an incoming offset of~|h|. + +@<Fix the offset change in |mp_knot_info(c)| and set |c| to the return value of...@>= +mp->spec_offset = mp_knot_info(c) - zero_off; +if (mp_next_knot(c) == c) { + mp_knot_info(c) = zero_off + n; +} else { + mp_knot_info(c) += k_needed; + while (w0 != h) { + mp_knot_info(c) += 1; + w0 = mp_next_knot(w0); + } + while (mp_knot_info(c) <= zero_off - n) { + mp_knot_info(c) += n; + } + while (mp_knot_info(c) > zero_off) { + mp_knot_info(c) -= n; + } + ; + if ((mp_knot_info(c) != zero_off) && ab_vs_cd(dy0, dxin, dx0, dyin) >= 0) { + mp_knot_info(c) += n; + } +} + +@ Finally we want to reduce the general problem to situations that +|fin_offset_prep| can handle. We split the cubic into at most three parts with +respect to $d_{k-1}$, and apply |fin_offset_prep| to each part. + +@<Complete the offset splitting process@>= +ww = mp_prev_knot(w); +@<Compute (case 2) test coefficients |(t0,t1,t2)| for $d(t)$ versus $d_k$ or $d_{k-1}$@> +@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set |t:=fraction_one+1|@> +if (number_greater(t, fraction_one_t)) { + mp_fin_offset_prep(mp, p, w, &x0, &x1, &x2, &y0, &y1, &y2, 1, turn_amt); +} else { + mp_split_cubic(mp, p, &t); + r = mp_next_knot(p); + set_number_from_of_the_way(x1a, t, x0, x1); + set_number_from_of_the_way(x1, t, x1, x2); + set_number_from_of_the_way(x2a, t, x1a, x1); + set_number_from_of_the_way(y1a, t, y0, y1); + set_number_from_of_the_way(y1, t, y1, y2); + set_number_from_of_the_way(y2a, t, y1a, y1); + mp_fin_offset_prep (mp, p, w, &x0, &x1a, &x2a, &y0, &y1a, &y2a, 1, 0); + number_clone(x0, x2a); + number_clone(y0, y2a); + mp_knot_info(r) = zero_off - 1; + if (turn_amt >= 0) { + mp_number arg1, arg2, arg3; + new_number(arg1); + new_number(arg2); + new_number(arg3); + set_number_from_of_the_way(t1, t, t1, t2); + if (number_positive(t1)) { + set_number_to_zero(t1); + } + number_negated_clone(arg2, t1); + number_negated_clone(arg3, t2); + crossing_point(t, arg1, arg2, arg3); + free_number(arg1); + free_number(arg2); + free_number(arg3); + if (number_greater(t, fraction_one_t)) { + number_clone(t, fraction_one_t); + } + @<Split off another rising cubic for |fin_offset_prep|@> + mp_fin_offset_prep(mp, r, ww, &x0, &x1, &x2, &y0, &y1, &y2, -1, 0); + } else { + mp_fin_offset_prep(mp, r, ww, &x0, &x1, &x2, &y0, &y1, &y2, -1, (-1 - turn_amt)); + } +} + +@ @<Split off another rising cubic for |fin_offset_prep|@>= +mp_split_cubic(mp, r, &t); +mp_knot_info(mp_next_knot(r)) = zero_off + 1; +set_number_from_of_the_way(x1a, t, x1, x2); +set_number_from_of_the_way(x1, t, x0, x1); +set_number_from_of_the_way(x0a, t, x1, x1a); +set_number_from_of_the_way(y1a, t, y1, y2); +set_number_from_of_the_way(y1, t, y0, y1); +set_number_from_of_the_way(y0a, t, y1, y1a); +mp_fin_offset_prep (mp, mp_next_knot(r), w, &x0a, &x1a, &x2, &y0a, &y1a, &y2, 1, turn_amt); +number_clone(x2, x0a); +number_clone(y2, y0a); + +@ At this point, the direction of the incoming pen edge is |(-du,-dv)|. When the +component of $d(t)$ perpendicular to |(-du,-dv)| crosses zero, we need to decide +whether the directions are parallel or antiparallel. We can test this by finding +the dot product of $d(t)$ and |(-du,-dv)|, but this should be avoided when the +value of |turn_amt| already determines the answer. If |t2<0|, there is one +crossing and it is antiparallel only if |turn_amt>=0|. If |turn_amt<0|, there +should always be at least one crossing and the first crossing cannot be +antiparallel. + +@<Find the first |t| where $d(t)$ crosses $d_{k-1}$ or set...@>= +crossing_point(t, t0, t1, t2); +if (turn_amt >= 0) { + if (number_negative(t2)) { + number_clone(t, fraction_one_t); + number_add_scaled(t, 1); + } else { + mp_number tmp, arg1, r1; + new_fraction(r1); + new_number(tmp); + new_number(arg1); + set_number_from_of_the_way(u0, t, x0, x1); + set_number_from_of_the_way(u1, t, x1, x2); + set_number_from_of_the_way(tmp, t, u0, u1); + number_negated_clone(arg1, du); + take_fraction(ss, arg1, tmp); + set_number_from_of_the_way(v0, t, y0, y1); + set_number_from_of_the_way(v1, t, y1, y2); + set_number_from_of_the_way(tmp, t, v0, v1); + number_negated_clone(arg1, dv); + take_fraction(r1, arg1, tmp); + number_add(ss, r1); + free_number(tmp); + if (number_negative(ss)) { + number_clone(t, fraction_one_t); + number_add_scaled(t, 1); + } + free_number(arg1); + free_number(r1); + } +} else if (number_greater(t, fraction_one_t)) { + number_clone(t, fraction_one_t); +} + +@ If the cubic almost has a cusp, it is a numerically ill-conditioned problem to +decide which way it loops around but that's OK as long we're consistent. To make +|doublepath| envelopes work properly, reversing the path should always change +the sign of |turn_amt|. + +@<Decide on the net change in pen offsets and set |turn_amt|@>= +{ + int sign = ab_vs_cd(dx, dyin, dxin, dy); + if (sign < 0) { + d_sign = -1; + } else if (sign == 0) { + d_sign = 0; + } else { + d_sign = 1; + } +} +if (d_sign == 0) { + @<Check rotation direction based on node position@> +} +if (d_sign == 0) { + if (number_zero(dx)) { + d_sign = number_positive(dy) ? 1 : -1; + } else { + d_sign = number_positive(dx) ? 1 : -1; + } +} +@<Make |ss| negative if and only if the total change in direction is more than $180^\circ$@> +turn_amt = mp_get_turn_amt(mp, w, &dxin, &dyin, (d_sign > 0)); +if (number_negative(ss)) { + turn_amt = turn_amt - d_sign * n; +} + +@ We check rotation direction by looking at the vector connecting the current +node with the next. If its angle with incoming and outgoing tangents has the same +sign, we pick this as |d_sign|, since it means we have a flex, not a cusp. +Otherwise we proceed to the cusp code. + +@<Check rotation direction based on node position@>= +{ + int t; + set_number_from_subtraction(u0, q->x_coord, p->x_coord); + set_number_from_subtraction(u1, q->y_coord, p->y_coord); + t = ab_vs_cd(dx, u1, u0, dy) + ab_vs_cd(u0, dyin, dxin, u1); + // number_half(t); + if (t < 0) { + d_sign = -1; + } else if (t == 0) { + d_sign = 0; + } else { + d_sign = 1; + } +} + +@ In order to be invariant under path reversal, the result of this computation +should not change when |x0|, |y0|, $\ldots$ are all negated and |(x0,y0)| is then +swapped with |(x2,y2)|. We make use of the identities |take_fraction(-a,-b) = +take_fraction(a,b)| and |t_of_the_way(-a,-b) = - (t_of_the_way(a,b))|. + +@<Make |ss| negative if and only if the total change in direction is...@>= +{ + mp_number r1, r2, arg1; + new_number(arg1); + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, x0, y2); + take_fraction(r2, x2, y0); + number_half(r1); + number_half(r2); + set_number_from_subtraction(t0, r1, r2); + set_number_from_addition(arg1, y0, y2); + take_fraction(r1, x1, arg1); + set_number_from_addition(arg1, x0, x2); + /*|take_fraction(r1, y1, arg1);|*//* The old one, is it correct ?*/ + take_fraction(r2, y1, arg1); + number_half(r1); + number_half(r2); + set_number_from_subtraction(t1, r1, r2); + free_number(arg1); + free_number(r1); + free_number(r2); +} +if (number_zero(t0)) { + set_number_from_scaled(t0, d_sign); /* path reversal always negates |d_sign| */ +} +if (number_positive(t0)) { + mp_number arg3; + new_number(arg3); + number_negated_clone(arg3, t0); + crossing_point(t, t0, t1, arg3); + free_number(arg3); + set_number_from_of_the_way(u0, t, x0, x1); + set_number_from_of_the_way(u1, t, x1, x2); + set_number_from_of_the_way(v0, t, y0, y1); + set_number_from_of_the_way(v1, t, y1, y2); +} else { + mp_number arg1; + new_number(arg1); + number_negated_clone(arg1, t0); + crossing_point(t, arg1, t1, t0); + free_number(arg1); + set_number_from_of_the_way(u0, t, x2, x1); + set_number_from_of_the_way(u1, t, x1, x0); + set_number_from_of_the_way(v0, t, y2, y1); + set_number_from_of_the_way(v1, t, y1, y0); +} +{ + mp_number tmp1, tmp2, r1, r2, arg1; + new_fraction(r1); + new_fraction(r2); + new_number(arg1); + new_number(tmp1); + new_number(tmp2); + set_number_from_of_the_way(tmp1, t, u0, u1); + set_number_from_of_the_way(tmp2, t, v0, v1); + set_number_from_addition(arg1, x0, x2); + take_fraction(r1, arg1, tmp1); + set_number_from_addition(arg1, y0, y2); + take_fraction(r2, arg1, tmp2); + set_number_from_addition(ss, r1, r2); + free_number(arg1); + free_number(r1); + free_number(r2); + free_number(tmp1); + free_number(tmp2); +} + +@ Here's a routine that prints an envelope spec in symbolic form. It assumes that +the |cur_pen| has not been walked around to the first offset. + +@c +static void mp_print_spec (MP mp, mp_knot cur_spec, mp_knot cur_pen, const char *s) +{ + mp_knot w; /* the current pen offset */ + mp_knot p = cur_spec; /* list traversal */ + mp_print_diagnostic(mp, "Envelope spec", s, 1); + w = mp_pen_walk(mp, cur_pen, mp->spec_offset); + mp_print_ln(mp); + mp_print_two(mp, &(cur_spec->x_coord), &(cur_spec->y_coord)); + mp_print_str(mp, " % beginning with offset "); + mp_print_two(mp, &(w->x_coord), &(w->y_coord)); + do { + while (1) { + mp_knot q = mp_next_knot(p); + @<Print the cubic between |p| and |q|@> + p = q; + if ((p == cur_spec) || (mp_knot_info(p) != zero_off)) { + break; + } + } + if (mp_knot_info(p) != zero_off) { + @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@> + } + } while (p != cur_spec); + mp_print_nl(mp, " & cycle"); + mp_end_diagnostic(mp, 1); +} + +@ @<Update |w| as indicated by |mp_knot_info(p)| and print an explanation@>= +w = mp_pen_walk (mp, w, (mp_knot_info(p) - zero_off)); +mp_print_str(mp, " % "); +if (mp_knot_info(p) > zero_off) { + mp_print_str(mp, "counter"); +} +mp_print_str(mp, "clockwise to offset "); +mp_print_two(mp, &(w->x_coord), &(w->y_coord)); + +@ @<Print the cubic between |p| and |q|@>= +mp_print_nl(mp, " .. controls "); +mp_print_two(mp, &(p->right_x), &(p->right_y)); +mp_print_str(mp, " and "); +mp_print_two(mp, &(q->left_x), &(q->left_y)); +mp_print_nl(mp, " .. "); +mp_print_two(mp, &(q->x_coord), &(q->y_coord)); + +@ Once we have an envelope spec, the remaining task to construct the actual +envelope by offsetting each cubic as determined by the |info| fields in the +knots. First we use |offset_prep| to convert the |c| into an envelope spec. Then +we add the offsets so that |c| becomes a cyclic path that represents the +envelope. + +The |linejoin| and |miterlimit| parameters control the treatment of points where the +pen offset changes, and |linecap| controls the endpoints of a |doublepath|. The +endpoints are easily located because |c| is given in undoubled form and then +doubled in this procedure. We use |spec_p1| and |spec_p2| to keep track of the +endpoints and treat them like very sharp corners. Butt end caps are treated like +beveled joins; round end caps are treated like round joins; and square end caps +are achieved by setting |join_type:=3|. + +None of these parameters apply to inside joins where the convolution tracing has +retrograde lines. In such cases we use a simple connect-the-endpoints approach +that is achieved by setting |join_type:=2|. + +@c +static mp_knot mp_make_envelope (MP mp, mp_knot c, mp_knot h, int linejoin, int linecap, mp_number *miterlimit) +{ + mp_knot p, q, r, q0; /* for manipulating the path */ + mp_knot w, w0; /* the pen knot for the current offset */ + int k, k0; /* controls pen edge insertion */ + mp_number qx, qy; /* unshifted coordinates of |q| */ + mp_fraction dxin, dyin, dxout, dyout; /* directions at |q| when square or mitered */ + int join_type = 0; /* codes |0..3| for mitered, round, beveled, or square */ + @<Other local variables for |make_envelope|@> + new_number(max_ht); + new_number(tmp); + new_fraction(dxin); + new_fraction(dyin); + new_fraction(dxout); + new_fraction(dyout); + mp->spec_p1 = NULL; + mp->spec_p2 = NULL; + new_number(qx); + new_number(qy); + @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@> + @<Use |offset_prep| to compute the envelope spec then walk |h| around to the initial offset@> + w = h; + p = c; + do { + q = mp_next_knot(p); + q0 = q; + number_clone(qx, q->x_coord); + number_clone(qy, q->y_coord); + k = mp_knot_info(q); + k0 = k; + w0 = w; + if (k != zero_off) { + @<Set |join_type| to indicate how to handle offset changes at~|q|@> + } + @<Add offset |w| to the cubic from |p| to |q|@> + while (k != zero_off) { + @<Step |w| and move |k| one step closer to |zero_off|@> + if ((join_type == 1) || (k == zero_off)) { + mp_number xtot, ytot; + new_number(xtot); + new_number(ytot); + set_number_from_addition(xtot, qx, w->x_coord); + set_number_from_addition(ytot, qy, w->y_coord); + q = mp_insert_knot(mp, q, &xtot, &ytot); + free_number(xtot); + free_number(ytot); + } + } + if (q != mp_next_knot(p)) { + @<Set |p=mp_link(p)| and add knots between |p| and |q| as required by |join_type|@> + } + p = q; + } while (q0 != c); + free_number(max_ht); + free_number(tmp); + free_number(qx); + free_number(qy); + free_number(dxin); + free_number(dyin); + free_number(dxout); + free_number(dyout); + return c; +} + +@ @<Use |offset_prep| to compute the envelope spec then walk |h| around to...@>= +c = mp_offset_prep (mp, c, h); +if (number_positive(internal_value(mp_tracing_specs_internal))) { + mp_print_spec(mp, c, h, ""); +} +h = mp_pen_walk (mp, h, mp->spec_offset); + +@ Mitered and squared-off joins depend on path directions that are difficult to +compute for degenerate cubics. The envelope spec computed by |offset_prep| can +have degenerate cubics only if the entire cycle collapses to a single degenerate +cubic. Setting |join_type:=2| in this case makes the computed envelope degenerate +as well. + +@<Set |join_type| to indicate how to handle offset changes at~|q|@>= +if (k < zero_off) { + join_type = 2; /* mp_beveled_linejoin_code */ +} else { + if ((q != mp->spec_p1) && (q != mp->spec_p2)) { + join_type = linejoin; + } else if (linecap == mp_squared_linecap_code) { + join_type = 3; /* mp_weird_linejoin_code */ + } else { + join_type = 2 - linecap; /* mp_beveled_linejoin_code - linecap */ + } + if ((join_type == 0) || (join_type == 3)) { /* mp_mitered_linejoin_code || mp_weird_linejoin_code */ + @<Set the incoming and outgoing directions at |q|; in case of degeneracy set |join_type:=2|@> + if (join_type == 0) { /* mp_mitered_linejoin_code */ + @<If |miterlimit| is less than the secant of half the angle at |q| then set |join_type:=2|@> + } + } +} + +@ @<If |miterlimit| is less than the secant of half the angle at |q|...@>= +mp_number r1, r2; +new_fraction(r1); +new_fraction(r2); +take_fraction(r1, dxin, dxout); +take_fraction(r2, dyin, dyout); +number_add(r1, r2); +number_half(r1); +number_add(r1, fraction_half_t); +take_fraction(tmp, *miterlimit, r1); +if (number_less(tmp, unity_t)) { + mp_number ret; + new_number(ret); + take_scaled(ret, *miterlimit, tmp); + if (number_less(ret, unity_t)) { + join_type = 2; + } + free_number(ret); +} +free_number(r1); +free_number(r2); + +@ @<Other local variables for |make_envelope|@>= +mp_number tmp; /* a temporary value */ + +@ The coordinates of |p| have already been shifted unless |p| is the first knot +in which case they get shifted at the very end. + +@<Add offset |w| to the cubic from |p| to |q|@>= +number_add(p->right_x, w->x_coord); +number_add(p->right_y, w->y_coord); +number_add(q->left_x, w->x_coord); +number_add(q->left_y, w->y_coord); +number_add(q->x_coord, w->x_coord); +number_add(q->y_coord, w->y_coord); +mp_left_type(q) = mp_explicit_knot; +mp_right_type(q) = mp_explicit_knot; + +@ @<Step |w| and move |k| one step closer to |zero_off|@>= +if (k > zero_off) { + w = mp_next_knot(w); + --k; +} else { + w = mp_prev_knot(w); + ++k; +} + +@ The cubic from |q| to the new knot at |(x,y)| becomes a line segment and the +|mp_right_x| and |mp_right_y| fields of |r| are set from |q|. This is done in +case the cubic containing these control points is \quote {yet to be examined.} + +@<Declarations@>= +static mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number *x, mp_number *y); + +@ @c +mp_knot mp_insert_knot (MP mp, mp_knot q, mp_number *x, mp_number *y) +{ + /* returns the inserted knot */ + mp_knot r = mp_new_knot(mp); + mp_knot n = mp_next_knot(q); + mp_next_knot(r) = n; + mp_prev_knot(n) = r; + mp_prev_knot(r) = q; + mp_next_knot(q) = r; + number_clone(r->right_x, q->right_x); + number_clone(r->right_y, q->right_y); + number_clone(r->x_coord, *x); + number_clone(r->y_coord, *y); + number_clone(q->right_x, q->x_coord); + number_clone(q->right_y, q->y_coord); + number_clone(r->left_x, r->x_coord); + number_clone(r->left_y, r->y_coord); + mp_left_type(r) = mp_explicit_knot; + mp_right_type(r) = mp_explicit_knot; + mp_originator(r) = mp_program_code; + mp_knotstate(r) = mp_regular_knot; + return r; +} + +@ After setting |p:=mp_link(p)|, either |join_type=1| or |q=mp_link(p)|. + +@<Set |p=mp_link(p)| and add knots between |p| and |q| as...@>= +p = mp_next_knot(p); +if ((join_type == 0) || (join_type == 3)) { + if (join_type == 0) { + @<Insert a new knot |r| between |p| and |q| as required for a mitered join@> + } else { + @<Make |r| the last of two knots inserted between |p| and |q| to form a squared join@> + } + if (r != NULL) { + number_clone(r->right_x, r->x_coord); + number_clone(r->right_y, r->y_coord); + } +} + +@ For very small angles, adding a knot is unnecessary and would cause numerical +problems, so we just set |r:=NULL| in that case. + +@d near_zero_angle_k mp->math->md_near_zero_angle_t + +@<Insert a new knot |r| between |p| and |q| as required for a mitered join@>= +mp_number det; /* a determinant used for mitered join calculations */ +mp_number absdet; +mp_number r1, r2; +new_fraction(r1); +new_fraction(r2); +new_fraction(det); +new_fraction(absdet); +take_fraction(r1, dyout, dxin); +take_fraction(r2, dxout, dyin); +set_number_from_subtraction(det, r1, r2); +number_abs_clone(absdet, det); +if (number_less(absdet, near_zero_angle_k)) { + r = NULL; /* sine $<10^{-4}$ */ +} else { + mp_number xtot, ytot, xsub, ysub; + new_fraction(xsub); + new_fraction(ysub); + new_number(xtot); + new_number(ytot); + set_number_from_subtraction(tmp, q->x_coord, p->x_coord); + take_fraction(r1, tmp, dyout); + set_number_from_subtraction(tmp, q->y_coord, p->y_coord); + take_fraction(r2, tmp, dxout); + set_number_from_subtraction(tmp, r1, r2); + make_fraction(r1, tmp, det); + number_clone(tmp, r1); + take_fraction(xsub, tmp, dxin); + take_fraction(ysub, tmp, dyin); + set_number_from_addition(xtot, p->x_coord, xsub); + set_number_from_addition(ytot, p->y_coord, ysub); + r = mp_insert_knot(mp, p, &xtot, &ytot); + free_number(xtot); + free_number(ytot); + free_number(xsub); + free_number(ysub); +} +free_number(r1); +free_number(r2); +free_number(det); +free_number(absdet); + +@ @<Make |r| the last of two knots inserted between |p| and |q| to form a...@>= +mp_number ht_x, ht_y; /* perpendicular to the segment from |p| to |q| */ +mp_number ht_x_abs, ht_y_abs; /* absolutes */ +mp_number xtot, ytot, xsub, ysub; +new_fraction(xsub); +new_fraction(ysub); +new_number(xtot); +new_number(ytot); +new_fraction(ht_x); +new_fraction(ht_y); +new_fraction(ht_x_abs); +new_fraction(ht_y_abs); +set_number_from_subtraction(ht_x, w->y_coord, w0->y_coord); +set_number_from_subtraction(ht_y, w0->x_coord, w->x_coord); +number_abs_clone(ht_x_abs, ht_x); +number_abs_clone(ht_y_abs, ht_y); +while (number_less(ht_x_abs, fraction_half_t) && number_less(ht_y_abs, fraction_half_t)) { + number_double(ht_x); + number_double(ht_y); + number_abs_clone(ht_x_abs, ht_x); + number_abs_clone(ht_y_abs, ht_y); +} +@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range dot product with |(ht_x,ht_y)|@> +{ + mp_number r1 ,r2; + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, dxin, ht_x); + take_fraction(r2, dyin, ht_y); + number_add(r1, r2); + make_fraction(tmp, max_ht, r1); + free_number(r1); + free_number(r2); +} +take_fraction(xsub, tmp, dxin); +take_fraction(ysub, tmp, dyin); +set_number_from_addition(xtot, p->x_coord, xsub); +set_number_from_addition(ytot, p->y_coord, ysub); +r = mp_insert_knot(mp, p, &xtot, &ytot); +{ + mp_number r1 ,r2; + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, dxout, ht_x); + take_fraction(r2, dyout, ht_y); + number_add(r1, r2); + make_fraction(tmp, max_ht, r1); + free_number(r1); + free_number(r2); +} +take_fraction(xsub, tmp, dxout); +take_fraction(ysub, tmp, dyout); +set_number_from_addition(xtot, q->x_coord, xsub); +set_number_from_addition(ytot, q->y_coord, ysub); +r = mp_insert_knot(mp, r, &xtot, &ytot); +free_number(xsub); +free_number(ysub); +free_number(xtot); +free_number(ytot); +free_number(ht_x); +free_number(ht_y); +free_number(ht_x_abs); +free_number(ht_y_abs); + +@ @<Other local variables for |make_envelope|@>= +mp_number max_ht; /* maximum height of the pen polygon above the |w0|-|w| line */ +int kk; /* keeps track of the pen vertices being scanned */ +mp_knot ww; /* the pen vertex being tested */ + +@ The dot product of the vector from |w0| to |ww| with |(ht_x,ht_y)| ranges +from zero to |max_ht|. + +@<Scan the pen polygon between |w0| and |w| and make |max_ht| the range...@>= +set_number_to_zero(max_ht); +kk = zero_off; +ww = w; +while (1) { + @<Step |ww| and move |kk| one step closer to |k0|@> + if (kk == k0) { + break; + } else { + mp_number r1, r2; + new_fraction(r1); + new_fraction(r2); + set_number_from_subtraction(tmp, ww->x_coord, w0->x_coord); + take_fraction(r1, tmp, ht_x); + set_number_from_subtraction(tmp, ww->y_coord, w0->y_coord); + take_fraction(r2, tmp, ht_y); + set_number_from_addition(tmp, r1, r2); + free_number(r1); + free_number(r2); + if (number_greater(tmp, max_ht)) { + number_clone(max_ht, tmp); + } + } +} + +@ @<Step |ww| and move |kk| one step closer to |k0|@>= +if (kk > k0) { + ww = mp_next_knot(ww); + --kk; +} else { + ww = mp_prev_knot(ww); + ++kk; +} + +@ @<If endpoint, double the path |c|, and set |spec_p1| and |spec_p2|@>= +if (mp_left_type(c) == mp_endpoint_knot) { + mp->spec_p1 = mp_htap_ypoc(mp, c); + mp->spec_p2 = mp->path_tail; + mp_originator(mp->spec_p1) = mp_program_code; + mp_knotstate(mp->spec_p1) = mp_regular_knot; + mp_prev_knot(mp->spec_p1) = mp_next_knot(mp->spec_p2); + mp_next_knot(mp->spec_p2) = mp_next_knot(mp->spec_p1); + mp_prev_knot(c) = mp->spec_p1; + mp_next_knot(mp->spec_p1) = c; + mp_remove_cubic(mp, mp->spec_p1); + c = mp->spec_p1; + if (c != mp_next_knot(c)) { + mp_originator(mp->spec_p2) = mp_program_code; + mp_knotstate(mp->spec_p2) = mp_regular_knot; + mp_remove_cubic(mp, mp->spec_p2); + } else { + @<Make |c| look like a cycle of length one@> + } +} + +@ @<Make |c| look like a cycle of length one@>= +mp_left_type(c) = mp_explicit_knot; +mp_right_type(c) = mp_explicit_knot; +number_clone(c->left_x, c->x_coord); +number_clone(c->left_y, c->y_coord); +number_clone(c->right_x, c->x_coord); +number_clone(c->right_y, c->y_coord); + +@ In degenerate situations we might have to look at the knot preceding~|q|. That +knot is |p| but if |p<>c|, its coordinates have already been offset by |w|. + +@<Set the incoming and outgoing directions at |q|; in case of...@>= +set_number_from_subtraction(dxin, q->x_coord, q->left_x); +set_number_from_subtraction(dyin, q->y_coord, q->left_y); +if (number_zero(dxin) && number_zero(dyin)) { + set_number_from_subtraction(dxin, q->x_coord, p->right_x); + set_number_from_subtraction(dyin, q->y_coord, p->right_y); + if (number_zero(dxin) && number_zero(dyin)) { + set_number_from_subtraction(dxin, q->x_coord, p->x_coord); + set_number_from_subtraction(dyin, q->y_coord, p->y_coord); + if (p != c) { + /* the coordinates of |p| have been offset by |w| */ + number_add(dxin, w->x_coord); + number_add(dyin, w->y_coord); + } + } +} +pyth_add(tmp, dxin, dyin); +if (number_zero(tmp)) { + join_type = 2; +} else { + mp_number r1; + new_fraction(r1); + make_fraction(r1, dxin, tmp); + number_clone(dxin, r1); + make_fraction(r1, dyin, tmp); + number_clone(dyin, r1); + free_number(r1); + @<Set the outgoing direction at |q|@> +} + +@ If |q=c| then the coordinates of |r| and the control points between |q| and~|r| +have already been offset by |h|. + +@<Set the outgoing direction at |q|@>= +set_number_from_subtraction(dxout, q->right_x, q->x_coord); +set_number_from_subtraction(dyout, q->right_y, q->y_coord); +if (number_zero(dxout) && number_zero(dyout)) { + r = mp_next_knot(q); + set_number_from_subtraction(dxout, r->left_x, q->x_coord); + set_number_from_subtraction(dyout, r->left_y, q->y_coord); + if (number_zero(dxout) && number_zero(dyout)) { + set_number_from_subtraction(dxout, r->x_coord, q->x_coord); + set_number_from_subtraction(dyout, r->y_coord, q->y_coord); + } +} +if (q == c) { + number_subtract(dxout, h->x_coord); + number_subtract(dyout, h->y_coord); +} +pyth_add(tmp, dxout, dyout); +if (number_zero(tmp)) { + /* |mp_confusion(mp, "degenerate spec");| */ + @:this can't happen degerate spec}{\quad degenerate spec@> + /* + + But apparently, it actually can happen. The test case is this: + + path p; + linejoin := mitered; + p:= (10,0)..(0,10)..(-10,0)..(0,-10)..cycle; + addto currentpicture contour p withpen pensquare; + + The reason for failure here is the addition of |r != q| in revision + 1757 in \quote {Advance |p| to node |q|, removing any ``dead} cubics'', + which itself was needed to fix a bug with disappearing knots in a + path that was rotated exactly 45 degrees (luatex.org bug 530). + */ +} else { + mp_number r1; + new_fraction(r1); + make_fraction(r1, dxout, tmp); + number_clone(dxout, r1); + make_fraction(r1, dyout, tmp); + number_clone(dyout, r1); + free_number(r1); +} + +@* Direction and intersection times. + +A path of length $n$ is defined parametrically by functions $x(t)$ and $y(t)$, +for |0<=t<=n|; we can regard $t$ as the \quote {time} at which the path reaches the +point $\bigl(x(t),y(t)\bigr)$. In this section of the program we shall consider +operations that determine special times associated with given paths: the first +time that a path travels in a given direction, and a pair of times at which two +paths cross each other. + +@ Let's start with the easier task. The function |find_direction_time| is given a +direction |(x,y)| and a path starting at~|h|. If the path never travels in +direction |(x,y)|, the direction time will be~|-1|; otherwise it will be +nonnegative. + +Certain anomalous cases can arise: If |(x,y)=(0,0)|, so that the given direction +is undefined, the direction time will be~0. If $\bigl(x'(t), y'(t)\bigr)=(0,0)$, +so that the path direction is undefined, it will be assumed to match any given +direction at time~|t|. + +The routine solves this problem in nondegenerate cases by rotating the path and +the given direction so that |(x,y)=(1,0)|; i.e., the main task will be to find +when a given path first travels \quote {due east.} + +@c +static void mp_find_direction_time (MP mp, mp_number *ret, mp_number *x_orig, mp_number *y_orig, mp_knot h) +{ + mp_number max; /* $\max\bigl(\vert x\vert,\vert y\vert\bigr)$ */ + mp_knot p, q; /* for list traversal */ + mp_number n; /* the direction time at knot |p| */ + mp_number tt; /* the direction time within a cubic */ + mp_number abs_x, abs_y; /* Other local variables for |find_direction_time| */ + mp_number x1, x2, x3, y1, y2, y3; /* multiples of rotated derivatives */ + mp_number phi; /* angles of exit and entry at a knot */ + mp_number t; /* temp storage */ + mp_number x, y; + new_number(max); + new_number(x1); + new_number(x2); + new_number(x3); + new_number(y1); + new_number(y2); + new_number(y3); + new_fraction(t); + new_angle(phi); + set_number_to_zero(*ret); /* just in case */ + new_number(x); + new_number(y); + new_number(abs_x); + new_number(abs_y); + new_number(n); + new_fraction(tt); + number_clone(x, *x_orig); + number_clone(y, *y_orig); + number_abs_clone(abs_x, *x_orig); + number_abs_clone(abs_y, *y_orig); + /* + Normalize the given direction for better accuracy; but |return| with zero + result if it's zero + */ + if (number_less(abs_x, abs_y)) { + mp_number r1; + new_fraction(r1); + make_fraction(r1, x, abs_y); + number_clone(x, r1); + free_number(r1); + if (number_positive(y)) { + number_clone(y, fraction_one_t); + } else { + number_negated_clone(y, fraction_one_t); + } + } else if (number_zero(x)) { + goto FREE; + } else { + mp_number r1; + new_fraction(r1); + make_fraction(r1, y, abs_x); + number_clone(y, r1); + free_number(r1); + if (number_positive(x)) { + number_clone(x, fraction_one_t); + } else { + number_negated_clone(x, fraction_one_t); + } + } + p = h; + while (1) { + if (mp_right_type(p) == mp_endpoint_knot) { + break; + } else { + q = mp_next_knot(p); + @<Rotate the cubic between |p| and |q|; then |goto found| if the rotated cubic travels due east at some time |tt|; but |break| if an entire cyclic path has been traversed@> + p = q; + number_add(n, unity_t); + } + } + set_number_to_unity(*ret); + number_negate(*ret); + goto FREE; + FOUND: + set_number_from_addition(*ret, n, tt); + goto FREE; + FREE: + free_number(x); + free_number(y); + free_number(abs_x); + free_number(abs_y); + /* Free local variables for |find_direction_time| */ + free_number(x1); + free_number(x2); + free_number(x3); + free_number(y1); + free_number(y2); + free_number(y3); + free_number(t); + free_number(phi); + free_number(n); + free_number(max); + free_number(tt); +} + +@ Since we're interested in the tangent directions, we work with the derivative +$${1\over3}B'(x_0,x_1,x_2,x_3;t)= B(x_1-x_0,x_2-x_1,x_3-x_2;t)$$ instead of +$B(x_0,x_1,x_2,x_3;t)$ itself. The derived coefficients are also scale-d up in +order to achieve better accuracy. + +The given path may turn abruptly at a knot, and it might pass the critical +tangent direction at such a time. Therefore we remember the direction |phi| in +which the previous rotated cubic was traveling. (The value of |phi| will be +undefined on the first cubic, i.e., when |n=0|.) + +@<Rotate the cubic between |p| and |q|; then...@>= +set_number_to_zero(tt); +/* + Set local variables |x1,x2,x3| and |y1,y2,y3| to multiples of the control + points of the rotated derivatives. +*/ +{ + mp_number absval; + new_number(absval); + set_number_from_subtraction(x1, p->right_x, p->x_coord); + set_number_from_subtraction(x2, q->left_x, p->right_x); + set_number_from_subtraction(x3, q->x_coord, q->left_x); + set_number_from_subtraction(y1, p->right_y, p->y_coord); + set_number_from_subtraction(y2, q->left_y, p->right_y); + set_number_from_subtraction(y3, q->y_coord, q->left_y); + number_abs_clone(absval, x2); + number_abs_clone(max, x1); + if (number_greater(absval, max)) { + number_clone(max, absval); + } + number_abs_clone(absval, x3); + if (number_greater(absval, max)) { + number_clone(max, absval); + } + number_abs_clone(absval, y1); + if (number_greater(absval, max)) { + number_clone(max, absval); + } + number_abs_clone(absval, y2); + if (number_greater(absval, max)) { + number_clone(max, absval); + } + number_abs_clone(absval, y3); + if (number_greater(absval, max)) { + number_clone(max, absval); + } + free_number(absval); + if (number_zero(max)) { + goto FOUND; + } + while (number_less(max, fraction_half_t)) { + number_double(max); + number_double(x1); + number_double(x2); + number_double(x3); + number_double(y1); + number_double(y2); + number_double(y3); + } + number_clone(t, x1); + { + mp_number r1, r2; + new_fraction(r1); + new_fraction(r2); + take_fraction(r1, x1, x); + take_fraction(r2, y1, y); + set_number_from_addition(x1, r1, r2); + take_fraction(r1, y1, x); + take_fraction(r2, t, y); + set_number_from_subtraction(y1, r1, r2); + number_clone(t, x2); + take_fraction(r1, x2, x); + take_fraction(r2, y2, y); + set_number_from_addition(x2, r1, r2); + take_fraction(r1, y2, x); + take_fraction(r2, t, y); + set_number_from_subtraction(y2, r1, r2); + number_clone(t, x3); + take_fraction(r1, x3 ,x); + take_fraction(r2, y3, y); + set_number_from_addition(x3, r1, r2); + take_fraction(r1, y3, x); + take_fraction(r2, t, y); + set_number_from_subtraction(y3, r1, r2); + free_number(r1); + free_number(r2); + } +} +if (number_zero(y1) && (number_zero(x1) || number_positive(x1))) { + goto FOUND; +} +if (number_positive(n)) { + /* Exit to |found| if an eastward direction occurs at knot |p| */ + mp_number theta; + mp_number tmp; + new_angle(theta); + n_arg(theta, x1, y1); + new_angle(tmp); + set_number_from_subtraction(tmp, theta, one_eighty_deg_t); + if (number_nonnegative(theta) && number_nonpositive(phi) && number_greaterequal(phi, tmp)) { + free_number(tmp); + free_number(theta); + goto FOUND; + } + set_number_from_addition(tmp, theta, one_eighty_deg_t); + if (number_nonpositive(theta) && number_nonnegative(phi) && number_lessequal(phi, tmp)) { + free_number(tmp); + free_number(theta); + goto FOUND; + } + free_number(tmp); + free_number(theta); + if (p == h) { + break; + } +} +if (number_nonzero(x3) || number_nonzero(y3)) { + n_arg(phi, x3, y3); +} +/* + Exit to |found| if the curve whose derivatives are specified by + |x1,x2,x3,y1,y2,y3| travels eastward at some time~|tt|. In this step we + want to use the |crossing_point| routine to find the roots of the + quadratic equation $B(y_1,y_2,y_3;t)=0$. Several complications arise: If + the quadratic equation has a double root, the curve never crosses zero, + and |crossing_point| will find nothing; this case occurs iff + $y_1y_3=y_2^2$ and $y_1y_2<0$. If the quadratic equation has simple + roots, or only one root, we may have to negate it so that + $B(y_1,y_2,y_3;t)$ crosses from positive to negative at its first root. + And finally, we need to do special things if $B(y_1,y_2,y_3;t)$ is + identically zero. +*/ +if (number_negative(x1) && number_negative(x2) && number_negative(x3)) { + goto DONE; +} +{ + if (ab_vs_cd(y1, y3, y2, y2) == 0) { + /* + Handle the test for eastward directions when $y_1y_3=y_2^2$; either |goto + found| or |goto done|. + */ + { + if (ab_vs_cd(y1, y2, zero_t, zero_t) < 0) { + mp_number tmp, arg2; + new_number(tmp); + new_number(arg2); + set_number_from_subtraction(arg2, y1, y2); + make_fraction(t, y1, arg2); + free_number(arg2); + set_number_from_of_the_way(x1, t, x1, x2); + set_number_from_of_the_way(x2, t, x2, x3); + set_number_from_of_the_way(tmp, t, x1, x2); + if (number_zero(tmp) || number_positive(tmp)) { + free_number(tmp); + number_clone(tt, t); + fraction_to_round_scaled(tt); + goto FOUND; + } else { + free_number(tmp); + } + } else if (number_zero(y3)) { + if (number_zero(y1)) { + /* + Exit to |found| if the derivative $B(x_1,x_2,x_3;t)$ becomes |>=0| At + this point we know that the derivative of |y(t)| is identically zero, + and that |x1<0|; but either |x2>=0| or |x3>=0|, so there's some hope of + traveling east. + */ + { + mp_number arg1, arg2, arg3; + new_number(arg1); + new_number(arg2); + new_number(arg3); + number_negated_clone(arg1, x1); + number_negated_clone(arg2, x2); + number_negated_clone(arg3, x3); + crossing_point(t, arg1, arg2, arg3); + free_number(arg1); + free_number(arg2); + free_number(arg3); + if (number_lessequal(t, fraction_one_t)) { + number_clone(tt, t); + fraction_to_round_scaled(tt); + goto FOUND; + } else if (ab_vs_cd(x1, x3, x2, x2) <= 0) { + mp_number arg2; + new_number(arg2); + set_number_from_subtraction(arg2, x1, x2); + make_fraction(t, x1, arg2); + free_number(arg2); + number_clone(tt, t); + fraction_to_round_scaled(tt); + goto FOUND; + } + } + } else if (number_zero(x3) || number_positive(x3)) { + set_number_to_unity(tt); + goto FOUND; + } + } + goto DONE; + } + } +} +if (number_zero(y1) || number_negative(y1)) { + if (number_negative(y1)) { + number_negate(y1); + number_negate(y2); + number_negate(y3); + } else if (number_positive(y2)) { + number_negate(y2); + number_negate(y3); + } +} +/* + Check the places where $B(y_1,y_2,y_3;t)=0$ to see if $B(x_1,x_2,x_3;t)\ge0$ + The quadratic polynomial $B(y_1,y_2,y_3;t)$ begins |>=0| and has at most two + roots, because we know that it isn't identically zero. + + It must be admitted that the |crossing_point| routine is not perfectly + accurate; rounding errors might cause it to find a root when $y_1y_3>y_2^2$, or + to miss the roots when $y_1y_3<y_2^2$. The rotation process is itself subject + to rounding errors. Yet this code optimistically tries to do the right thing. +*/ +crossing_point(t, y1, y2, y3); +if (number_greater(t, fraction_one_t)) { + goto DONE; +} +set_number_from_of_the_way(y2, t, y2, y3); +set_number_from_of_the_way(x1, t, x1, x2); +set_number_from_of_the_way(x2, t, x2, x3); +set_number_from_of_the_way(x1, t, x1, x2); +if (number_zero(x1) || number_positive(x1)) { + number_clone(tt, t); + fraction_to_round_scaled(tt); + goto FOUND; +} +if (number_positive(y2)) { + set_number_to_zero(y2); +} +number_clone(tt, t); +{ + mp_number arg1, arg2, arg3; + new_number(arg1); + new_number(arg2); + new_number(arg3); + number_negated_clone(arg2, y2); + number_negated_clone(arg3, y3); + crossing_point(t, arg1, arg2, arg3); + free_number(arg1); + free_number(arg2); + free_number(arg3); +} +if (number_greater(t, fraction_one_t)) { + goto DONE; +} else { + mp_number tmp; + new_number(tmp); + set_number_from_of_the_way(x1, t, x1, x2); + set_number_from_of_the_way(x2, t, x2, x3); + set_number_from_of_the_way(tmp, t, x1, x2); + if (number_nonnegative(tmp)) { + free_number(tmp); + set_number_from_of_the_way(t, t, tt, fraction_one_t); + number_clone(tt, t); + fraction_to_round_scaled(tt); + goto FOUND; + } + free_number(tmp); +} +DONE: + +@ The intersection of two cubics can be found by an interesting variant of the +general bisection scheme described in the introduction to |crossing_point|.\ +Given $w(t)=B(w_0,w_1,w_2,w_3;t)$ and $z(t)=B(z_0,z_1,z_2,z_3;t)$, we wish to +find a pair of times $(t_1,t_2)$ such that $w(t_1)=z(t_2)$, if an intersection +exists. First we find the smallest rectangle that encloses the points +$\{w_0,w_1,w_2,w_3\}$ and check that it overlaps the smallest rectangle that +encloses $\{z_0,z_1,z_2,z_3\}$; if not, the cubics certainly don't intersect. But +if the rectangles do overlap, we bisect the intervals, getting new cubics $w'$ +and~$w''$, $z'$~and~$z''$; the intersection routine first tries for an +intersection between $w'$ and~$z'$, then (if unsuccessful) between $w'$ +and~$z''$, then (if still unsuccessful) between $w''$ and~$z'$, finally (if +thrice unsuccessful) between $w''$ and~$z''$. After $l$~successful levels of +bisection we will have determined the intersection times $t_1$ and~$t_2$ to +$l$~bits of accuracy. + +\def\submin{_{\rm min}} \def\submax{_{\rm max}} + +As before, it is better to work with the numbers $W_k=2^l(w_k-w_{k-1})$ and +$Z_k=2^l(z_k-z_{k-1})$ rather than the coefficients $w_k$ and $z_k$ themselves. +We also need one other quantity, $\Delta=2^l(w_0-z_0)$, to determine when the +enclosing rectangles overlap. Here's why: The $x$~coordinates of~$w(t)$ are +between $u\submin$ and $u\submax$, and the $x$~coordinates of~$z(t)$ are between +$x\submin$ and $x\submax$, if we write $w_k=(u_k,v_k)$ and $z_k=(x_k,y_k)$ and +$u\submin= \min(u_0,u_1,u_2,u_3)$, etc. These intervals of $x$~coordinates +overlap if and only if $u\submin\L x\submax$ and $x\submin\L u\submax$. Letting + +$$ + U\submin=\min(0,U_1,U_1+U_2,U_1+U_2+U_3),\; + U\submax=\max(0,U_1,U_1+U_2,U_1+U_2+U_3), +$$ + +we have $2^lu\submin=2^lu_0+U\submin$, etc.; the condition for overlap reduces to + +$$ + X\submin-U\submax\L 2^l(u_0-x_0)\L X\submax-U\submin. +$$ + +Thus we want to maintain the quantity $2^l(u_0-x_0)$; similarly, the quantity +$2^l(v_0-y_0)$ accounts for the $y$~coordinates. The coordinates of +$\Delta=2^l(w_0-z_0)$ must stay bounded as $l$ increases, because of the overlap +condition; i.e., we know that $X\submin$, $X\submax$, and their relatives are +bounded, hence $X\submax- U\submin$ and $X\submin-U\submax$ are bounded. + +@ Incidentally, if the given cubics intersect more than once, the process just +sketched will not necessarily find the lexicographically smallest pair +$(t_1,t_2)$. The solution actually obtained will be smallest in \quote {shuffled +order}; i.e., if $t_1=(.a_1a_2\ldots a_{16})_2$ and $t_2=(.b_1b_2\ldots +b_{16})_2$, then we will minimize $a_1b_1a_2b_2\ldots a_{16}b_{16}$, not +$a_1a_2\ldots a_{16}b_1b_2\ldots b_{16}$. Shuffled order agrees with +lexicographic order if all pairs of solutions $(t_1,t_2)$ and $(t_1',t_2')$ have +the property that $t_1<t_1'$ iff $t_2<t_2'$; but in general, lexicographic order +can be quite different, and the bisection algorithm would be substantially less +efficient if it were constrained by lexicographic order. + +For example, suppose that an overlap has been found for $l=3$ and $(t_1,t_2)= +(.101,.011)$ in binary, but that no overlap is produced by either of the +alternatives $(.1010,.0110)$, $(.1010,.0111)$ at level~4. Then there is probably +an intersection in one of the subintervals $(.1011,.011x)$; but lexicographic +order would require us to explore $(.1010,.1xxx)$ and $(.1011,.00xx)$ and +$(.1011,.010x)$ first. We wouldn't want to store all of the subdivision data for +the second path, so the subdivisions would have to be regenerated many times. +Such inefficiencies would be associated with every `1' in the binary +representation of~$t_1$. + +@ The subdivision process introduces rounding errors, hence we need to make a +more liberal test for overlap. It is not hard to show that the computed values of +$U_i$ differ from the truth by at most~$l$, on level~$l$, hence $U\submin$ and +$U\submax$ will be at most $3l$ in error. If $\beta$ is an upper bound on the +absolute error in the computed components of $\Delta=(|delx|,|dely|)$ on +level~$l$, we will replace the test `$X\submin-U\submax\L|delx|$' by the more +liberal test `$X\submin-U\submax\L|delx|+|tol|$', where $|tol|=6l+\beta$. + +More accuracy is obtained if we try the algorithm first with |tol=0|; the more +liberal tolerance is used only if an exact approach fails. It is convenient to do +this double-take by letting `3' in the preceding paragraph be a parameter, which +is first 0, then 3. + +@<Glob...@>= +unsigned int tol_step; /* either 0 or 3, usually */ + +@ We shall use an explicit stack to implement the recursive bisection +method described above. The |bisect_stack| array will contain numerous 5-word +packets like $(U_1,U_2,U_3,U\submin,U\submax)$, as well as 20-word packets +comprising the 5-word packets for $U$, $V$, $X$, and~$Y$. + +The following macros define the allocation of stack positions to +the quantities needed for bisection-intersection. + +@d stack_1(A) mp->bisect_stack[(A)] /* $U_1$, $V_1$, $X_1$, or $Y_1$ */ +@d stack_2(A) mp->bisect_stack[(A)+1] /* $U_2$, $V_2$, $X_2$, or $Y_2$ */ +@d stack_3(A) mp->bisect_stack[(A)+2] /* $U_3$, $V_3$, $X_3$, or $Y_3$ */ +@d stack_min(A) mp->bisect_stack[(A)+3] /* $U\submin$, $V\submin$, $X\submin$, or $Y\submin$ */ +@d stack_max(A) mp->bisect_stack[(A)+4] /* $U\submax$, $V\submax$, $X\submax$, or $Y\submax$ */ + +@d int_packets 20 /* number of words to represent $U_k$, $V_k$, $X_k$, and $Y_k$ */ + +@d u_packet(A) ((A)- 5) +@d v_packet(A) ((A)-10) +@d x_packet(A) ((A)-15) +@d y_packet(A) ((A)-20) + +@d l_packets (mp->bisect_ptr-int_packets) +@d r_packets mp->bisect_ptr + +@d ul_packet u_packet(l_packets) /* base of $U'_k$ variables */ +@d vl_packet v_packet(l_packets) /* base of $V'_k$ variables */ +@d xl_packet x_packet(l_packets) /* base of $X'_k$ variables */ +@d yl_packet y_packet(l_packets) /* base of $Y'_k$ variables */ +@d ur_packet u_packet(r_packets) /* base of $U''_k$ variables */ +@d vr_packet v_packet(r_packets) /* base of $V''_k$ variables */ +@d xr_packet x_packet(r_packets) /* base of $X''_k$ variables */ +@d yr_packet y_packet(r_packets) /* base of $Y''_k$ variables */ + +@d u1l stack_1(ul_packet) /* $U'_1$ */ +@d u2l stack_2(ul_packet) /* $U'_2$ */ +@d u3l stack_3(ul_packet) /* $U'_3$ */ +@d v1l stack_1(vl_packet) /* $V'_1$ */ +@d v2l stack_2(vl_packet) /* $V'_2$ */ +@d v3l stack_3(vl_packet) /* $V'_3$ */ +@d x1l stack_1(xl_packet) /* $X'_1$ */ +@d x2l stack_2(xl_packet) /* $X'_2$ */ +@d x3l stack_3(xl_packet) /* $X'_3$ */ +@d y1l stack_1(yl_packet) /* $Y'_1$ */ +@d y2l stack_2(yl_packet) /* $Y'_2$ */ +@d y3l stack_3(yl_packet) /* $Y'_3$ */ +@d u1r stack_1(ur_packet) /* $U''_1$ */ +@d u2r stack_2(ur_packet) /* $U''_2$ */ +@d u3r stack_3(ur_packet) /* $U''_3$ */ +@d v1r stack_1(vr_packet) /* $V''_1$ */ +@d v2r stack_2(vr_packet) /* $V''_2$ */ +@d v3r stack_3(vr_packet) /* $V''_3$ */ +@d x1r stack_1(xr_packet) /* $X''_1$ */ +@d x2r stack_2(xr_packet) /* $X''_2$ */ +@d x3r stack_3(xr_packet) /* $X''_3$ */ +@d y1r stack_1(yr_packet) /* $Y''_1$ */ +@d y2r stack_2(yr_packet) /* $Y''_2$ */ +@d y3r stack_3(yr_packet) /* $Y''_3$ */ + +@d stack_dx mp->bisect_stack[mp->bisect_ptr] /* stacked value of |delx| */ +@d stack_dy mp->bisect_stack[mp->bisect_ptr+1] /* stacked value of |dely| */ +@d stack_tol mp->bisect_stack[mp->bisect_ptr+2] /* stacked value of |tol| */ +@d stack_uv mp->bisect_stack[mp->bisect_ptr+3] /* stacked value of |uv| */ +@d stack_xy mp->bisect_stack[mp->bisect_ptr+4] /* stacked value of |xy| */ + +@d int_increment (int_packets+int_packets+5) /* number of stack words per level */ + +@<Glob...@>= +mp_number *bisect_stack; +int bisect_ptr; + +@ @<Allocate or initialize ...@>= +mp->bisect_stack = mp_memory_allocate((size_t) (bistack_size + 1) * sizeof(mp_number)); +for (int i=0; i<bistack_size + 1; i++) { + new_number(mp->bisect_stack[i]); +} + +@ @<Dealloc variables@>= +for (int i=0; i<bistack_size + 1; i++) { + free_number(mp->bisect_stack[i]); +} +mp_memory_free(mp->bisect_stack); + +@ Computation of the min and max is a tedious but fairly fast sequence of +instructions; exactly four comparisons are made in each branch. + +@<Declarations...@>= +static void mp_set_min_max (MP mp, int v); + +@ This was a macro but a function is way more efficient here. @c +void mp_set_min_max (MP mp, int v) +{ + if (number_negative(stack_1(v))) { + if (number_nonnegative (stack_3(v))) { + if (number_negative(stack_2(v))) { + set_number_from_addition(stack_min(v), stack_1(v), stack_2(v)); + } else { + number_clone(stack_min(v), stack_1(v)); + } + set_number_from_addition(stack_max(v), stack_1(v), stack_2(v)); + number_add(stack_max(v), stack_3(v)); + if (number_negative(stack_max(v))) { + set_number_to_zero(stack_max(v)); + } + } else { + set_number_from_addition(stack_min(v), stack_1(v), stack_2(v)); + number_add(stack_min(v), stack_3(v)); + if (number_greater(stack_min(v), stack_1(v))) { + number_clone(stack_min(v), stack_1(v)); + } + set_number_from_addition(stack_max(v), stack_1(v), stack_2(v)); + if (number_negative(stack_max(v))) { + set_number_to_zero(stack_max(v)); + } + } + } else if (number_nonpositive(stack_3(v))) { + if (number_positive(stack_2(v))) { + set_number_from_addition(stack_max(v), stack_1(v), stack_2(v)); + } else { + number_clone(stack_max(v), stack_1(v)); + } + set_number_from_addition(stack_min(v), stack_1(v), stack_2(v)); + number_add(stack_min(v), stack_3(v)); + if (number_positive(stack_min(v))) { + set_number_to_zero(stack_min(v)); + } + } else { + set_number_from_addition(stack_max(v), stack_1(v), stack_2(v)); + number_add(stack_max(v), stack_3(v)); + if (number_less(stack_max(v), stack_1(v))) { + number_clone(stack_max(v), stack_1(v)); + } + set_number_from_addition(stack_min(v), stack_1(v), stack_2(v)); + if (number_positive(stack_min(v))) { + set_number_to_zero(stack_min(v)); + } + } +} + +@ It's convenient to keep the current values of $l$, $t_1$, and $t_2$ in the +integer form $2^l+2^lt_1$ and $2^l+2^lt_2$. The |cubic_intersection| routine uses +global variables |cur_t| and |cur_tt| for this purpose; after successful +completion, |cur_t| and |cur_tt| will contain |unity| plus the |scaled| values of +$t_1$ and~$t_2$. + +The values of |cur_t| and |cur_tt| will be set to zero if |cubic_intersection| +finds no intersection. The routine gives up and gives an approximate answer if it +has backtracked more than 5000 times (otherwise there are cases where several +minutes of fruitless computation would be possible). + +@d max_patience 5000 + +@<Glob...@>= +mp_number cur_t; +mp_number cur_tt; /* controls and results of |cubic_intersection| */ +int time_to_go; /* this many backtracks before giving up */ +mp_number max_t; /* maximum of $2^{l+1}$ so far achieved */ + +@ @<Initialize table ...@>= +new_number(mp->cur_t); +new_number(mp->cur_tt); +new_number(mp->max_t); + +@ @<Dealloc ...@>= +free_number(mp->cur_t); +free_number(mp->cur_tt); +free_number(mp->max_t); + +@ The given cubics $B(w_0,w_1,w_2,w_3;t)$ and +$B(z_0,z_1,z_2,z_3;t)$ are specified in adjacent knot nodes |(p,mp_link(p))| +and |(pp,mp_link(pp))|, respectively. + +@d half(A) ((A)/2) + +@c +static int mp_cubic_intersection(MP mp, mp_knot p, mp_knot pp, int run) +{ + mp_knot q, qq; /* |mp_link(p)|, |mp_link(pp)| */ + mp_number x_two_t; /* increment bit precision */ + mp_number x_two_t_low_precision; /* check for low precision */ + mp->time_to_go = max_patience; + set_number_from_scaled(mp->max_t, 2); + new_number_clone(x_two_t, two_t); + new_number(x_two_t_low_precision); + /* added 2 bit of precision */ + number_double(x_two_t); + number_double(x_two_t); + set_number_from_double(x_two_t_low_precision, -0.5); + number_add(x_two_t_low_precision, x_two_t); + @<Initialize for intersections at level zero@> + CONTINUE: + while (1) { + /* + When we are in arbitrary precision math, low precisions can lead to + acces locations beyond the |stack_size|: in this case we say that + there is no intersection. + */ + if (((x_packet (mp->xy))+4)>bistack_size + || ((u_packet (mp->uv))+4)>bistack_size + || ((y_packet (mp->xy))+4)>bistack_size + || ((v_packet (mp->uv))+4)>bistack_size){ + set_number_from_scaled(mp->cur_t,1); + set_number_from_scaled(mp->cur_tt,1); + goto NOT_FOUND; + } + /* + Also, low precision can lead to wrong result in comparing so we check + that the level of bisection stay low, and later we will also check + that the bisection level are safe from approximations. + */ + if (number_greater(mp->max_t, x_two_t)){ + set_number_from_scaled(mp->cur_t,1); + set_number_from_scaled(mp->cur_tt,1); + goto NOT_FOUND; + } + if (number_to_scaled(mp->delx) - mp->tol <= number_to_scaled(stack_max (x_packet (mp->xy))) - number_to_scaled(stack_min (u_packet (mp->uv)))) { + if (number_to_scaled(mp->delx) + mp->tol >= number_to_scaled(stack_min (x_packet (mp->xy))) - number_to_scaled(stack_max (u_packet (mp->uv)))) { + if (number_to_scaled(mp->dely) - mp->tol <= number_to_scaled(stack_max (y_packet (mp->xy))) - number_to_scaled(stack_min (v_packet (mp->uv)))) { + if (number_to_scaled(mp->dely) + mp->tol >= number_to_scaled(stack_min (y_packet (mp->xy))) - number_to_scaled(stack_max (v_packet (mp->uv)))) { + if (number_to_scaled(mp->cur_t) >= number_to_scaled(mp->max_t)) { + if (number_equal(mp->max_t, x_two_t) || number_greater(mp->max_t, x_two_t_low_precision)) { + if (run == 1) { + /* we've done 17+2 bisections, first restore values due bit precision */ + number_divide_int(mp->cur_t,1<<2); + number_divide_int(mp->cur_tt,1<<2); + set_number_from_scaled(mp->cur_t, ((number_to_scaled(mp->cur_t) + 1)/2)); + set_number_from_scaled(mp->cur_tt, ((number_to_scaled(mp->cur_tt) + 1)/2)); +free_number(x_two_t); +free_number(x_two_t_low_precision); + return 1; + } else { + run--; + goto NOT_FOUND; + } + } + number_double(mp->max_t); + number_clone(mp->appr_t, mp->cur_t); + number_clone(mp->appr_tt, mp->cur_tt); + } + @<Subdivide for a new level of intersection@> + goto CONTINUE; + } + } + } + } + if (mp->time_to_go > 0) { + --mp->time_to_go; + } else { + /* we have added 2 bit of precision */ + number_divide_int(mp->appr_t, 1<<2); + number_divide_int(mp->appr_tt, 1<<2); + while (number_less(mp->appr_t, unity_t)) { + number_double(mp->appr_t); + number_double(mp->appr_tt); + } + number_clone(mp->cur_t, mp->appr_t); + number_clone(mp->cur_tt, mp->appr_tt); +free_number(x_two_t); +free_number(x_two_t_low_precision); + return 2; + } + NOT_FOUND: + /* Advance to the next pair |(cur_t,cur_tt)| */ + if (odd(number_to_scaled(mp->cur_tt))) { + // if (number_odd(mp->cur_tt)) { + if (odd(number_to_scaled(mp->cur_t))) { + // if (number_odd(mp->cur_t)) { + /* Descend to the previous level and |goto not_found| */ + set_number_from_scaled(mp->cur_t, half (number_to_scaled(mp->cur_t))); + set_number_from_scaled(mp->cur_tt, half (number_to_scaled(mp->cur_tt))); + if (number_to_scaled(mp->cur_t) == 0) { +free_number(x_two_t); +free_number(x_two_t_low_precision); + return 3; + } else { + mp->bisect_ptr -= int_increment; + mp->three_l -= (int) mp->tol_step; + number_clone(mp->delx, stack_dx); + number_clone(mp->dely, stack_dy); + mp->tol = number_to_scaled(stack_tol); + mp->uv = number_to_scaled(stack_uv); + mp->xy = number_to_scaled(stack_xy); + goto NOT_FOUND; + } + } else { + set_number_from_scaled(mp->cur_t, number_to_scaled(mp->cur_t) + 1); + number_add(mp->delx, stack_1(u_packet (mp->uv))); + number_add(mp->delx, stack_2(u_packet (mp->uv))); + number_add(mp->delx, stack_3(u_packet (mp->uv))); + number_add(mp->dely, stack_1(v_packet (mp->uv))); + number_add(mp->dely, stack_2(v_packet (mp->uv))); + number_add(mp->dely, stack_3(v_packet (mp->uv))); + mp->uv = mp->uv + int_packets; /* switch from |l_packets| to |r_packets| */ + set_number_from_scaled(mp->cur_tt, number_to_scaled(mp->cur_tt) - 1); + mp->xy = mp->xy - int_packets; + number_add(mp->delx, stack_1(x_packet (mp->xy))); + number_add(mp->delx, stack_2(x_packet (mp->xy))); + number_add(mp->delx, stack_3(x_packet (mp->xy))); + number_add(mp->dely, stack_1(y_packet (mp->xy))); + number_add(mp->dely, stack_2(y_packet (mp->xy))); + number_add(mp->dely, stack_3(y_packet (mp->xy))); + } + } else { + set_number_from_scaled(mp->cur_tt, number_to_scaled(mp->cur_tt) + 1); + mp->tol = mp->tol + mp->three_l; + number_subtract(mp->delx, stack_1(x_packet (mp->xy))); + number_subtract(mp->delx, stack_2(x_packet (mp->xy))); + number_subtract(mp->delx, stack_3(x_packet (mp->xy))); + number_subtract(mp->dely, stack_1(y_packet (mp->xy))); + number_subtract(mp->dely, stack_2(y_packet (mp->xy))); + number_subtract(mp->dely, stack_3(y_packet (mp->xy))); + mp->xy = mp->xy + int_packets; /* switch from |l_packets| to |r_packets| */ + } + } +free_number(x_two_t); +free_number(x_two_t_low_precision); +} + +@ The following variables are global, although they are used only by +|cubic_intersection|, because it is necessary on some machines to split +|cubic_intersection| up into two procedures. + +@<Glob...@>= +mp_number delx; +mp_number dely; /* the components of $\Delta=2^l(w_0-z_0)$ */ +int tol; /* bound on the uncertainty in the overlap test */ +int uv; +int xy; /* pointers to the current packets of interest */ +int three_l; /* |tol_step| times the bisection level */ +mp_number appr_t; +mp_number appr_tt; /* best approximations known to the answers */ + +@ @<Initialize table ...@>= +new_number(mp->delx); +new_number(mp->dely); +new_number(mp->appr_t); +new_number(mp->appr_tt); + +@ @<Dealloc...@>= +free_number(mp->delx); +free_number(mp->dely); +free_number(mp->appr_t); +free_number(mp->appr_tt); + +@ We shall assume that the coordinates are sufficiently non-extreme that +integer overflow will not occur. +@^overflow in arithmetic@> + +@<Initialize for intersections at level zero@>= +q = mp_next_knot(p); +qq = mp_next_knot(pp); +mp->bisect_ptr = int_packets; +set_number_from_subtraction(u1r, p->right_x, p->x_coord); +set_number_from_subtraction(u2r, q->left_x, p->right_x); +set_number_from_subtraction(u3r, q->x_coord, q->left_x); +mp_set_min_max(mp, ur_packet); +set_number_from_subtraction(v1r, p->right_y, p->y_coord); +set_number_from_subtraction(v2r, q->left_y, p->right_y); +set_number_from_subtraction(v3r, q->y_coord, q->left_y); +mp_set_min_max(mp, vr_packet); +set_number_from_subtraction(x1r, pp->right_x, pp->x_coord); +set_number_from_subtraction(x2r, qq->left_x, pp->right_x); +set_number_from_subtraction(x3r, qq->x_coord, qq->left_x); +mp_set_min_max(mp, xr_packet); +set_number_from_subtraction(y1r, pp->right_y, pp->y_coord); +set_number_from_subtraction(y2r, qq->left_y, pp->right_y); +set_number_from_subtraction(y3r, qq->y_coord, qq->left_y); +mp_set_min_max(mp, yr_packet); +set_number_from_subtraction(mp->delx, p->x_coord, pp->x_coord); +set_number_from_subtraction(mp->dely, p->y_coord, pp->y_coord); +mp->tol = 0; +mp->uv = r_packets; +mp->xy = r_packets; +mp->three_l = 0; +set_number_from_scaled(mp->cur_t, 1); +set_number_from_scaled(mp->cur_tt, 1); + +@ @<Subdivide for a new level of intersection@>= +number_clone(stack_dx, mp->delx); +number_clone(stack_dy, mp->dely); +set_number_from_scaled(stack_tol, mp->tol); +set_number_from_scaled(stack_uv, mp->uv); +set_number_from_scaled(stack_xy, mp->xy); +mp->bisect_ptr = mp->bisect_ptr + int_increment; +number_double(mp->cur_t); +number_double(mp->cur_tt); +number_clone(u1l, stack_1(u_packet (mp->uv))); +number_clone(u3r, stack_3(u_packet (mp->uv))); +set_number_half_from_addition(u2l, u1l, stack_2(u_packet(mp->uv))); +set_number_half_from_addition(u2r, u3r, stack_2(u_packet(mp->uv))); +set_number_half_from_addition(u3l, u2l, u2r); +number_clone(u1r, u3l); +mp_set_min_max(mp, ul_packet); +mp_set_min_max(mp, ur_packet); +number_clone(v1l, stack_1(v_packet (mp->uv))); +number_clone(v3r, stack_3(v_packet (mp->uv))); +set_number_half_from_addition(v2l, v1l, stack_2(v_packet(mp->uv))); +set_number_half_from_addition(v2r, v3r, stack_2(v_packet(mp->uv))); +set_number_half_from_addition(v3l, v2l, v2r); +number_clone(v1r, v3l); +mp_set_min_max(mp, vl_packet); +mp_set_min_max(mp, vr_packet); +number_clone(x1l, stack_1(x_packet (mp->xy))); +number_clone(x3r, stack_3(x_packet (mp->xy))); +set_number_half_from_addition(x2l, x1l, stack_2(x_packet(mp->xy))); +set_number_half_from_addition(x2r, x3r, stack_2(x_packet(mp->xy))); +set_number_half_from_addition(x3l, x2l, x2r); +number_clone(x1r, x3l); +mp_set_min_max(mp, xl_packet); +mp_set_min_max(mp, xr_packet); +number_clone(y1l, stack_1(y_packet (mp->xy))); +number_clone(y3r, stack_3(y_packet (mp->xy))); +set_number_half_from_addition(y2l, y1l, stack_2(y_packet(mp->xy))); +set_number_half_from_addition(y2r, y3r, stack_2(y_packet(mp->xy))); +set_number_half_from_addition(y3l, y2l, y2r); +number_clone(y1r, y3l); +mp_set_min_max(mp, yl_packet); +mp_set_min_max(mp, yr_packet); +mp->uv = l_packets; +mp->xy = l_packets; +number_double(mp->delx); +number_double(mp->dely); +mp->tol = mp->tol - mp->three_l + (int) mp->tol_step; +mp->tol += mp->tol; +mp->three_l = mp->three_l + (int) mp->tol_step; + +@ The |path_intersection| procedure is much simpler. It invokes +|cubic_intersection| in lexicographic order until finding a pair of cubics that +intersect. The final intersection times are placed in |cur_t| and~|cur_tt|. + +@d intersection_run_shift 8 + +@c +static mp_knot mp_path_intersection_add(MP mp, mp_knot list, mp_knot *last, mp_number *t, mp_number *tt) +{ + int a = number_to_scaled(*t) >> intersection_run_shift; + int aa = number_to_scaled(*tt) >> intersection_run_shift; + int b = (list ? number_to_scaled((*last)->x_coord) : -1) >> intersection_run_shift ; + int bb = (list ? number_to_scaled((*last)->y_coord) : -1) >> intersection_run_shift ; + if (a == b && aa == bb) { + /* ignore */ + } else { + /* todo: just the point as we have it */ + mp_knot k = mp_new_knot(mp); + mp_left_type(k) = mp_explicit_knot; + mp_right_type(k) = mp_explicit_knot; + number_clone(k->x_coord, *t); + number_clone(k->y_coord, *tt); + if (list) { + mp_prev_knot(k) = *last; + mp_next_knot(*last) = k; + mp_prev_knot(list) = k; + mp_next_knot(k) = list; + } else { + list = k; + mp_prev_knot(k) = k; + mp_next_knot(k) = k; + } + *last = k; + } + return list; +} + +@c +static mp_knot mp_path_intersection(MP mp, mp_knot h, mp_knot hh, int path, mp_knot *last) +{ + mp_number n, nn; /* integer parts of intersection times, minus |unity| */ + int done = 0; + mp_knot list = NULL; + mp_knot l = NULL; + mp_knot ll = NULL; + if (last) { + *last = NULL; + } + @<Change one-point paths into dead cycles@> + new_number(n); + new_number(nn); + mp->tol_step = 0; + do { + mp_knot p, pp; /* link registers that traverse the given paths */ + int t = -1; + int tt = -1; + // set_number_to_unity(n); + // number_negate(n); + number_negated_clone(n, unity_t); + p = h; + do { + if (mp_right_type(p) != mp_endpoint_knot) { + // set_number_to_unity(nn); + // number_negate(nn); + number_negated_clone(nn, unity_t); + pp = hh; + do { + if (mp_right_type(pp) != mp_endpoint_knot) { + int run = 0; + int retrials = 0; + RETRY: + ++run; + mp_cubic_intersection(mp, p, pp, run); + if (number_positive(mp->cur_t)) { + number_add(mp->cur_t, n); + number_add(mp->cur_tt, nn); + done = 1; + if (path) { + list = mp_path_intersection_add(mp, list, last, &(mp->cur_t), &(mp->cur_tt)); + if (t == number_to_scaled(mp->cur_t) && tt == number_to_scaled(mp->cur_tt)) { + if (retrials == 8) { /* is 8 okay? */ + break; + } else { + retrials += 1; + goto RETRY; + } + } else { + retrials = 0; + t = number_to_scaled(mp->cur_t); + tt = number_to_scaled(mp->cur_tt); + goto RETRY; + } + } else { + goto DONE; + } + } + } + number_add(nn, unity_t); + ll = pp; + pp = mp_next_knot(pp); + } while (pp != hh); + } + number_add(n, unity_t); + l = p; + p = mp_next_knot(p); + } while (p != h); + mp->tol_step = mp->tol_step + 3; + if (done) { + goto DONE; /* when we do all points */ + } + } while (mp->tol_step <= 3); + DONE: + if (path && l && ll && number_equal(l->x_coord, ll->x_coord) && number_equal(l->y_coord, ll->y_coord)) { + list = mp_path_intersection_add(mp, list, last, &n, &nn); + } + if (! done) { + number_negated_clone(mp->cur_t, unity_t); + number_negated_clone(mp->cur_tt, unity_t); + if (path && ! list) { + mp_knot k = mp_new_knot(mp); + number_clone(k->x_coord, mp->cur_t); + number_clone(k->y_coord, mp->cur_tt); + mp_prev_knot(k) = k; + mp_next_knot(k) = k; + list = k; + if (last) { + *last = k; + } + } + } + free_number(n); + free_number(nn); + return list; +} + +@ @<Change one-point paths...@>= +if (mp_right_type(h) == mp_endpoint_knot) { + number_clone(h->right_x, h->x_coord); + number_clone(h->left_x, h->x_coord); + number_clone(h->right_y, h->y_coord); + number_clone(h->left_y, h->y_coord); + mp_right_type(h) = mp_explicit_knot; +} +if (mp_right_type(hh) == mp_endpoint_knot) { + number_clone(hh->right_x, hh->x_coord); + number_clone(hh->left_x, hh->x_coord); + number_clone(hh->right_y, hh->y_coord); + number_clone(hh->left_y, hh->y_coord); + mp_right_type(hh) = mp_explicit_knot; +} + +@* Dynamic linear equations. + +\MP\ users define variables implicitly by stating equations that should be +satisfied; the computer is supposed to be smart enough to solve those equations. +And indeed, the computer tries valiantly to do so, by distinguishing five +different types of numeric values: + +\smallskip\hang |type(p)=mp_known| is the nice case, when |value(p)| is the +|scaled| value of the variable whose address is~|p|. + +\smallskip\hang |type(p)=mp_dependent| means that |value(p)| is not present, but +|mp_get_dep_list(p)| points to a {\sl dependency list} that expresses the value of +variable~|p| as a |scaled| number plus a sum of independent variables with +|fraction| coefficients. + +\smallskip\hang |type(p)=mp_independent| means that |mp_get_indep_value(p)=s|, where +|s>0| is a \quote {serial number} reflecting the time this variable was first used in +an equation; and there is an extra field |mp_get_indep_scale(p)=m|, with |0<=m<64|, each +dependent variable that refers to this one is actually referring to the future +value of this variable times~$2^m$. (Usually |m=0|, but higher degrees of scaling +are sometimes needed to keep the coefficients in dependency lists from getting +too large. The value of~|m| will always be even.) + +\smallskip\hang |type(p)=mp_numeric_type| means that variable |p| hasn't appeared +in an equation before, but it has been explicitly declared to be numeric. + +\smallskip\hang |type(p)=undefined| means that variable |p| hasn't appeared +before. + +\smallskip\noindent We have actually discussed these five types in the reverse +order of their history during a computation: Once |known|, a variable never again +becomes |dependent|; once |dependent|, it almost never again becomes +|mp_independent|; once |mp_independent|, it never again becomes +|mp_numeric_type|; and once |mp_numeric_type|, it never again becomes |undefined| +(except of course when the user specifically decides to scrap the old value and +start again). A backward step may, however, take place: Sometimes a |dependent| +variable becomes |mp_independent| again, when one of the independent variables it +depends on is reverting to |undefined|. + +@d mp_get_indep_scale(A) ((mp_value_node) (A))->data.indep.scale +@d mp_set_indep_scale(A,B) ((mp_value_node) (A))->data.indep.scale = (B) +@d mp_get_indep_value(A) ((mp_value_node) (A))->data.indep.serial +@d mp_set_indep_value(A,B) ((mp_value_node) (A))->data.indep.serial = (B) + +@c +static void mp_new_indep (MP mp, mp_node p) +{ + (void) mp; + /* create a new independent variable */ + if (mp->serial_no >= max_integer) { + mp_fatal_error(mp, "Variable instance identifiers exhausted"); + } + mp_type(p) = mp_independent_type; + mp->serial_no = mp->serial_no + 1; + mp_set_indep_scale(p, 0); + mp_set_indep_value(p, mp->serial_no); +} + +@ @<Declarations@>= +static void mp_new_indep (MP mp, mp_node p); + +@ @<Glob...@>= +int serial_no; /* the most recent serial number */ + +@ But how are dependency lists represented? It's simple: The linear combination +$\alpha_1v_1+\cdots+\alpha_kv_k+\beta$ appears in |k+1| value nodes. If +|q=mp_get_dep_list(p)| points to this list, and if |k>0|, then |mp_get_dep_value(q)= +@t$\alpha_1$@>| (which is a |fraction|); |mp_get_dep_info(q)| points to the location of +$\alpha_1$; and |mp_link(p)| points to the dependency list +$\alpha_2v_2+\cdots+\alpha_kv_k+\beta$. On the other hand if |k=0|, then +|mp_get_dep_value(q)=@t$\beta$@>| (which is |scaled|) and |mp_get_dep_info(q)=NULL|. The +independent variables $v_1$, \dots,~$v_k$ have been sorted so that they appear in +decreasing order of their |value| fields (i.e., of their serial numbers). \ (It +is convenient to use decreasing order, since |value(NULL)=0|. If the independent +variables were not sorted by serial number but by some other criterion, such as +their location in |mem|, the equation-solving mechanism would be too +system-dependent, because the ordering can affect the computed results.) + +The |link| field in the node that contains the constant term $\beta$ is called +the {\sl final link} of the dependency list. \MP\ maintains a doubly-linked +master list of all dependency lists, in terms of a permanently allocated node in +|mem| called |dep_head|. If there are no dependencies, we have +|mp_link(dep_head)=dep_head| and |mp_get_prev_dep(dep_head)=dep_head|; otherwise +|mp_link(dep_head)| points to the first dependent variable, say~|p|, and +|mp_get_prev_dep(p)=dep_head|. We have |type(p)=mp_dependent|, and |mp_get_dep_list(p)| points +to its dependency list. If the final link of that dependency list occurs in +location~|q|, then |mp_link(q)| points to the next dependent variable (say~|r|); +and we have |mp_get_prev_dep(r)=q|, etc. + +Dependency nodes sometimes mutate into value nodes and vice versa, so their +structures have to match. + +@d mp_get_dep_value(A) ((mp_value_node) (A))->data.n +@d mp_get_dep_list(A) ((mp_value_node) (A))->attr_head /* half of the |value| field in a |dependent| variable */ +@d mp_get_prev_dep(A) ((mp_value_node) (A))->subscr_head /* the other half; makes a doubly linked list */ +@d mp_get_dep_info(A) do_get_dep_info(mp, (A)) + +@d mp_set_dep_value(A,B) do_set_dep_value(mp,(A),&(B)) +@d mp_set_dep_list(A,B) ((mp_value_node) (A))->attr_head = (mp_node) (B) +@d mp_set_prev_dep(A,B) ((mp_value_node) (A))->subscr_head = (mp_node) (B) +@d mp_set_dep_info(A,B) ((mp_value_node) (A))->parent = (mp_node) (B) + +@c +inline static mp_node do_get_dep_info (MP mp, mp_value_node p) +{ + (void) mp; + mp_node d; + d = p->parent; /* half of the |value| field in a |dependent| variable */ + return d; +} + +inline static void do_set_dep_value (MP mp, mp_value_node p, mp_number *q) +{ + number_clone(p->data.n, *q); /* half of the |value| field in a |dependent| variable */ + p->attr_head = NULL; + p->subscr_head = NULL; +} + +@ @<Declarations...@>= +inline static mp_node do_get_dep_info (MP mp, mp_value_node p); +inline static void do_set_dep_value (MP mp, mp_value_node p, mp_number *q); + +@ @c +static mp_value_node mp_get_dep_node (MP mp) +{ + mp_value_node p = (mp_value_node) mp_new_value_node(mp); + mp_type(p) = mp_dep_node_type; + return p; +} + +static void mp_free_dep_node (MP mp, mp_value_node p) +{ + mp_free_value_node(mp, (mp_node) p); +} + +@ @<Declarations...@>= +static void mp_free_dep_node (MP mp, mp_value_node p); + +@ @<Initialize table entries@>= +mp->serial_no = 0; +mp->dep_head = mp_get_dep_node(mp); + +mp_set_link(mp->dep_head, mp->dep_head); +mp_set_prev_dep(mp->dep_head, mp->dep_head); +mp_set_dep_info(mp->dep_head, NULL); +mp_set_dep_list(mp->dep_head, NULL); + +@ @<Free table entries@>= +mp_free_dep_node(mp, mp->dep_head); + +@ Actually the description above contains a little white lie. There's another +kind of variable called |mp_proto_dependent|, which is just like a |dependent| +one except that the $\alpha$ coefficients in its dependency list are |scaled| +instead of being fractions. Proto-dependency lists are mixed with dependency +lists in the nodes reachable from |dep_head|. + +@ Here is a procedure that prints a dependency list in symbolic form. The second +parameter should be either |dependent| or |mp_proto_dependent|, to indicate the +scaling of the coefficients. + +@<Declarations@>= +static void mp_print_dependency (MP mp, mp_value_node p, int t); + +@ @c +void mp_print_dependency (MP mp, mp_value_node p, int t) +{ + mp_number v; /* a coefficient */ + mp_node q; + mp_value_node pp = p; + new_number(v); + while (1) { + number_abs_clone(v, mp_get_dep_value(p)); + q = mp_get_dep_info(p); + if (q == NULL) { + /* the constant term */ + if (number_nonzero(v) || (p == pp)) { + if (number_positive(mp_get_dep_value(p)) && p != pp) { + mp_print_chr(mp, '+'); + } + print_number(mp_get_dep_value(p)); + } + return; + } + /* Print the coefficient, unless it's $\pm1.0$ */ + if (number_negative(mp_get_dep_value(p))) { + mp_print_chr(mp, '-'); + } else if (p != pp) { + mp_print_chr(mp, '+'); + } + if (t == mp_dependent_type) { + fraction_to_round_scaled(v); + } + if (! number_equal(v, unity_t)) { + print_number(v); + } + if (mp_type(q) != mp_independent_type) { + mp_confusion(mp, "dependency"); + } else { + mp_print_variable_name(mp, q); + set_number_from_scaled(v, mp_get_indep_scale(q)); + while (number_positive(v)) { + mp_print_str(mp, "*4"); + number_add_scaled(v, -2); + } + p = (mp_value_node) mp_link(p); + } + } +} + +@ The maximum absolute value of a coefficient in a given dependency list is +returned by the following simple function. + +@c +static void mp_max_coef (MP mp, mp_number *x, mp_value_node p) +{ + mp_number(absv); + new_number(absv); + set_number_to_zero(*x); + while (mp_get_dep_info(p) != NULL) { + number_abs_clone(absv, mp_get_dep_value(p)); + if (number_greater(absv, *x)) { + number_clone(*x, absv); + } + p = (mp_value_node) mp_link(p); + } + free_number(absv); +} + +@ One of the main operations needed on dependency lists is to add a multiple of +one list to the other; we call this |p_plus_fq|, where |p| and~|q| point to +dependency lists and |f| is a fraction. + +If the coefficient of any independent variable becomes |coef_bound| or more, in +absolute value, this procedure changes the type of that variable to +|independent_needing_fix|, and sets the global variable |fix_needed| to~|true|. +The value of $|coef_bound|=\mu$ is chosen so that $\mu^2+\mu<8$; this means that +the numbers we deal with won't get too large. (Instead of the \quote {optimum} +$\mu=(\sqrt{33}-1)/2\approx 2.3723$, the safer value 7/3 is taken as the +threshold.) + +The changes mentioned in the preceding paragraph are actually done only if the +global variable |watch_coefs| is |true|. But it usually is; in fact, it is +|false| only when \MP\ is making a dependency list that will soon be equated to +zero. + +Several procedures that act on dependency lists, including |p_plus_fq|, set the +global variable |dep_final| to the final (constant term) node of the dependency +list that they produce. + +@d independent_needing_fix 0 + +@<Glob...@>= +int fix_needed; /* does at least one |independent| variable need scaling? */ +int watch_coefs; /* should we scale coefficients that exceed |coef_bound|? */ +mp_value_node dep_final; /* location of the constant term and final link */ + +@ @<Set init...@>= +mp->fix_needed = 0; +mp->watch_coefs = 1; + +@ The |p_plus_fq| procedure has a fourth parameter, |t|, that should be set to +|mp_proto_dependent| if |p| is a proto-dependency list. In this case |f| will be +|scaled|, not a |fraction|. Similarly, the fifth parameter~|tt| should be +|mp_proto_dependent| if |q| is a proto-dependency list. + +List |q| is unchanged by the operation; but list |p| is totally destroyed. + +The final link of the dependency list or proto-dependency list returned by +|p_plus_fq| is the same as the original final link of~|p|. Indeed, the constant +term of the result will be located in the same |mem| location as the original +constant term of~|p|. + +Coefficients of the result are assumed to be zero if they are less than a certain +threshold. This compensates for inevitable rounding errors, and tends to make +more variables |known|. The threshold is approximately $10^{-5}$ in the case of +normal dependency lists, $10^{-4}$ for proto-dependencies. + +@d fraction_threshold_k mp->math->md_fraction_threshold_t +@d half_fraction_threshold_k mp->math->md_half_fraction_threshold_t +@d scaled_threshold_k mp->math->md_scaled_threshold_t +@d half_scaled_threshold_k mp->math->md_half_scaled_threshold_t + +@<Declarations@>= +static mp_value_node mp_p_plus_fq (MP mp, mp_value_node p, mp_number *f, mp_value_node q, mp_variable_type t, mp_variable_type tt); + +@ @c +static mp_value_node mp_p_plus_fq (MP mp, + mp_value_node p, mp_number *f, + mp_value_node q, mp_variable_type t, + mp_variable_type tt +) +{ + mp_node pp, qq; /* |mp_get_dep_info(p)| and |mp_get_dep_info(q)|, respectively */ + mp_value_node r, s; /* for list manipulation */ + mp_number threshold; /* defines a neighborhood of zero */ + mp_number half_threshold; + mp_number v, vv; /* temporary registers */ + new_number(v); + new_number(vv); + if (t == mp_dependent_type) { + new_number_clone(threshold, fraction_threshold_k); + new_number_clone(half_threshold, half_fraction_threshold_k); + } else { + new_number_clone(threshold, scaled_threshold_k); + new_number_clone(half_threshold, half_scaled_threshold_k); + } + r = (mp_value_node) mp->temp_head; + pp = mp_get_dep_info(p); + qq = mp_get_dep_info(q); + while (1) { + if (pp == qq) { + if (pp == NULL) { + break; + } else { + /* + Contribute a term from |p|, plus |f| times the corresponding + term from |q| + */ + mp_number r1; + mp_number absv; + new_fraction(r1); + new_number(absv); + if (tt == mp_dependent_type) { + take_fraction(r1, *f, mp_get_dep_value(q)); + } else { + take_scaled(r1, *f, mp_get_dep_value(q)); + } + set_number_from_addition(v, mp_get_dep_value(p), r1); + free_number(r1); + mp_set_dep_value(p, v); + s = p; + p = (mp_value_node) mp_link(p); + number_abs_clone(absv, v); + if (number_less(absv, threshold)) { + mp_free_dep_node(mp, s); + } else { + if (number_greaterequal(absv, coef_bound_k) && mp->watch_coefs) { + mp_type(qq) = independent_needing_fix; + /* + If we set this , then we can drop |(mp_type(pp) == + independent_needing_fix && mp->fix_needed)| later + |set_number_from_scaled(mp_get_value_number(qq), + mp_get_indep_value(qq));| + */ + mp->fix_needed = 1; + } + mp_set_link(r, s); + r = s; + } + free_number(absv); + pp = mp_get_dep_info(p); + q = (mp_value_node) mp_link(q); + qq = mp_get_dep_info(q); + } + } else { + if (pp == NULL) { + set_number_to_negative_inf(v); + } else if (mp_type(pp) == mp_independent_type || (mp_type(pp) == independent_needing_fix && mp->fix_needed)) { + set_number_from_scaled(v, mp_get_indep_value(pp)); + } else { + number_clone(v, mp_get_value_number(pp)); + } + if (qq == NULL) { + set_number_to_negative_inf(vv); + } else if (mp_type(qq) == mp_independent_type || (mp_type(qq) == independent_needing_fix && mp->fix_needed)) { + set_number_from_scaled(vv, mp_get_indep_value(qq)); + } else { + number_clone(vv, mp_get_value_number(qq)); + } + if (number_less(v, vv)) { + /* Contribute a term from |q|, multiplied by~|f| */ + mp_number absv; + { + mp_number r1; + mp_number arg1, arg2; + new_fraction(r1); + new_number_clone(arg1, *f); + new_number_clone(arg2, mp_get_dep_value(q)); + if (tt == mp_dependent_type) { + take_fraction(r1, arg1, arg2); + } else { + take_scaled(r1, arg1, arg2); + } + number_clone(v, r1); + free_number(r1); + free_number(arg1); + free_number(arg2); + } + new_number_abs(absv, v); + if (number_greater(absv, half_threshold)) { + s = mp_get_dep_node(mp); + mp_set_dep_info(s, qq); + mp_set_dep_value(s, v); + if (number_greaterequal(absv, coef_bound_k) && mp->watch_coefs) { + mp_type(qq) = independent_needing_fix; + mp->fix_needed = 1; + } + mp_set_link(r, s); + r = s; + } + q = (mp_value_node) mp_link(q); + qq = mp_get_dep_info(q); + free_number(absv); + } else { + mp_set_link(r, p); + r = p; + p = (mp_value_node) mp_link(p); + pp = mp_get_dep_info(p); + } + } + } + { + mp_number r1; + mp_number arg1, arg2; + new_fraction(r1); + new_number(arg1); + new_number(arg2); + number_clone(arg1, mp_get_dep_value(q)); + number_clone(arg2, *f); + if (t == mp_dependent_type) { + take_fraction(r1, arg1, arg2); + } else { + take_scaled(r1, arg1, arg2); + } + slow_add(arg1, mp_get_dep_value(p), r1); + mp_set_dep_value(p, arg1); + free_number(r1); + free_number(arg1); + free_number(arg2); + } + mp_set_link(r, p); + mp->dep_final = p; + free_number(threshold); + free_number(half_threshold); + free_number(v); + free_number(vv); + return (mp_value_node) mp_link(mp->temp_head); +} + +@ It is convenient to have another subroutine for the special case of |p_plus_fq| +when |f=1.0|. In this routine lists |p| and |q| are both of the same type~|t| +(either |dependent| or |mp_proto_dependent|). + +@c +static mp_value_node mp_p_plus_q (MP mp, mp_value_node p, mp_value_node q, mp_variable_type t) +{ + mp_node pp, qq; /* |mp_get_dep_info(p)| and |mp_get_dep_info(q)|, respectively */ + mp_value_node s; /* for list manipulation */ + mp_value_node r; /* for list manipulation */ + mp_number threshold; /* defines a neighborhood of zero */ + mp_number v, vv; /* temporary register */ + new_number(v); + new_number(vv); + new_number(threshold); + if (t == mp_dependent_type) { + number_clone(threshold, fraction_threshold_k); + } else { + number_clone(threshold, scaled_threshold_k); + } + r = (mp_value_node) mp->temp_head; + pp = mp_get_dep_info(p); + qq = mp_get_dep_info(q); + while (1) { + if (pp == qq) { + if (pp == NULL) { + break; + } else { + /* Contribute a term from |p|, plus the corresponding term from |q| */ + mp_number test; + new_number(test); + set_number_from_addition(v, mp_get_dep_value(p), mp_get_dep_value(q)); + mp_set_dep_value(p, v); + s = p; + p = (mp_value_node) mp_link(p); + pp = mp_get_dep_info(p); + number_abs_clone(test, v); + if (number_less(test, threshold)) { + mp_free_dep_node(mp, s); + } else { + if (number_greaterequal(test, coef_bound_k) && mp->watch_coefs) { + mp_type(qq) = independent_needing_fix; + /* + If we set this , then we can drop |(mp_type(pp) == + independent_needing_fix && mp->fix_needed)| later + |set_number_from_scaled(mp_get_value_number(qq), + mp_get_indep_value(qq));| + */ + mp->fix_needed = 1; + } + mp_set_link(r, s); + r = s; + } + free_number(test); + q = (mp_value_node) mp_link(q); + qq = mp_get_dep_info(q); + } + + } else { + if (pp == NULL) { + set_number_to_zero(v); + } else if (mp_type(pp) == mp_independent_type || (mp_type(pp) == independent_needing_fix && mp->fix_needed)) { + set_number_from_scaled(v, mp_get_indep_value(pp)); + } else { + number_clone(v, mp_get_value_number(pp)); + } + if (qq == NULL) { + set_number_to_zero(vv); + } else if (mp_type(qq) == mp_independent_type || (mp_type(qq) == independent_needing_fix && mp->fix_needed)) { + set_number_from_scaled(vv, mp_get_indep_value(qq)); + } else { + number_clone(vv, mp_get_value_number(qq)); + } + if (number_less(v, vv)) { + s = mp_get_dep_node(mp); + mp_set_dep_info(s, qq); + mp_set_dep_value(s, mp_get_dep_value(q)); + q = (mp_value_node) mp_link(q); + qq = mp_get_dep_info(q); + mp_set_link(r, s); + r = s; + } else { + mp_set_link(r, p); + r = p; + p = (mp_value_node) mp_link(p); + pp = mp_get_dep_info(p); + } + } + } + { + mp_number r1; + new_number(r1); + slow_add(r1, mp_get_dep_value(p), mp_get_dep_value(q)); + mp_set_dep_value(p, r1); + free_number(r1); + } + mp_set_link(r, p); + mp->dep_final = p; + free_number(v); + free_number(vv); + free_number(threshold); + return (mp_value_node) mp_link(mp->temp_head); +} + +@ A somewhat simpler routine will multiply a dependency list by a given +constant~|v|. The constant is either a |fraction| less than |fraction_one|, or it +is |scaled|. In the latter case we might be forced to convert a dependency list +to a proto-dependency list. Parameters |t0| and |t1| are the list types before +and after; they should agree unless |t0=mp_dependent| and |t1=mp_proto_dependent| +and |v_is_scaled=true|. + +@c +static mp_value_node mp_p_times_v (MP mp, mp_value_node p, mp_number *v, int t0, int t1, int v_is_scaled) +{ + mp_value_node r, s; /* for list manipulation */ + mp_number w; /* tentative coefficient */ + mp_number threshold; + int scaling_down = (t0 != t1) ? 1 : (! v_is_scaled); + new_number(threshold); + new_number(w); + if (t1 == mp_dependent_type) { + number_clone(threshold, half_fraction_threshold_k); + } else { + number_clone(threshold, half_scaled_threshold_k); + } + r = (mp_value_node) mp->temp_head; + while (mp_get_dep_info(p) != NULL) { + mp_number test; + new_number(test); + if (scaling_down) { + take_fraction(w, *v, mp_get_dep_value(p)); + } else { + take_scaled(w, *v, mp_get_dep_value(p)); + } + number_abs_clone(test, w); + if (number_lessequal(test, threshold)) { + s = (mp_value_node) mp_link(p); + mp_free_dep_node(mp, p); + p = s; + } else { + if (number_greaterequal(test, coef_bound_k)) { + mp->fix_needed = 1; + mp_type(mp_get_dep_info(p)) = independent_needing_fix; + } + mp_set_link(r, p); + r = p; + mp_set_dep_value(p, w); + p = (mp_value_node) mp_link(p); + } + free_number(test); + } + mp_set_link(r, p); + { + mp_number r1; + new_number(r1); + if (v_is_scaled) { + take_scaled(r1, mp_get_dep_value(p), *v); + } else { + take_fraction(r1, mp_get_dep_value(p), *v); + } + mp_set_dep_value(p, r1); + free_number(r1); + } + free_number(w); + free_number(threshold); + return (mp_value_node) mp_link(mp->temp_head); +} + +@ Similarly, we sometimes need to divide a dependency list by a given |scaled| +constant. + +@<Declarations@>= +static mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number *v, int t0, int t1); + +@ @d p_over_v_threshold_k mp->math->md_p_over_v_threshold_t + +@ @c +mp_value_node mp_p_over_v (MP mp, mp_value_node p, mp_number *v_orig, int t0, int t1) +{ + mp_value_node r, s; /* for list manipulation */ + mp_number w; /* tentative coefficient */ + mp_number threshold; + mp_number v; + int scaling_down = (t0 != t1); + new_number(w); + new_number(threshold); + new_number_clone(v, *v_orig); + if (t1 == mp_dependent_type) { + number_clone(threshold, half_fraction_threshold_k); + } else { + number_clone(threshold, half_scaled_threshold_k); + } + r = (mp_value_node) mp->temp_head; + while (mp_get_dep_info(p) != NULL) { + if (scaling_down) { + mp_number x, absv; + new_number_abs(absv, v); + if (number_less(absv, p_over_v_threshold_k)) { + new_number_clone(x, v); + convert_scaled_to_fraction(x); + make_scaled(w, mp_get_dep_value(p), x); + } else { + new_number_clone(x, mp_get_dep_value(p)); + fraction_to_round_scaled(x); + make_scaled(w, x, v); + } + free_number(x); + free_number(absv); + } else { + make_scaled(w, mp_get_dep_value(p), v); + } + { + mp_number test; + new_number(test); + number_abs_clone(test, w); + if (number_lessequal(test, threshold)) { + s = (mp_value_node) mp_link(p); + mp_free_dep_node(mp, p); + p = s; + } else { + if (number_greaterequal(test, coef_bound_k)) { + mp->fix_needed = 1; + mp_type(mp_get_dep_info(p)) = independent_needing_fix; + } + mp_set_link(r, p); + r = p; + mp_set_dep_value(p, w); + p = (mp_value_node) mp_link(p); + } + free_number(test); + } + } + mp_set_link(r, p); + { + mp_number ret; + new_number(ret); + make_scaled(ret, mp_get_dep_value(p), v); + mp_set_dep_value(p, ret); + free_number(ret); + } + free_number(v); + free_number(w); + free_number(threshold); + return (mp_value_node) mp_link(mp->temp_head); +} + +@ Here's another utility routine for dependency lists. When an independent +variable becomes dependent, we want to remove it from all existing dependencies. +The |p_with_x_becoming_q| function computes the dependency list of~|p| after +variable~|x| has been replaced by~|q|. + +This procedure has basically the same calling conventions as |p_plus_fq|: +List~|q| is unchanged; list~|p| is destroyed; the constant node and the final +link are inherited from~|p|; and the fourth parameter tells whether or not |p| is +|mp_proto_dependent|. However, the global variable |dep_final| is not altered if +|x| does not occur in list~|p|. + +@c +static mp_value_node mp_p_with_x_becoming_q (MP mp, mp_value_node p, mp_node x, mp_node q, int t) +{ + mp_value_node s = p; + mp_value_node r = (mp_value_node) mp->temp_head; + int sx = mp_get_indep_value(x); /* serial number of |x| */ + while (mp_get_dep_info(s) != NULL && mp_get_indep_value(mp_get_dep_info(s)) > sx) { + r = s; + s = (mp_value_node) mp_link(s); + } + if (mp_get_dep_info(s) == NULL || mp_get_dep_info(s) != x) { + return p; + } else { + mp_value_node ret; + mp_number v1; + mp_set_link(mp->temp_head, p); + mp_set_link(r, mp_link(s)); + new_number_clone(v1, mp_get_dep_value(s)); + mp_free_dep_node(mp, s); + ret = mp_p_plus_fq(mp, (mp_value_node) mp_link(mp->temp_head), &v1, (mp_value_node) q, t, mp_dependent_type); + free_number(v1); + return ret; + } +} + +@ Here's a simple procedure that reports an error when a variable has just +received a known value that's out of the required range. + +@<Declarations@>= +static void mp_val_too_big (MP mp, mp_number *x); + +@ @c +static void mp_val_too_big (MP mp, mp_number *x) +{ + if (number_positive(internal_value(mp_warning_check_internal))) { + char msg[256]; + mp_snprintf(msg, 256, "Value is too large (%s)", number_tostring(*x)); + mp_error( + mp, + msg, + "The equation I just processed has given some variable a value outside of the\n" + "safetyp range. Continue and I'll try to cope with that big value; but it might be\n" + "dangerous. (Set 'warningcheck := 0' to suppress this message.)" + ); + } +} + +@ When a dependent variable becomes known, the following routine removes its +dependency list. Here |p| points to the variable, and |q| points to the +dependency list (which is one node long). + +@<Declarations@>= +static void mp_make_known (MP mp, mp_value_node p, mp_value_node q); + +@ @c +void mp_make_known (MP mp, mp_value_node p, mp_value_node q) +{ + mp_variable_type t = mp_type(p); /* the previous type */ + mp_number absp; + new_number(absp); + mp_set_prev_dep(mp_link(q), mp_get_prev_dep(p)); + mp_set_link(mp_get_prev_dep(p), mp_link(q)); + mp_type(p) = mp_known_type; + mp_set_value_number(p, mp_get_dep_value(q)); + mp_free_dep_node(mp, q); + number_abs_clone(absp, mp_get_value_number(p)); + if (number_greaterequal(absp, warning_limit_t)) { + mp_val_too_big (mp, &(mp_get_value_number(p))); + } + if ((number_positive(internal_value(mp_tracing_equations_internal))) && mp_interesting(mp, (mp_node) p)) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, "#### "); + mp_print_variable_name(mp, (mp_node) p); + mp_print_chr(mp, '='); + print_number(mp_get_value_number(p)); + mp_end_diagnostic(mp, 0); + } + if (cur_exp_node == (mp_node) p && mp->cur_exp.type == t) { + mp->cur_exp.type = mp_known_type; + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(p))); + mp_free_value_node(mp, (mp_node) p); + } + free_number(absp); +} + +@ The |fix_dependencies| routine is called into action when |fix_needed| +has been triggered. The program keeps a list~|s| of independent variables +whose coefficients must be divided by~4. + +In unusual cases, this fixup process might reduce one or more coefficients +to zero, so that a variable will become known more or less by default. + +@<Declarations@>= +static void mp_fix_dependencies (MP mp); + +@ @d independent_being_fixed 1 /* this variable already appears in |s| */ + +@ @c +static void mp_fix_dependencies (MP mp) +{ + mp_value_node r = (mp_value_node) mp_link(mp->dep_head); + mp_value_node s = NULL; + while (r != mp->dep_head) { + /* + Run through the dependency list for variable |t|, fixing all nodes, + and ending with final link~|q| + */ + mp_value_node t = r; + mp_value_node q; + while (1) { + mp_node x; + if (t == r) { + q = (mp_value_node) mp_get_dep_list(t); + } else { + q = (mp_value_node) mp_link(r); + } + x = mp_get_dep_info(q); + if (x == NULL) { + break; + } else if (mp_type(x) <= independent_being_fixed) { + if (mp_type(x) < independent_being_fixed) { + mp_value_node p = mp_get_dep_node(mp); + mp_set_link(p, s); + s = p; + mp_set_dep_info(s, x); + mp_type(x) = independent_being_fixed; + } + mp_set_dep_value(q, mp_get_dep_value(q)); + number_divide_int(mp_get_dep_value(q), 4); + if (number_zero(mp_get_dep_value(q))) { + mp_set_link(r, mp_link(q)); + mp_free_dep_node(mp, q); + q = r; + } + } + r = q; + } + r = (mp_value_node) mp_link(q); + if (q == (mp_value_node) mp_get_dep_list(t)) { + mp_make_known(mp, t, q); + } + } + while (s != NULL) { + mp_value_node p = (mp_value_node) mp_link(s); + mp_node x = mp_get_dep_info(s); + mp_free_dep_node(mp, s); + s = p; + mp_type(x) = mp_independent_type; + mp_set_indep_scale(x, mp_get_indep_scale(x) + 2); + } + mp->fix_needed = 0; +} + +@ The |new_dep| routine installs a dependency list~|p| based on the value +node~|q|, linking it into the list of all known dependencies. It replaces |q| +with the new dependency node. We assume that |dep_final| points to the final node +of list~|p|. + +@c +static void mp_new_dep (MP mp, mp_node q, mp_variable_type newtype, mp_value_node p) +{ + mp_node r; /* what used to be the first dependency */ + mp_type(q) = newtype; + mp_set_dep_list(q, p); + mp_set_prev_dep(q, (mp_node) mp->dep_head); + r = mp_link(mp->dep_head); + mp_set_link(mp->dep_final, r); + mp_set_prev_dep(r, (mp_node) mp->dep_final); + mp_set_link(mp->dep_head, q); +} + +@ Here is one of the ways a dependency list gets started. +The |const_dependency| routine produces a list that has nothing but +a constant term. + +@c +static mp_value_node mp_const_dependency (MP mp, mp_number *v) +{ + mp->dep_final = mp_get_dep_node(mp); + mp_set_dep_value(mp->dep_final, *v); + mp_set_dep_info(mp->dep_final, NULL); + return mp->dep_final; +} + +@ And here's a more interesting way to start a dependency list from scratch: The +parameter to |single_dependency| is the location of an independent variable~|x|, +and the result is the simple dependency list |x+0|. + +In the unlikely event that the given independent variable has been doubled so +often that we can't refer to it with a nonzero coefficient, |single_dependency| +returns the simple list `0'. This case can be recognized by testing that the +returned list pointer is equal to |dep_final|. + +@d two_to_the(A) (1<<(unsigned)(A)) + +@ @c +static mp_value_node mp_single_dependency (MP mp, mp_node p) +{ + mp_value_node q; /* the new dependency list */ + int m = mp_get_indep_scale(p); /* the number of doublings */ + if (m > 28) { + q = mp_const_dependency(mp, &zero_t); + } else { + mp_value_node rr; + q = mp_get_dep_node(mp); + mp_set_dep_value(q, zero_t); + set_number_from_scaled(mp_get_dep_value(q), (int) two_to_the(28 - m)); + mp_set_dep_info(q, p); + rr = mp_const_dependency(mp, &zero_t); + mp_set_link(q, rr); + } + return q; +} + +@ We sometimes need to make an exact copy of a dependency list. + +@c +static mp_value_node mp_copy_dep_list (MP mp, mp_value_node p) +{ + mp_value_node q = mp_get_dep_node(mp); /* the new dependency list */ + mp->dep_final = q; + while (1) { + mp_set_dep_info(mp->dep_final, mp_get_dep_info(p)); + mp_set_dep_value(mp->dep_final, mp_get_dep_value(p)); + if (mp_get_dep_info(mp->dep_final) == NULL) { + break; + } else { + mp_set_link(mp->dep_final, mp_get_dep_node(mp)); + mp->dep_final = (mp_value_node) mp_link(mp->dep_final); + p = (mp_value_node) mp_link(p); + } + } + return q; +} + +@ But how do variables normally become known? Ah, now we get to the heart of the +equation-solving mechanism. The |linear_eq| procedure is given a |dependent| or +|mp_proto_dependent| list,~|p|, in which at least one independent variable +appears. It equates this list to zero, by choosing an independent variable with +the largest coefficient and making it dependent on the others. The newly +dependent variable is eliminated from all current dependencies, thereby possibly +making other dependent variables known. + +The given list |p| is, of course, totally destroyed by all this processing. + +@c +static mp_value_node find_node_with_largest_coefficient (MP mp, mp_value_node p, mp_number *v); + +static void display_new_dependency (MP mp, mp_value_node p, mp_node x, int n); + +static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, int n); + +static mp_value_node divide_p_by_minusv_removing_q (MP mp, + mp_value_node p, mp_value_node q, + mp_value_node *final_node, mp_number *v, int t +); + +static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, int n); + +static void mp_linear_eq (MP mp, mp_value_node p, int t) +{ + mp_value_node r; /* for link manipulation */ + mp_node x; /* the variable that loses its independence */ + int n; /* the number of times |x| had been halved */ + mp_number v; /* the coefficient of |x| in list |p| */ + mp_value_node prev_r; /* lags one step behind |r| */ + mp_value_node final_node; /* the constant term of the new dependency list */ + mp_value_node qq; + new_number(v); + qq = find_node_with_largest_coefficient(mp, p, &v); + x = mp_get_dep_info(qq); + n = mp_get_indep_scale(x); + p = divide_p_by_minusv_removing_q(mp, p, qq, &final_node, &v, t); + if (number_positive(internal_value(mp_tracing_equations_internal))) { + display_new_dependency(mp, p, (mp_node) x, n); + } + prev_r = (mp_value_node) mp->dep_head; + r = (mp_value_node) mp_link(mp->dep_head); + while (r != mp->dep_head) { + mp_value_node s = (mp_value_node) mp_get_dep_list(r); + mp_value_node q = mp_p_with_x_becoming_q(mp, s, x, (mp_node) p, mp_type(r)); + if (mp_get_dep_info(q) == NULL) { + mp_make_known(mp, r, q); + } else { + mp_set_dep_list(r, q); + do { + q = (mp_value_node) mp_link(q); + } while (mp_get_dep_info(q) != NULL); + prev_r = q; + } + r = (mp_value_node) mp_link(prev_r); + } + if (n > 0) { + p = divide_p_by_2_n(mp, p, n); + } + change_to_known(mp, p, (mp_node) x, final_node, n); + if (mp->fix_needed) { + mp_fix_dependencies(mp); + } + free_number(v); +} + +@ @c +static mp_value_node find_node_with_largest_coefficient (MP mp, mp_value_node p, mp_number *v) +{ + mp_number vabs; /* its absolute value of v*/ + mp_number rabs; /* the absolute value of |mp_get_dep_value(r)| */ + mp_value_node q = p; + mp_value_node r = (mp_value_node) mp_link(p); + new_number(vabs); + new_number(rabs); + number_clone(*v, mp_get_dep_value(q)); + while (mp_get_dep_info(r) != NULL) { + number_abs_clone(vabs, *v); + number_abs_clone(rabs, mp_get_dep_value(r)); + if (number_greater(rabs, vabs)) { + q = r; + number_clone(*v, mp_get_dep_value(r)); + } + r = (mp_value_node) mp_link(r); + } + free_number(vabs); + free_number(rabs); + return q; +} + +@ Here we want to change the coefficients from |scaled| to |fraction|, except in +the constant term. In the common case of a trivial equation like |x=3.14|, we +will have |v=-fraction_one|, |q=p|, and |t=mp_dependent|. + +@c +static mp_value_node divide_p_by_minusv_removing_q (MP mp, + mp_value_node p, mp_value_node q, + mp_value_node *final_node, mp_number *v, int t +) +{ + mp_value_node r = p; /* for link manipulation */ + mp_value_node s = (mp_value_node) mp->temp_head; + mp_set_link(s, p); + do { + if (r == q) { + mp_set_link(s, mp_link(r)); + mp_free_dep_node(mp, r); + } else { + mp_number w; /* a tentative coefficient */ + mp_number absw; + new_number(w); + new_number(absw); + make_fraction(w, mp_get_dep_value(r), *v); + number_abs_clone(absw, w); + if (number_lessequal(absw, half_fraction_threshold_k)) { + mp_set_link(s, mp_link(r)); + mp_free_dep_node(mp, r); + } else { + number_negate(w); + mp_set_dep_value(r, w); + s = r; + } + free_number(w); + free_number(absw); + } + r = (mp_value_node) mp_link(s); + } while (mp_get_dep_info(r) != NULL); + if (t == mp_proto_dependent_type) { + mp_number ret; + new_number(ret); + make_scaled(ret, mp_get_dep_value(r), *v); + number_negate(ret); + mp_set_dep_value(r, ret); + free_number(ret); + } else if (number_to_scaled(*v) != -number_to_scaled(fraction_one_t)) { + mp_number ret; + new_fraction(ret); + make_fraction(ret, mp_get_dep_value(r), *v); + number_negate(ret); + mp_set_dep_value(r, ret); + free_number(ret); + } + *final_node = r; + return (mp_value_node) mp_link(mp->temp_head); +} + +@ @c +static void display_new_dependency (MP mp, mp_value_node p, mp_node x, int n) +{ + if (mp_interesting(mp, x)) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, "## "); + mp_print_variable_name(mp, x); + while (n > 0) { + mp_print_str(mp, "*4"); + n = n - 2; + } + mp_print_chr(mp, '='); + mp_print_dependency(mp, p, mp_dependent_type); + mp_end_diagnostic(mp, 0); + } +} + +@ The |n > 0| test is repeated here because it is of vital importance to the +function's functioning. + +@c +static mp_value_node divide_p_by_2_n (MP mp, mp_value_node p, int n) +{ + mp_value_node pp = NULL; + if (n > 0) { + /* Divide list |p| by $2^n$ */ + mp_value_node r; + mp_value_node s; + mp_number absw; + mp_number w; /* a tentative coefficient */ + new_number(w); + new_number(absw); + s = (mp_value_node) mp->temp_head; + mp_set_link(mp->temp_head, p); + r = p; + do { + if (n > 30) { + set_number_to_zero(w); + } else { + number_clone(w, mp_get_dep_value(r)); + number_divide_int(w, two_to_the(n)); + } + number_abs_clone(absw, w); + if (number_lessequal(absw, half_fraction_threshold_k) && (mp_get_dep_info(r) != NULL)) { + mp_set_link(s, mp_link(r)); + mp_free_dep_node(mp, r); + } else { + mp_set_dep_value(r, w); + s = r; + } + r = (mp_value_node) mp_link(s); + } while (mp_get_dep_info(s) != NULL); + pp = (mp_value_node) mp_link(mp->temp_head); + free_number(absw); + free_number(w); + } + return pp; +} + +@ @c +static void change_to_known (MP mp, mp_value_node p, mp_node x, mp_value_node final_node, int n) +{ + (void) n; + if (mp_get_dep_info(p) == NULL) { + mp_number absx; + mp_type(x) = mp_known_type; + mp_set_value_number(x, mp_get_dep_value(p)); + new_number_abs(absx, mp_get_value_number(x)); + if (number_greaterequal(absx, warning_limit_t)) { + mp_val_too_big(mp, &(mp_get_value_number(x))); + } + free_number(absx); + mp_free_dep_node(mp, p); + if (cur_exp_node == x && mp->cur_exp.type == mp_independent_type) { + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(x))); + mp->cur_exp.type = mp_known_type; + mp_free_value_node(mp, x); + } + } else { + mp->dep_final = final_node; + mp_new_dep(mp, x, mp_dependent_type, p); + if (cur_exp_node == x && mp->cur_exp.type == mp_independent_type) { + mp->cur_exp.type = mp_dependent_type; + } + } +} + +@* Dynamic nonlinear equations. + +Variables of numeric type are maintained by the general scheme of independent, +dependent, and known values that we have just studied; and the components of pair +and transform variables are handled in the same way. But \MP\ also has five other +types of values: |boolean|, |string|, |pen|, |path|, and |picture|; +what about them? + +Equations are allowed between nonlinear quantities, but only in a simple form. +Two variables that haven't yet been assigned values are either equal to each +other, or they're not. + +Before a boolean variable has received a value, its type is |mp_unknown_boolean|; +similarly, there are variables whose type is |mp_unknown_string|, +|mp_unknown_pen|, |mp_unknown_path|, and |mp_unknown_picture|. In such cases the +value is either |NULL| (which means that no other variables are equivalent to +this one), or it points to another variable of the same undefined type. The +pointers in the latter case form a cycle of nodes, which we shall call a +\quote {ring.} Rings of undefined variables may include capsules, which arise as +intermediate results within expressions or as |expr| parameters to macros. + +When one member of a ring receives a value, the same value is given to all the +other members. In the case of paths and pictures, this implies making separate +copies of a potentially large data structure; users should restrain their +enthusiasm for such generality, unless they have lots and lots of memory space. + +@ The following procedure is called when a capsule node is being added to a ring +(e.g., when an unknown variable is mentioned in an expression). + +@c +static mp_node mp_new_ring_entry (MP mp, mp_node p) +{ + mp_node q = mp_new_value_node(mp); /* the new capsule node */ + mp_name_type(q) = mp_capsule_operation; + mp_type(q) = mp_type(p); + if (mp_get_value_node(p) == NULL) { + mp_set_value_node(q, p); + } else { + mp_set_value_node(q, mp_get_value_node(p)); + } + mp_set_value_node(p, q); + return q; +} + +@ Conversely, we might delete a capsule or a variable before it becomes known. +The following procedure simply detaches a quantity from its ring, without +recycling the storage. + +@<Declarations@>= +static void mp_ring_delete (MP mp, mp_node p); + +@ @c +void mp_ring_delete (MP mp, mp_node p) +{ + (void) mp; + mp_node q = mp_get_value_node(p); + if (q != NULL && q != p) { + while (mp_get_value_node(q) != p) { + q = mp_get_value_node(q); + } + mp_set_value_node(q, mp_get_value_node(p)); + } +} + +@ Eventually there might be an equation that assigns values to all of the +variables in a ring. The |nonlinear_eq| subroutine does the necessary propagation +of values. + +If the parameter |flush_p| is |true|, node |p| itself needn't receive a value, it +will soon be recycled. + +@c +static void mp_nonlinear_eq (MP mp, mp_value v, mp_node p, int flush_p) +{ + mp_variable_type t = mp_type(p) - unknown_tag; /* the type of ring |p| */ + mp_node q = mp_get_value_node(p); + if (flush_p) { + mp_type(p) = mp_vacuous_type; + } else { + p = q; + } + do { + mp_node r = mp_get_value_node(q); + mp_type(q) = t; + switch (t) { + case mp_boolean_type: + mp_set_value_number(q, v.data.n); + break; + case mp_string_type: + mp_set_value_str(q, v.data.str); + add_str_ref(v.data.str); + break; + case mp_pen_type: + case mp_nep_type: + mp_set_value_knot(q, mp_copy_pen(mp, v.data.p)); + break; + case mp_path_type: + mp_set_value_knot(q, mp_copy_path(mp, v.data.p)); + break; + case mp_picture_type: + mp_set_value_node(q, v.data.node); + mp_add_edge_ref(mp, v.data.node); + break; + default: + break; + } + /* there ain't no more cases */ + q = r; + } while (q != p); +} + +@ If two members of rings are equated, and if they have the same type, the +|ring_merge| procedure is called on to make them equivalent. + +@c +static void mp_ring_merge (MP mp, mp_node p, mp_node q) +{ + mp_node r = mp_get_value_node(p); /* traverses one list */ + while (r != p) { + if (r == q) { + mp_exclaim_redundant_equation(mp); + return; + } else { + r = mp_get_value_node(r); + } + } + r = mp_get_value_node(p); + mp_set_value_node(p, mp_get_value_node(q)); + mp_set_value_node(q, r); +} + +@ @c +static void mp_exclaim_redundant_equation (MP mp) +{ + mp_back_error( + mp, + "Redundant equation", + "I already knew that this equation was true. But perhaps no harm has been done;\n" + "let's continue." + ); + mp_get_x_next(mp); +} + +@ @<Declarations@>= +static void mp_exclaim_redundant_equation (MP mp); + +@* Introduction to the syntactic routines. + +Let's pause a moment now and try to look at the Big Picture. The \MP\ program +consists of three main parts: syntactic routines, semantic routines, and output +routines. The chief purpose of the syntactic routines is to deliver the user's +input to the semantic routines, while parsing expressions and locating operators +and operands. The semantic routines act as an interpreter responding to these +operators, which may be regarded as commands. And the output routines are +periodically called on to produce compact font descriptions that can be used for +typesetting or for making interim proof drawings. We have discussed the basic +data structures and many of the details of semantic operations, so we are good +and ready to plunge into the part of \MP\ that actually controls the activities. + +Our current goal is to come to grips with the |get_next| procedure, which is the +keystone of \MP's input mechanism. Each call of |get_next| sets the value of +three variables |cur_cmd|, |cur_mod|, and |cur_sym|, representing the next input +token. + +$$ +\vbox{\halign{#\hfil\cr + \hbox{|cur_cmd| denotes a command code from the long list of codes given + earlier;}\cr + \hbox{|cur_mod| denotes a modifier or operand of the command code;}\cr + \hbox{|cur_sym| is the hash address of the symbolic token that was just + scanned,}\cr + \hbox{\qquad or zero in the case of a numeric or string or capsule + token.}\cr}} +$$ + +Underlying this external behavior of |get_next| is all the machinery necessary to +convert from character files to tokens. At a given time we may be only partially +finished with the reading of several files (for which |input| was specified), +and partially finished with the expansion of some user-defined macros and/or some +macro parameters, and partially finished reading some text that the user has +inserted online, and so on. When reading a character file, the characters must be +converted to tokens; comments and blank spaces must be removed, numeric and +string tokens must be evaluated. + +To handle these situations, which might all be present simultaneously, \MP\ uses +various stacks that hold information about the incomplete activities, and there +is a finite state control for each level of the input mechanism. These stacks +record the current state of an implicitly recursive process, but the |get_next| +procedure is not recursive. + +@d cur_cmd mp->cur_mod_->command +@d cur_mod number_to_scaled(mp->cur_mod_->data.n) +@d cur_mod_number mp->cur_mod_->data.n +@d cur_mod_node mp->cur_mod_->data.node +@d cur_mod_str mp->cur_mod_->data.str +@d cur_sym mp->cur_mod_->data.sym +@d cur_sym_mod mp->cur_mod_->name_type + +@d set_cur_cmd(A) mp->cur_mod_->command = (A) +@d set_cur_mod(A) set_number_from_scaled(mp->cur_mod_->data.n, (A)) +@d set_cur_mod_number(A) number_clone(mp->cur_mod_->data.n, (A)) +@d set_cur_mod_node(A) mp->cur_mod_->data.node = (A) +@d set_cur_mod_str(A) mp->cur_mod_->data.str = (A) +@d set_cur_sym(A) mp->cur_mod_->data.sym = (A) +@d set_cur_sym_mod(A) mp->cur_mod_->name_type = (A) + +@<Glob...@>= +mp_node cur_mod_; /* current command, symbol, and its operands */ + +@ @<Initialize table...@>= +mp->cur_mod_ = mp_new_symbolic_node(mp); + +@ @<Free table...@>= +mp_free_symbolic_node(mp, mp->cur_mod_); + +@ The |print_cmd_mod| routine prints a symbolic interpretation of a command code +and its modifier. It consists of a rather tedious sequence of print commands, and +most of it is essentially an inverse to the |primitive| routine that enters a +\MP\ primitive into |hash| and |eqtb|. Therefore almost all of this procedure +appears elsewhere in the program, together with the corresponding |primitive| +calls. + +@<Declarations@>= +static const char *mp_cmd_mod_string (MP mp, int c, int m); +static void mp_print_cmd_mod (MP mp, int c, int m); + +@ @c +const char *mp_cmd_mod_string (MP mp, int c, int m) +{ + switch (c) { + @<Cases of |print_cmd_mod| for symbolic printing of primitives@> + } + return "[unknown command code!]"; +} + +void mp_print_cmd_mod (MP mp, int c, int m) +{ + mp_print_str(mp, mp_cmd_mod_string(mp, c, m)); +} + +@ Here is a procedure that displays a given command in braces, in the +user's transcript file. + +@c +static void mp_show_cmd_mod (MP mp, int c, int m) +{ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{"); + switch (c) { + case mp_primary_def_command: + case mp_secondary_def_command: + case mp_tertiary_def_command: + mp_print_cmd_mod(mp, mp_macro_def_command, c); + mp_print_str(mp, "'d macro:"); + mp_print_ln(mp); + mp_show_token_list(mp, mp_link(mp_link(cur_mod_node)),0); + break; + default: + mp_print_cmd_mod(mp, c, m); + break; + } + mp_print_chr(mp, '}'); + mp_end_diagnostic(mp, 0); +} + +@* Input stacks and states. + +The state of \MP's input mechanism appears in the input stack, whose entries are +records with five fields, called |index|, |start|, |loc|, |limit|, and |name|. +The top element of this stack is maintained in a global variable for which no +subscripting needs to be done; the other elements of the stack appear in an +array. Hence the stack is declared thus: + +@<Types...@>= +typedef struct mp_in_state_record { + int start_field; + int loc_field; + int limit_field; + int index_field; + mp_node nstart_field; + mp_node nloc_field; + mp_string name_field; +} mp_in_state_record; + +@ @<Glob...@>= +mp_in_state_record *input_stack; +int input_ptr; /* first unused location of |input_stack| */ +int max_in_stack; /* largest value of |input_ptr| when pushing */ +mp_in_state_record cur_input; /* the \quote {top} input state */ +int stack_size; /* maximum number of simultaneous input sources */ + +@ @<Allocate or initialize ...@>= +mp->stack_size = 16; +mp->input_stack = mp_memory_allocate((size_t) (mp->stack_size + 1) * sizeof(mp_in_state_record)); + +@ @<Dealloc variables@>= +mp_memory_free(mp->input_stack); + +@ We've already defined the special variable |loc==cur_input.loc_field| in our +discussion of basic input-output routines. The other components of |cur_input| +are defined in the same way: + +@d iindex mp->cur_input.index_field /* reference for buffer information */ +@d start mp->cur_input.start_field /* starting position in |buffer| */ +@d limit mp->cur_input.limit_field /* end of current line in |buffer| */ +@d name mp->cur_input.name_field /* name of the current file */ + +@ Let's look more closely now at the five control variables +(|index|,~|start|,~|loc|,~|limit|,~|name|), assuming that \MP\ is reading a line +of characters that have been input from some file or from the user's terminal. +There is an array called |buffer| that acts as a stack of all lines of characters +that are currently being read from files, including all lines on subsidiary +levels of the input stack that are not yet completed. \MP\ will return to the +other lines when it is finished with the present input file. + +(Incidentally, on a machine with byte-oriented addressing, it would be +appropriate to combine |buffer| with the |str_pool| array, letting the buffer +entries grow downward from the top of the string pool and checking that these two +tables don't bump into each other.) + +The line we are currently working on begins in position |start| of the buffer; +the next character we are about to read is |buffer[loc]|; and |limit| is the +location of the last character present. We always have |loc<=limit|. For +convenience, |buffer[limit]| has been set to |"%"|, so that the end of a line is +easily sensed. + +The |name| variable is a string number that designates the name of the current +file, if we are reading an ordinary text file. Special codes +|is_term..max_spec_src| indicate other sources of input text. + +@d is_term (mp_string) 0 /* |name| value when reading from the terminal for normal input */ +@d is_read (mp_string) 1 /* |name| value when executing a |readstring| or |readfrom| */ +@d is_scantok (mp_string) 2 /* |name| value when reading text generated by |scantokens| */ + +@d max_spec_src is_scantok + +@ Additional information about the current line is available via the |index| +variable, which counts how many lines of characters are present in the buffer +below the current level. We have |index=0| when reading from the terminal and +prompting the user for each line; then if the user types, e.g., |input figs|, +we will have |index=1| while reading the file |figs.mp|. However, it does not +follow that |index| is the same as the input stack pointer, since many of the +levels on the input stack may come from token lists. + +The global variable |in_open| is equal to the highest |index| value excluding +token-list input levels. Thus, the number of partially read lines in the buffer +is |in_open+1| and we have |in_open>=index| when we are not reading a token list. + +If we are not currently reading from the terminal, we are reading from the file +variable |input_file[index]|. We use the notation |terminal_input| as a +convenient abbreviation for |name=is_term|, and |cur_file| as an abbreviation for +|input_file[index]|. + +When \MP\ is not reading from the terminal, the global variable |line| contains +the line number in the current file, for use in error messages. More precisely, +|line| is a macro for |line_stack[index]| and the |line_stack| array gives the +line number for each file in the |input_file| array. + +If more information about the input state is needed, it can be included in small +arrays like those shown here. For example, the current page or segment number in +the input file might be put into a variable |page|, that is really a macro for +the current entry in `\ignorespaces|page_stack:array[0..max_in_open] of +integer|\unskip' by analogy with |line_stack|. @^system dependencies@> + +@d terminal_input (name == is_term) /* are we reading from the terminal? */ +@d cur_file mp->input_file[iindex] /* the current |void *| variable */ +@d line mp->line_stack[iindex] /* current line number in the current source file */ + +@<Glob...@>= +int in_open; /* the number of lines in the buffer, less one */ +int in_open_max; /* highest value of |in_open| ever seen */ +unsigned int open_parens; /* the number of open text files */ +void **input_file; +int *line_stack; /* the line number for each file */ + +@ @<Declarations@>= +static void mp_reallocate_input_stack (MP mp, int newsize); + +@ @c +static void mp_reallocate_input_stack (MP mp, int newsize) +{ + int n = newsize + 1; + mp->input_file = mp_memory_reallocate(mp->input_file, (size_t) (n + 1) * sizeof(void *)); + mp->line_stack = mp_memory_reallocate(mp->line_stack, (size_t) (n + 1) * sizeof(int)); + for (int k = mp->max_in_open; k <= n; k++) { + mp->input_file[k] = NULL; + mp->line_stack[k] = 0; + } + mp->max_in_open = newsize; +} + +@ This has to be more than |file_bottom|, so: +@<Allocate or ...@>= +mp_reallocate_input_stack(mp, mp_file_bottom_text + 4); + +@ @<Dealloc variables@>= +mp_memory_free(mp->input_file); +mp_memory_free(mp->line_stack); + +@ However, all this discussion about input state really applies only to the case +that we are inputting from a file. There is another important case, namely when +we are currently getting input from a token list. In this case +|iindex>max_in_open|, and the conventions about the other state variables are +different: + +\yskip\hang|nloc| is a pointer to the current node in the token list, i.e., the +node that will be read next. If |nloc=NULL|, the token list has been fully read. + +\yskip\hang|start| points to the first node of the token list; this node may or +may not contain a reference count, depending on the type of token list involved. + +\yskip\hang|token_type|, which takes the place of |iindex| in the discussion +above, is a code number that explains what kind of token list is being scanned. + +\yskip\hang|name| points to the |eqtb| address of the control sequence being +expanded, if the current token list is a macro not defined by |vardef|. Macros +defined by |vardef| have |name=NULL|; their name can be deduced by looking at +their first two parameters. + +\yskip\hang|param_start|, which takes the place of |limit|, tells where the +parameters of the current macro or loop text begin in the |param_stack|. + +\yskip\noindent The |token_type| can take several values, depending on where the +current token list came from: + +\yskip \indent|forever_text|, if the token list being scanned is the body of a +|forever| loop; + +\indent|loop_text|, if the token list being scanned is the body of a |for| or +|forsuffixes| loop; + +\indent|parameter|, if a |text| or |suffix| parameter is being scanned; + +\indent|backed_up|, if the token list being scanned has been inserted as `to be +read again'. + +\indent|inserted|, if the token list being scanned has been inserted as part of +error recovery; + +\indent|macro|, if the expansion of a user-defined symbolic token is being +scanned. + +\yskip\noindent The token list begins with a reference count if and only if +|token_type= macro|. @^reference counts@> + +@d nloc mp->cur_input.nloc_field /* location of next node node */ +@d nstart mp->cur_input.nstart_field /* location of next node node */ + +@d token_type iindex /* type of current token list */ +@d token_state (iindex<=mp_macro_text) /* are we scanning a token list? */ +@d file_state (iindex>mp_macro_text) /* are we scanning a file line? */ +@d param_start limit /* base of macro parameters in |param_stack| */ + + +@ @<Enumeration types@>= +typedef enum mp_text_codes { + mp_forever_text, /* |token_type| code for loop texts */ + mp_loop_text, /* |token_type| code for loop texts */ + mp_parameter_text, /* |token_type| code for parameter texts */ + mp_backed_up_text, /* |token_type| code for texts to be reread */ + mp_inserted_text, /* |token_type| code for inserted texts */ + mp_macro_text, /* |token_type| code for macro replacement texts */ + mp_file_bottom_text, /* lowest file code */ +} mp_text_codes; + +@ The |param_stack| is an auxiliary array used to hold pointers to the token +lists for parameters at the current level and subsidiary levels of input. This +stack grows at a different rate from the others, and is dynamically reallocated +when needed. + +@<Glob...@>= +mp_node *param_stack; /* token list pointers for parameters */ +int param_ptr; /* first unused entry in |param_stack| */ +int max_param_stack; /* largest value of |param_ptr| */ + +@ @<Allocate or initialize ...@>= +mp->param_stack = mp_memory_allocate((size_t) (mp->param_size + 1) * sizeof(mp_node)); + +@ @c +static void mp_check_param_size (MP mp, int k) +{ + while (k >= mp->param_size) { + mp->param_stack = mp_memory_reallocate(mp->param_stack, (size_t) ((k + k / 4) + 1) * sizeof(mp_node)); + mp->param_size = k + k / 4; + } +} + +@ @<Dealloc variables@>= +mp_memory_free(mp->param_stack); + +@ Notice that the |line| isn't valid when |token_state| is true because it +depends on |iindex|. If we really need to know the line number for the topmost +file in the iindex stack we use the following function. If a page number or other +information is needed, this routine should be modified to compute it as well. +@^system dependencies@> + +@<Declarations@>= +static int mp_true_line (MP mp); + +@ @c +int mp_true_line (MP mp) +{ + int k; /* an index into the input stack */ + if (file_state && (name > max_spec_src)) { + return line; + } else { + k = mp->input_ptr; + while ((k > 0) && ((mp->input_stack[(k - 1)].index_field < mp_file_bottom_text) + || (mp->input_stack[(k - 1)].name_field <= max_spec_src))) { + --k; + } + return (k > 0 ? mp->line_stack[(k - 1) + mp_file_bottom_text] : 0); + } +} + +@ Thus, the \quote {current input state} can be very complicated indeed; there can be +many levels and each level can arise in a variety of ways. The |show_context| +procedure, which is used by \MP's error-reporting routine to print out the +current input state on all levels down to the most recent line of characters from +an input file, illustrates most of these conventions. The global variable +|file_ptr| contains the lowest level that was displayed by this procedure. + +@<Glob...@>= +int file_ptr; /* shallowest level shown by |show_context| */ + +@ The status at each level is indicated by printing two lines, where the first +line indicates what was read so far and the second line shows what remains to be +read. Non-current input levels whose |token_type| is |backed_up| are shown only if +they have not been fully read. + +@c +void mp_show_context (MP mp) +{ + /* prints where the scanner is */ + mp->file_ptr = mp->input_ptr; + mp->input_stack[mp->file_ptr] = mp->cur_input; + /* store current state */ + while (1) { + /* enter into the context */ + mp->cur_input = mp->input_stack[mp->file_ptr]; + @<Display the current context@> + if (file_state && (name > max_spec_src || mp->file_ptr == 0)) { + break; + } else { + --mp->file_ptr; + } + } + /* restore original state */ + mp->cur_input = mp->input_stack[mp->input_ptr]; +} + +@ @<Display the current context@>= +/* we omit backed-up token lists that have already been read */ +if ((mp->file_ptr == mp->input_ptr) || file_state || (token_type != mp_backed_up_text) || (nloc != NULL)) { + if (file_state) { + @<Print location of current line@> + if (limit > 0) { + for (int i = start; i <= limit - 1; i++) { + mp_print_chr(mp, mp->buffer[i]); + } + } + } else { + @<Print type of token list@> + if (token_type == mp_macro_text) { + mp_show_macro(mp, nstart, nloc); + } else if (mp->show_mode) { + mp_show_token_list_space(mp, nstart, nloc); + } else { + mp_show_token_list(mp, nstart, nloc); + } + } +} + +@ This routine should be changed, if necessary, to give the best possible +indication of where the current line resides in the input file. For example, on +some systems it is best to print both a page and line number. @^system +dependencies@> + +@<Print location of current line@>= +if (name > max_spec_src) { + /* mp_print_nl(mp, "l."); */ + mp_print_nl(mp, "<line "); + mp_print_int(mp, mp_true_line(mp)); + mp_print_chr(mp, '>'); +} else if (terminal_input) { + if (mp->file_ptr == 0) { + mp_print_nl(mp, "<direct>"); + } else { + mp_print_nl(mp, "<insert>"); + } +} else if (name == is_scantok) { + mp_print_nl(mp, "<scantokens>"); +} else { + mp_print_nl(mp, "<read>"); +} +mp_print_chr(mp, ' '); + +@ Can't use case statement here because the |token_type| is not a constant +expression. + +@<Print type of token list@>= +{ + switch (token_type) { + case mp_forever_text: + mp_print_nl(mp, "<forever> "); + break; + case mp_loop_text: + @<Print the current loop value@> + break; + case mp_parameter_text: + mp_print_nl(mp, "<argument> "); + break; + case mp_backed_up_text: + mp_print_nl(mp, nloc == NULL ? "<recently read> " : "<to be read again> "); + break; + case mp_inserted_text: + mp_print_nl(mp, "<inserted text> "); + break; + case mp_macro_text: + mp_print_nl(mp, "<macro> "); + // mp_print_ln(mp); + if (name != NULL) { + mp_print_mp_str(mp, name); + } else { + @<Print the name of a |vardef|'d macro@> + } + // mp_print_str(mp, "->"); + mp_print_str(mp, " -> "); + break; + default: + mp_print_nl(mp, "?"); /* this should never happen */ + @.?\relax@> + break; + } +} + +@ The parameter that corresponds to a loop text is either a token list (in the +case of |forsuffixes|) or a \quote {capsule} (in the case of |for|). We'll discuss +capsules later; for now, all we need to know is that the |link| field in a +capsule parameter is |void| and that |print_exp(p,0)| displays the value of +capsule~|p| in abbreviated form. + +@<Print the current loop value@>= +{ + mp_node pp = mp->param_stack[param_start]; + mp_print_nl(mp, "<for("); + if (pp != NULL) { + if (mp_link(pp) == MP_VOID) { + mp_print_exp(mp, pp, 0); /* we're in a |for| loop */ + } else { + mp_show_token_list(mp, pp, NULL); + } + } + mp_print_str(mp, ")> "); +} + +@ The first two parameters of a macro defined by |vardef| will be token +lists representing the macro's prefix and \quote {at point.} By putting these +together, we get the macro's full name. + +@<Print the name of a |vardef|'d macro@>= +{ + mp_node pp = mp->param_stack[param_start]; + if (pp == NULL) { + mp_show_token_list(mp, mp->param_stack[param_start + 1], NULL); + } else { + mp_node qq = pp; + while (mp_link(qq) != NULL) { + qq = mp_link(qq); + } + mp_link(qq) = mp->param_stack[param_start + 1]; + mp_show_token_list(mp, pp, NULL); + mp_link(qq) = NULL; + } +} + +@* Maintaining the input stacks. + +The following subroutines change the input status in commonly needed ways. + +First comes |mp_push_input|, which stores the current state and creates a +new level (having, initially, the same properties as the old). We could have +a maximum depth here. + +@<Declarations@>= +static void mp_push_input (MP mp); + +@ @c +void mp_push_input (MP mp) +{ + if (mp->input_ptr > mp->max_in_stack) { + mp->max_in_stack = mp->input_ptr; + if (mp->input_ptr == mp->stack_size) { + int l = (mp->stack_size + (mp->stack_size/4)); + if (l > 1000) { + mp_fatal_error(mp, "job aborted, more than 1000 input levels"); + } else { + mp_in_state_record *s = mp_memory_reallocate(mp->input_stack, (size_t) (l + 1) * sizeof(mp_in_state_record)); + if (s) { + mp->input_stack = s; + mp->stack_size = l; + } else { + mp_fatal_error(mp, "job aborted, out of memory"); + } + } + } + } + mp->input_stack[mp->input_ptr] = mp->cur_input; + ++mp->input_ptr; +} + +@ And of course what goes up must come down. + +@<Declarations@>= +static void mp_pop_input (MP mp); + +@ @c + +void mp_pop_input (MP mp) +{ + --mp->input_ptr; + mp->cur_input = mp->input_stack[mp->input_ptr]; +} + +@ Here is a procedure that starts a new level of token-list input, given a token +list |p| and its type |t|. If |t=macro|, the calling routine should set |name|, +reset~|loc|, and increase the macro's reference count. + +@c +static void mp_begin_token_list (MP mp, mp_node p, int t) +{ + mp_push_input(mp); + nstart = p; + token_type = t; + param_start = mp->param_ptr; + nloc = p; +} + +@ When a token list has been fully scanned, the following computations should be +done as we leave that level of input. @^inner loop@> + +@c +static void mp_end_token_list (MP mp) +{ + /* leave a token-list input level */ + if (token_type >= mp_backed_up_text) { + /* token list to be deleted */ + if (token_type <= mp_inserted_text) { + mp_flush_token_list(mp, nstart); + goto DONE; + } else { + /* update reference count */ + mp_delete_mac_ref(mp, nstart); + } + } + while (mp->param_ptr > param_start) { + /* parameters must be flushed */ + mp_node p; /* temporary register */ + --mp->param_ptr; + p = mp->param_stack[mp->param_ptr]; + if (p != NULL) { + if (mp_link(p) == MP_VOID) { + /* it's an |expr| parameter */ + mp_recycle_value(mp, p); + mp_free_value_node(mp, p); + } else { + /* it's a |suffix| or |text| parameter */ + mp_flush_token_list(mp, p); + } + } + } + DONE: + mp_pop_input(mp); +} + +@ The contents of |cur_cmd, cur_mod, cur_sym| are placed into an equivalent +token by the |cur_tok| routine. +@^inner loop@> + +@c +@<Declare the procedure called |make_exp_copy|@> +static mp_node mp_cur_tok (MP mp) +{ + mp_node p; /* a new token node */ + if (cur_sym == NULL && (cur_sym_mod == 0 || cur_sym_mod == mp_normal_operation)) { + if (cur_cmd == mp_capsule_command) { + mp_number save_exp_num; /* possible |cur_exp| numerical to be restored */ + mp_value save_exp = mp->cur_exp; /* |cur_exp| to be restored */ + new_number(save_exp_num); + number_clone(save_exp_num, cur_exp_value_number); + mp_make_exp_copy(mp, cur_mod_node); + p = mp_stash_cur_exp(mp); + mp_link(p) = NULL; + mp->cur_exp = save_exp; + number_clone(mp->cur_exp.data.n, save_exp_num); + free_number(save_exp_num); + } else { + p = mp_new_token_node(mp); + mp_name_type(p) = mp_token_operation; + if (cur_cmd == mp_numeric_command) { + mp_set_value_number(p, cur_mod_number); + mp_type(p) = mp_known_type; + } else { + mp_set_value_str(p, cur_mod_str); + mp_type(p) = mp_string_type; + } + } + } else { + p = mp_new_symbolic_node(mp); + mp_set_sym_sym(p, cur_sym); + mp_name_type(p) = cur_sym_mod; + } + return p; +} + +@ Sometimes \MP\ has read too far and wants to \quote {unscan} what it has seen. The +|back_input| procedure takes care of this by putting the token just scanned back +into the input stream, ready to be read again. If |cur_sym<>0|, the values of +|cur_cmd| and |cur_mod| are irrelevant. + +@<Declarations@>= +static void mp_back_input (MP mp); + +@ @c +void mp_back_input (MP mp) +{ + /* undoes one token of input */ + mp_node p = mp_cur_tok(mp); /* a token list of length one */ + /* conserve stack space */ + while (token_state && (nloc == NULL)) { + mp_end_token_list(mp); + } + mp_begin_token_list(mp, p, mp_backed_up_text); +} + +@ The |back_error| routine is used when we want to restore or replace an +offending token just before issuing an error message. + +@<Declarations@>= +static void mp_back_error (MP mp, const char *msg, const char *hlp) ; + +@ @c +static void mp_back_error (MP mp, const char *msg, const char *hlp) +{ + /* back up one token and call |error| */ + mp_back_input(mp); + mp_error(mp, msg, hlp); +} + +static void mp_ins_error (MP mp, const char *msg, const char *hlp) +{ + /* back up one inserted token and call |error| */ + mp_back_input(mp); + token_type = mp_inserted_text; + mp_error(mp, msg, hlp); +} + +@ The |begin_file_reading| procedure starts a new level of input for lines of +characters to be read from a file, or as an insertion from the terminal. It does +not take care of opening the file, nor does it set |loc| or |limit| or |line|. +@^system dependencies@> + +@c +void mp_begin_file_reading (MP mp) +{ + if (mp->in_open == (mp->max_in_open-1)) { + mp_reallocate_input_stack (mp, (mp->max_in_open + mp->max_in_open / 4)); + } + if (mp->first == mp->buf_size) { + mp_reallocate_buffer(mp, (mp->buf_size + mp->buf_size / 4)); + } + mp->in_open++; + mp_push_input(mp); + iindex = (int) mp->in_open; + if (mp->in_open_max < mp->in_open) { + mp->in_open_max = mp->in_open; + } + start = (int) mp->first; + name = is_term; /* |terminal_input| is now |true| */ +} + +@ Conversely, the variables must be downdated when such a level of input is +finished. While finishing preloading, it is possible that the file does not +actually end with 'dump', so we capture that case here as well. + +@c +static void mp_end_file_reading (MP mp) +{ + if (mp->in_open > iindex) { + if ((name <= max_spec_src)) { + mp_confusion(mp, "endinput"); + @:this can't happen endinput}{\quad endinput@> + } else { + (mp->close_file) (mp, mp->input_file[mp->in_open]); + --mp->in_open; + } + } + mp->first = (size_t) start; + if (iindex != mp->in_open) { + mp_confusion(mp, "endinput"); + } else { + if (name > max_spec_src) { + (mp->close_file) (mp, cur_file); + } + mp_pop_input(mp); + --mp->in_open; + } +} + +@* Getting the next token. + +The heart of \MP's input mechanism is the |get_next| procedure, which we shall +develop in the next few sections of the program. Perhaps we shouldn't actually +call it the \quote {heart,} however; it really acts as \MP's eyes and mouth, reading +the source files and gobbling them up. And it also helps \MP\ to regurgitate +stored token lists that are to be processed again. + +The main duty of |get_next| is to input one token and to set |cur_cmd| and +|cur_mod| to that token's command code and modifier. Furthermore, if the input +token is a symbolic token, that token's |hash| address is stored in |cur_sym|; +otherwise |cur_sym| is set to zero. + +Underlying this simple description is a certain amount of complexity because of +all the cases that need to be handled. However, the inner loop of |get_next| is +reasonably short and fast. + +@ Before getting into |get_next|, we need to consider a mechanism by which \MP\ +helps keep errors from propagating too far. Whenever the program goes into a mode +where it keeps calling |get_next| repeatedly until a certain condition is met, it +sets |scanner_status| to some value other than |normal|. Then if an input file +ends, or if an |outer| symbol appears, an appropriate error recovery will be +possible. + +The global variable |warning_info| helps in this error recovery by providing +additional information. For example, |warning_info| might indicate the name of a +macro whose replacement text is being scanned. + +@ @<Enumeration types@>= +typedef enum mp_scanner_states { + mp_normal_state, /* |scanner_status| at \quote {quiet times} */ + mp_skipping_state, /* |scanner_status| when false conditional text is being skipped */ + mp_flushing_state, /* |scanner_status| when junk after a statement is being ignored */ + mp_absorbing_state, /* |scanner_status| when a |text| parameter is being scanned */ + mp_var_defining_state, /* |scanner_status| when a |vardef| is being scanned */ + mp_op_defining_state, /* |scanner_status| when a macro |def| is being scanned */ + mp_loop_defining_state, /* |scanner_status| when a |for| loop is being scanned */ + mp_tex_flushing_state, +} mp_scanner_states; + +@ @<Glob...@>= +int scanner_status; /* are we scanning at high speed? */ +mp_sym warning_info; /* if so, what else do we need to know, in case an error occurs? */ +int warning_line; +mp_node warning_info_node; + +@ The following subroutine is called when an |outer| symbolic token has been +scanned or when the end of a file has been reached. These two cases are +distinguished by |cur_sym|, which is zero at the end of a file. + +@c +static int mp_check_outer_validity (MP mp) +{ + if (mp->scanner_status == mp_normal_state) { + return 1; + } else if (mp->scanner_status == mp_tex_flushing_state) { + @<Check if the file has ended while flushing \TeX\ material and set the result value for |check_outer_validity|@> + } else { + @<Back up an outer symbolic token so that it can be reread@> + if (mp->scanner_status > mp_skipping_state) { + @<Tell the user what has run away and try to recover@> + } else { + char msg[256]; + const char *hlp = NULL; + mp_snprintf(msg, 256, "Incomplete if; all text was ignored after line %d", (int) mp->warning_line); + @.Incomplete if...@> + if (cur_sym == NULL) { + hlp = + "The file ended while I was skipping conditional text. This kind of error happens\n" + "when you say 'if ...' and forget the matching 'fi'. I've inserted a 'fi'; this\n" + "might work."; + } else { + hlp = + "A forbidden 'outer' token occurred in skipped text. This kind of error happens\n" + "when you say 'if ...' and forget the matching 'fi'. I've inserted a 'fi'; this\n" + "might work."; + } + set_cur_sym(mp->frozen_fi); + mp_ins_error(mp, msg, hlp); + } + return 0; + } +} + +@ @<Check if the file has ended while flushing \TeX\ material and set...@>= +if (cur_sym != NULL) { + return 1; +} else { + char msg[256]; + mp_snprintf(msg, 256, "TeX mode didn't end; all text was ignored after line %d", (int) mp->warning_line); + set_cur_sym(mp->frozen_etex); + mp_ins_error( + mp, + msg, + "The file ended while I was looking for the 'etex' to finish this TeX material.\n" + "I've inserted 'etex' now." + ); + return 0; +} + +@ @<Back up an outer symbolic token so that it can be reread@>= +// if (cur_sym != NULL) { +// mp_node p = mp_new_symbolic_node(mp); +// mp_set_sym_sym(p, cur_sym); +// mp_name_type(p) = cur_sym_mod; +// /* prepare to read the symbolic token again */ +// mp_begin_token_list(mp, p, mp_backed_up_text); +// } + +@ @<Tell the user what has run away...@>= +{ + char msg[256]; + const char *mst = NULL; + const char *hlp = + "I suspect you have forgotten an 'enddef', causing me to read past where you\n" + "wanted me to stop. I'll try to recover."; + mp_runaway(mp); + /* print the definition-so-far */ + if (cur_sym == NULL) { + mst = "File ended while scanning"; + @.File ended while scanning...@> + } else { + mst = "Forbidden token found while scanning"; + @.Forbidden token found...@> + } + switch (mp->scanner_status) { + case mp_flushing_state: + { + mp_snprintf(msg, 256, "%s to the end of the statement", mst); + hlp = + "A previous error seems to have propagated, causing me to read past where\n" + "you wanted me to stop. I'll try to recover."; + set_cur_sym(mp->frozen_semicolon); + } + break; + case mp_absorbing_state: + { + mp_snprintf(msg, 256, "%s a text argument", mst); + hlp = + "It seems that a right delimiter was left out, causing me to read past where\n" + "you wanted me to stop. I'll try to recover."; + if (mp->warning_info == NULL) { + set_cur_sym(mp->frozen_end_group); + } else { + set_cur_sym(mp->frozen_right_delimiter); + /* + The next line makes sure that the inserted delimiter will match the + delimiter that already was read. + */ + set_equiv_sym(cur_sym, mp->warning_info); + } + } + break; + case mp_var_defining_state: + { + mp_string s; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_variable_name(mp, mp->warning_info_node); + s = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "%s the definition of %s", mst, s->str); + delete_str_ref(s); + set_cur_sym(mp->frozen_end_def); + } + break; + case mp_op_defining_state: + { + char *s = mp_str(mp, text(mp->warning_info)); + mp_snprintf(msg, 256, "%s the definition of %s", mst, s); + set_cur_sym(mp->frozen_end_def); + } + break; + case mp_loop_defining_state: + { + char *s = mp_str(mp, text(mp->warning_info)); + mp_snprintf(msg, 256, "%s the text of a %s loop", mst, s); + hlp = + "I suspect you have forgotten an 'endfor', causing me to read past where\n" + "you wanted me to stop. I'll try to recover."; + set_cur_sym(mp->frozen_end_for); + } + break; + } + mp_ins_error(mp, msg, hlp); +} + +@ The |runaway| procedure displays the first part of the text that occurred when +\MP\ began its special |scanner_status|, if that text has been saved. + +@<Declarations@>= +static void mp_runaway (MP mp); + +@ @c +void mp_runaway (MP mp) +{ + if (mp->scanner_status > mp_flushing_state) { + mp_print_nl(mp, "Runaway "); + switch (mp->scanner_status) { + case mp_absorbing_state: + mp_print_str(mp, "text?"); + break; + case mp_var_defining_state: + case mp_op_defining_state: + mp_print_str(mp, "definition?"); + break; + case mp_loop_defining_state: + mp_print_str(mp, "loop?"); + break; + } + mp_print_ln(mp); + mp_show_token_list(mp, mp_link(mp->hold_head), NULL); + } +} + +@ We need to mention a procedure that may be called by |get_next|. + +@<Declarations@>= +static void mp_firm_up_the_line (MP mp); + +@ And now we're ready to take the plunge into |get_next| itself. Note that the +behavior depends on the |scanner_status| because percent signs and double quotes +need to be passed over when skipping TeX material. + +@c +void mp_get_next (MP mp) +{ + /* sets |cur_cmd|, |cur_mod|, |cur_sym| to next token */ + mp_sym cur_sym_; /* speed up access */ + RESTART: + set_cur_sym(NULL); + set_cur_sym_mod(0); + if (file_state) { + int k; /* an index into |buffer| */ + unsigned char c; /* the current character in the buffer */ + int cclass; /* its class number */ + /* + Input from external file; |goto restart| if no input found, or + |return| if a non-symbolic token is found. A percent sign appears in + |buffer[limit]|; this makes it unnecessary to have a special test for + end-of-line. + */ + SWITCH: + c = mp->buffer[loc]; + ++loc; + cclass = mp->char_class[c]; + switch (cclass) { + case mp_digit_class: + scan_numeric_token((c - '0')); + return; + case mp_period_class: + cclass = mp->char_class[mp->buffer[loc]]; + if (cclass > mp_period_class) { + goto SWITCH; + } else if (cclass < mp_period_class) { + /* |class=digit_class| */ + scan_fractional_token(0); + return; + } else { + break; + } + case mp_space_class: + goto SWITCH; + case mp_percent_class: + if (mp->scanner_status == mp_tex_flushing_state && loc < limit) { + /* btex .. etex */ + goto SWITCH; + } + /* + Move to next line of file, or |goto restart| if there is no + next line. + */ + if (mp_move_to_next_line(mp)) { + goto RESTART; + } else { + goto SWITCH; + } + case mp_string_class: + if (mp->scanner_status == mp_tex_flushing_state) { + goto SWITCH; + } else { + unsigned char cend = c == '"' ? '"' : 3 ; /* ASCII BTX ... ETX */ + if (mp->buffer[loc] == cend) { + set_cur_mod_str(mp_rts(mp,"")); + } else { + k = loc; + mp->buffer[limit + 1] = cend; + do { + ++loc; + } while (mp->buffer[loc] != cend); + if (loc > limit) { + /* + Decry the missing string delimiter and |goto restart|. We go to + |restart| after this error message, not to |SWITCH|, because the + |clear_for_error_prompt| routine might have reinstated + |token_state| after |error| has finished. + */ + loc = limit; + /* the next character to be read on this line will be |"%"| */ + mp_error( + mp, + "Incomplete string token has been flushed", + "Strings should finish on the same line as they began. I've deleted the partial\n" + "string." + ); + goto RESTART; + } + mp_str_room(mp, (size_t) (loc - k)); + do { + mp_append_char(mp, mp->buffer[k]); + ++k; + } while (k != loc); + set_cur_mod_str(mp_make_string(mp)); + } + ++loc; + set_cur_cmd(mp_string_command); + return; + } + case mp_comma_class: + case mp_semicolon_class: + case mp_left_parenthesis_class: + case mp_right_parenthesis_class: + k = loc - 1; + goto FOUND; + case mp_invalid_class: + if (mp->scanner_status == mp_tex_flushing_state) { + goto SWITCH; + } else { + /* + Decry the invalid character and |goto restart|. We go to + |restart| instead of to |SWITCH|, because we might enter + |token_state| after the error has been dealt with (cf.\ + |clear_for_error_prompt|). + */ + mp_error( + mp, + "Text line contains an invalid character", + "A funny symbol that I can\'t read has just been input. Continue, and I'll forget\n" + "that it ever happened." + ); + goto RESTART; + } + default: + /* letters, etc. */ + break; + } + k = loc - 1; + while (mp->char_class[mp->buffer[loc]] == cclass) { + ++loc; + } + FOUND: + set_cur_sym(mp_id_lookup(mp, (char *) (mp->buffer + k), (size_t) (loc - k), 1)); + } else { + /* + Input from token list; |goto restart| if end of list or if a parameter + needs to be expanded, or |return| if a non-symbolic token is found. + */ + if (nloc != NULL && mp_type(nloc) == mp_symbol_node_type) { + /* symbolic token */ + int cur_sym_mod_ = mp_name_type(nloc); + int cur_info = mp_get_sym_info(nloc); + set_cur_sym(mp_get_sym_sym(nloc)); + set_cur_sym_mod(cur_sym_mod_); + /* move to next */ + nloc = mp_link(nloc); + if (cur_sym_mod_ == mp_expr_operation) { + set_cur_cmd(mp_capsule_command); + set_cur_mod_node(mp->param_stack[param_start + cur_info]); + set_cur_sym_mod(0); + set_cur_sym(NULL); + return; + } else if (cur_sym_mod_ == mp_suffix_operation || cur_sym_mod_ == mp_text_operation) { + mp_begin_token_list(mp, mp->param_stack[param_start + cur_info], (int) mp_parameter_text); + goto RESTART; + } + } else if (nloc != NULL) { + /* Get a stored numeric or string or capsule token and |return| */ + if (mp_name_type(nloc) == mp_token_operation) { + if (mp_type(nloc) == mp_known_type) { + set_cur_mod_number(mp_get_value_number(nloc)); + set_cur_cmd(mp_numeric_command); + } else { + set_cur_mod_str(mp_get_value_str(nloc)); + set_cur_cmd(mp_string_command); + add_str_ref(cur_mod_str); + } + } else { + set_cur_mod_node(nloc); + set_cur_cmd(mp_capsule_command); + } + nloc = mp_link(nloc); + return; + } else { + /* we are done with this token list */ + mp_end_token_list(mp); + /* resume previous level */ + goto RESTART; + } + } + /* + When a symbolic token is declared to be |outer|, its command code is + increased by |outer_tag|. + */ + cur_sym_ = cur_sym; + set_cur_cmd(eq_type(cur_sym_)); + set_cur_mod(equiv(cur_sym_)); + set_cur_mod_node(equiv_node(cur_sym_)); + // if (cur_cmd >= mp_outer_tag_command) { + // if (mp_check_outer_validity(mp)) { + // set_cur_cmd(cur_cmd - mp_outer_tag_command); + // } else { + // goto RESTART; + // } + // } +} + +@ The global variable |force_eof| is normally |false|; it is set |true| by an +|endinput| command. + +@<Glob...@>= +int force_eof; /* should the next |input| be aborted early? */ + +@ @<Declarations@>= +static int mp_move_to_next_line (MP mp); + +@ @c +static int mp_move_to_next_line (MP mp) +{ + if (name > max_spec_src) { + /* + Read next line of file into |buffer|, or return 1 (|goto restart|) if + the file has ended. We must decrement |loc| in order to leave the + buffer in a valid state when an error condition causes us to |goto + restart| without calling |end_file_reading|. + */ + ++line; + mp->first = (size_t) start; + if (! mp->force_eof) { + if (mp_input_ln(mp, cur_file)) { /* not end of file */ + mp_firm_up_the_line(mp); /* this sets |limit| */ + } else { + mp->force_eof = 1; + } + }; + if (mp->force_eof) { + mp->force_eof = 0; + --loc; + if (mp->interaction < mp_silent_mode) { + mp_print_chr(mp, ')'); + --mp->open_parens; + /* show user that file has been read */ + update_terminal(); + } + /* resume previous level */ + mp_end_file_reading(mp); + mp_check_outer_validity(mp); + return 1; + } else { + mp->buffer[limit] = '%'; + mp->first = (size_t) (limit + 1); + loc = start; /* ready to read */ + } + } else if (mp->input_ptr > 0) { + /* text was inserted during error recovery or by |scantokens| */ + mp_end_file_reading(mp); + /* goto RESTART */ + return 1; /* resume previous level */ + } else if (mp->interaction > mp_nonstop_mode) { + if (limit == start && mp->interaction < mp_silent_mode) { + /* previous line was empty */ + mp_print_nl(mp, "(Please type a command or say `end')"); + } + mp_print_ln(mp); + mp->first = (size_t) start; + /* get a line from the terminal, prompt delegated */ + if (! mp_input_ln(mp, mp->term_in)) { + longjmp(*(mp->jump_buf), 1); + } + mp->buffer[mp->last] = '%'; + /* done */ + limit = (int) mp->last; + mp->buffer[limit] = '%'; + mp->first = (size_t) (limit + 1); + loc = start; + } else { + mp_fatal_error(mp, "job aborted, no legal end found"); + } + return 0; +} + +@ If the user has set the |mp_pausing| parameter to some positive value, and if +nonstop mode has not been selected, each line of input is displayed on the +terminal and the transcript file, followed by |=>|. \MP\ waits for a +response. If the response is NULL (i.e., if nothing is typed except perhaps a few +blank spaces), the original line is accepted as it stands; otherwise the line +typed is used instead of the line in the file. + +@c +void mp_firm_up_the_line (MP mp) +{ + limit = (int) mp->last; +} + +@* Dealing with \TeX\ material. + +The |btex|$\,\ldots\,$|etex| and |verbatimtex|$\,\ldots\,$|etex| features +need to be implemented at a low level in the scanning process so that \MP\ can +stay in synch with the a preprocessor that treats blocks of \TeX\ material as +they occur in the input file without trying to expand \MP\ macros. Thus we need a +special version of |get_next| that does not expand macros and such but does +handle |btex|, |verbatimtex|, etc. + +@ @<Enumeration types@>= +typedef enum mp_verbatim_codes { + mp_btex_code, + mp_verbatim_code, +} mp_verbatim_codes; + +@ @<Put each...@>= +mp_primitive(mp, "btex", mp_btex_command, mp_btex_code); +@:btex_}{|btex| primitive@> +mp_primitive(mp, "verbatimtex", mp_btex_command, mp_verbatim_code); +@:verbatimtex_}{|verbatimtex| primitive@> +mp_primitive(mp, "etex", mp_etex_command, 0); +mp->frozen_etex = mp_frozen_primitive (mp, "etex", mp_etex_command, 0); +@:etex_}{|etex| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_btex_command: return m == mp_btex_code ? "btex" : "verbatimtex"; +case mp_etex_command: return "etex"; + +@ Actually, |get_t_next| is a macro that avoids procedure overhead except in the +unusual case where |btex|, |verbatimtex| or |etex| is encountered. Nowadays +the compiler deals with this so it might become a function. + +@d get_t_next(mp) do { + mp_get_next(mp); + if (cur_cmd <= mp_max_pre_command) { + mp_t_next(mp); /* will probably get inlined anyway */ + } +} while (0) + +@c +@ @<Declarations@>= +static void mp_t_next (MP mp); + +@ @c +static void mp_t_next (MP mp) +{ + if ((mp->extensions == 1) && (cur_cmd == mp_btex_command)) { + @<Pass btex ... etex to script@> + } else { + @<Complain about a misplaced |btex|@> + } +} + +@ @<Complain about a misplaced |btex|@>= +{ + mp_error( + mp, + "A 'btex/verbatimtex ... etex' definition needs an extension", + "This file contains picture expressions for 'btex ... etex' blocks. Such files\n" + "need an extension (plugin) that seems to be absent." + ); +} + +@* Scanning macro definitions. + +\MP\ has a variety of ways to tuck tokens away into token lists for later use: +Macros can be defined with |def|, |vardef|, |primarydef|, etc.; repeatable +code can be defined with |for|, |forever|, |forsuffixes|. All such +operations are handled by the routines in this part of the program. + +The modifier part of each command code is zero for the \quote {ending delimiters} like +|enddef| and |endfor|. + +@ @<Enumeration types@>= +typedef enum mp_def_codes { + mp_end_def_code, /* command modifier for |enddef| */ + mp_def_code, /* command modifier for |def| */ + mp_var_def_code, /* command modifier for |vardef| */ + mp_primary_def_code, /* command modifier for |primarydef| */ + mp_secondary_def_code, /* command modifier for |secondarydef| */ + mp_tertiary_def_code, /* command modifier for |tertiarydef| */ +} mp_def_codes; + +@ @<Enumeration types@>= +typedef enum mp_only_set_codes { + mp_random_seed_code, + mp_max_knot_pool_code, +} mp_only_set_codes; + +@ @<Enumeration types@>= +typedef enum mp_for_codes { + mp_end_for_code, /* command modifier for |endfor| */ + mp_start_forever_code, /* command modifier for |forever| */ + mp_start_for_code, /* command modifier for |for| */ + mp_start_forsuffixes_code, /* command modifier for |forsuffixes| */ +} mp_for_codes; + +@ @<Put each...@>= +mp_primitive(mp, "def", mp_macro_def_command, mp_def_code); +@:def_}{|def| primitive@> +mp_primitive(mp, "vardef", mp_macro_def_command, mp_var_def_code); +@:var_def_}{|vardef| primitive@> +mp_primitive(mp, "primarydef", mp_macro_def_command, mp_primary_def_code); +@:primary_def_}{|primarydef| primitive@> +mp_primitive(mp, "secondarydef", mp_macro_def_command, mp_secondary_def_code); +@:secondary_def_}{|secondarydef| primitive@> +mp_primitive(mp, "tertiarydef", mp_macro_def_command, mp_tertiary_def_code); +@:tertiary_def_}{|tertiarydef| primitive@> +mp_primitive(mp, "enddef", mp_macro_def_command, mp_end_def_code); +mp->frozen_end_def = mp_frozen_primitive(mp, "enddef", mp_macro_def_command, mp_end_def_code); +@:end_def_}{|enddef| primitive@> +mp_primitive(mp, "for", mp_iteration_command, mp_start_for_code); +@:for_}{|for| primitive@> +mp_primitive(mp, "forsuffixes", mp_iteration_command, mp_start_forsuffixes_code); +@:for_suffixes_}{|forsuffixes| primitive@> +mp_primitive(mp, "forever", mp_iteration_command, mp_start_forever_code); +@:forever_}{|forever| primitive@> +mp_primitive(mp, "endfor", mp_iteration_command, mp_end_for_code); +mp->frozen_end_for = mp_frozen_primitive (mp, "endfor", mp_iteration_command, mp_end_for_code); +@:end_for_}{|endfor| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_macro_def_command: + switch (m) { + /* low numbers, command specifiers */ + case mp_end_def_code : return "enddef"; + case mp_def_code : return "def"; + case mp_var_def_code : return "vardef"; + case mp_primary_def_code : return "primarydef"; + case mp_secondary_def_code: return "secondarydef"; + case mp_tertiary_def_code : return "tertiarydef"; + default: return "?def"; + } + break; + +case mp_iteration_command: + switch (m) { + case mp_end_for_code : return "endfor"; + case mp_start_forever_code : return "forever"; + case mp_start_for_code : return "for"; + case mp_start_forsuffixes_code: return "forsuffixes"; + } + break; + +case mp_only_set_command: + switch (m) { + case mp_random_seed_code : return"randomseed"; + case mp_max_knot_pool_code: return"maxknotpool"; + } + break; + +@ Different macro-absorbing operations have different syntaxes, but they also +have a lot in common. There is a list of special symbols that are to be replaced +by parameter tokens; there is a special command code that ends the definition; +the quotation conventions are identical. Therefore it makes sense to have most of +the work done by a single subroutine. That subroutine is called |scan_toks|. + +The first parameter to |scan_toks| is the command code that will terminate +scanning (either |macro_def| or |iteration|). + +The second parameter, |subst_list|, points to a (possibly empty) list of +non-symbolic nodes whose |info| and |value| fields specify symbol tokens before +and after replacement. The list will be returned to free storage by |scan_toks|. + +The third parameter is simply appended to the token list that is built. And the +final parameter tells how many of the special operations |\#\AT!|, |\AT!|, +and |\AT!\#| are to be replaced by suffix parameters. When such parameters are +present, they are called |(SUFFIX0)|, |(SUFFIX1)|, and |(SUFFIX2)|. + +@<Types...@>= +typedef struct mp_subst_list_item { + mp_name_type_type info_mod; + int value_mod; + int value_data; + int padding; + mp_sym info; + struct mp_subst_list_item *link; +} mp_subst_list_item; + +@ @c +static mp_node mp_scan_toks (MP mp, mp_command_code terminator, mp_subst_list_item * subst_list, mp_node tail_end, int suffix_count) +{ + int cur_data; + int cur_data_mod = 0; + mp_node p = mp->hold_head; /* tail of the token list being built */ + int balance = 1; /* left delimiters minus right delimiters */ + mp_link(mp->hold_head) = NULL; + while (1) { + get_t_next(mp); + cur_data = -1; + if (cur_sym != NULL) { + @<Substitute for |cur_sym|, if it's on the |subst_list|@> + if (cur_cmd == terminator) { + @<Adjust the balance; |break| if it's zero@> + } else if (cur_cmd == mp_macro_special_command) { + /* Handle quoted symbols, |\#\AT!|, |\AT!|, or |\AT!\#| */ + if (cur_mod == mp_macro_quote_code) { + get_t_next(mp); + } else if (cur_mod <= suffix_count) { + cur_data = cur_mod - 1; + cur_data_mod = mp_suffix_operation; + } + } + } + if (cur_data != -1) { + mp_node pp = mp_new_symbolic_node(mp); + mp_set_sym_info(pp, cur_data); + mp_name_type(pp) = cur_data_mod; + mp_link(p) = pp; + } else { + mp_link(p) = mp_cur_tok(mp); + } + p = mp_link(p); + } + mp_link(p) = tail_end; + while (subst_list) { + mp_subst_list_item *q = subst_list->link; + mp_memory_free(subst_list); + subst_list = q; + } + return mp_link(mp->hold_head); +} + +@ @<Substitute for |cur_sym|...@>= +{ + mp_subst_list_item *q = subst_list; + while (q != NULL) { + if (q->info == cur_sym && q->info_mod == cur_sym_mod) { + cur_data = q->value_data; + cur_data_mod = q->value_mod; + set_cur_cmd(mp_relax_command); + break; + } + q = q->link; + } +} + +@ @<Adjust the balance; |break| if it's zero@>= +if (cur_mod > 0) { + ++balance; +} else { + --balance; + if (balance == 0) + break; +} + +@ Four commands are intended to be used only within macro texts: |quote|, +|\#\AT!|, |\AT!|, and |\AT!\#|. They are variants of a single command code +called |macro_special|. + +@ @<Enumeration types@>= +typedef enum mp_macro_fix_codes { + mp_macro_quote_code, /* |macro_special| modifier for |quote| */ + mp_macro_prefix_code, /* |macro_special| modifier for |\#\AT!| */ + mp_macro_at_code, /* |macro_special| modifier for |\AT!| */ + mp_macro_suffix_code, /* |macro_special| modifier for |\AT!\#| */ +} mp_macro_fix_codes; + +@ @<Put each...@>= +mp_primitive(mp, "quote", mp_macro_special_command, mp_macro_quote_code); +@:quote_}{|quote| primitive@> +mp_primitive(mp, "#@@", mp_macro_special_command, mp_macro_prefix_code); +@:]]]\#\AT!_}{|\#\AT!| primitive@> +mp_primitive(mp, "@@", mp_macro_special_command, mp_macro_at_code); +@:]]]\AT!_}{|\AT!| primitive@> +mp_primitive(mp, "@@#", mp_macro_special_command, mp_macro_suffix_code); +@:]]]\AT!\#_}{|\AT!\#| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_macro_special_command: + switch (m) { + case mp_macro_prefix_code: return "#@@"; + case mp_macro_at_code : return "@@"; + case mp_macro_suffix_code: return "@@#"; + case mp_macro_quote_code : return "quote"; + } + break; + +@ Here is a routine that's used whenever a token will be redefined. If the user's +token is unredefinable, the |mp->frozen_inaccessible| token is substituted; the +latter is redefinable but essentially impossible to use, hence \MP's tables won't +get fouled up. + +@c +static void mp_get_symbol (MP mp) +{ + /* sets |cur_sym| to a safe symbol */ + RESTART: + get_t_next(mp); + if ((cur_sym == NULL) || mp_is_frozen(mp, cur_sym)) { + const char *hlp = NULL; + if (cur_sym != NULL) { + hlp = + "Sorry: You can't redefine my error-recovery tokens. I've inserted an\n" + "inaccessible symbol so that your definition will be completed without\n" + "mixing me up too badly."; + } else { + hlp = + "Sorry: You can't redefine a number, string, or expr. I've inserted an\n" + "inaccessible symbol so that your definition will be completed without\n" + "mixing me up too badly."; + if (cur_cmd == mp_string_command) { + delete_str_ref(cur_mod_str); + } + } + set_cur_sym(mp->frozen_inaccessible); + mp_ins_error(mp, "Missing symbolic token inserted", hlp); + @.Missing symbolic token...@> + goto RESTART; + } +} + + +@ Before we actually redefine a symbolic token, we need to clear away its former +value, if it was a variable. The following stronger version of |get_symbol| does +that. + +@c +static void mp_get_clear_symbol (MP mp) +{ + mp_get_symbol(mp); + mp_clear_symbol(mp, cur_sym, 0); +} + +@ Here's another little subroutine; it checks that an equals sign or assignment +sign comes along at the proper place in a macro definition. + +@c +static void mp_check_equals (MP mp) +{ + if (cur_cmd != mp_equals_command && cur_cmd != mp_assignment_command) { + mp_back_error( + mp, + "Missing '=' has been inserted", + "The next thing in this 'def' should have been '=', because I've already looked at\n" + "the definition heading. But don't worry; I'll pretend that an equals sign was\n" + "present. Everything from here to 'enddef' will be the replacement text of this\n" + "macro." + ); + @.Missing `='@> + } +} + +@ A |primarydef|, |secondarydef|, or |tertiarydef| is rather easily handled +now that we have |scan_toks|. In this case there are two parameters, which will +be |EXPR0| and |EXPR1|. + +@c +static void mp_make_op_def (MP mp, int code) +{ + mp_node q, r; + mp_command_code m = (code == mp_primary_def_code) ? mp_primary_def_command : (code == mp_secondary_def_code ? mp_secondary_def_command : mp_tertiary_def_command); + mp_subst_list_item *qm = NULL; + mp_subst_list_item *qn = NULL; + mp_get_symbol(mp); + qm = mp_memory_allocate(sizeof(mp_subst_list_item)); + qm->link = NULL; + qm->info = cur_sym; + qm->info_mod = cur_sym_mod; + qm->value_data = 0; + qm->value_mod = mp_expr_operation; + mp_get_clear_symbol(mp); + mp->warning_info = cur_sym; + mp_get_symbol(mp); + qn = mp_memory_allocate(sizeof(mp_subst_list_item)); + qn->link = qm; + qn->info = cur_sym; + qn->info_mod = cur_sym_mod; + qn->value_data = 1; + qn->value_mod = mp_expr_operation; + get_t_next(mp); + mp_check_equals(mp); + mp->scanner_status = mp_op_defining_state; + q = mp_new_symbolic_node(mp); + mp_set_ref_count(q, 0); + r = mp_new_symbolic_node(mp); + mp_link(q) = r; + mp_set_sym_info(r, mp_general_macro); + mp_name_type(r) = mp_macro_operation; + mp_link(r) = mp_scan_toks(mp, mp_macro_def_command, qn, NULL, 0); + mp->scanner_status = mp_normal_state; + set_eq_type(mp->warning_info, m); + set_equiv_node(mp->warning_info, q); + mp_get_x_next(mp); +} + +@ Parameters to macros are introduced by the keywords |expr|, |suffix|, +|text|, |primary|, |secondary|, and |tertiary|. + +@<Put each...@>= +mp_primitive(mp, "expr", mp_parameter_commmand, mp_expr_parameter); +@:expr_}{|expr| primitive@> +mp_primitive(mp, "suffix", mp_parameter_commmand, mp_suffix_parameter); +@:suffix_}{|suffix| primitive@> +mp_primitive(mp, "text", mp_parameter_commmand, mp_text_parameter); +@:text_}{|text| primitive@> +mp_primitive(mp, "primary", mp_parameter_commmand, mp_primary_macro); +@:primary_}{|primary| primitive@> +mp_primitive(mp, "secondary", mp_parameter_commmand, mp_secondary_macro); +@:secondary_}{|secondary| primitive@> +mp_primitive(mp, "tertiary", mp_parameter_commmand, mp_tertiary_macro); +@:tertiary_}{|tertiary| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_parameter_commmand: + switch (m) { + case mp_expr_parameter : return "expr"; + case mp_suffix_parameter: return "suffix"; + case mp_text_parameter : return "text"; + case mp_primary_macro : return "primary"; + case mp_secondary_macro : return "secondary"; + default : return "tertiary"; + } + break; + +@ Let's turn next to the more complex processing associated with |def| and +|vardef|. When the following procedure is called, |cur_mod| should be either +|start_def| or |var_def|. + +Note that although the macro scanner allows |def = := enddef| and |def := = +enddef|; |def = = enddef| and |def := := enddef| will generate an error because +by the time the second of the two identical tokens is seen, its meaning has +already become undefined. + +@c +static void mp_scan_def (MP mp, int code) +{ + int n; /* the number of special suffix parameters */ + int k; /* the total number of parameters */ + mp_subst_list_item *r = NULL; /* parameter-substitution list */ + mp_subst_list_item *rp = NULL; /* parameter-substitution list */ + mp_node q; /* tail of the macro token list */ + mp_node p; /* temporary storage */ + int sym_type; /* |expr_sym|, |suffix_sym|, or |text_sym| */ + mp_sym l_delim, r_delim; /* matching delimiters */ + int c = mp_general_macro; /* the kind of macro we're defining */ + mp_link(mp->hold_head) = NULL; + q = mp_new_symbolic_node(mp); + mp_set_ref_count(q, 0); + r = NULL; + /* + Scan the token or variable to be defined; set |n|, |scanner_status|, and + |warning_info| + */ + if (code == mp_def_code) { + mp_get_clear_symbol(mp); + mp->warning_info = cur_sym; + get_t_next(mp); + mp->scanner_status = mp_op_defining_state; + n = 0; + set_eq_type(mp->warning_info, mp_defined_macro_command); + set_equiv_node(mp->warning_info, q); + } else { + /* |var_def| */ + p = mp_scan_declared_variable(mp); + mp_flush_variable(mp, equiv_node(mp_get_sym_sym(p)), mp_link(p), 1); + mp->warning_info_node = mp_find_variable(mp, p); + mp_flush_node_list(mp, p); + if (mp->warning_info_node == NULL) { + mp_error( + mp, + "This variable already starts with a macro", + "After 'vardef a' you can't say 'vardef a.b'. So I'll have to discard this\n" + "definition." + ); + mp->warning_info_node = mp->bad_vardef; + } + mp->scanner_status = mp_var_defining_state; + n = 2; + if (cur_cmd == mp_macro_special_command && cur_mod == mp_macro_suffix_code) { + /* |\AT!\#| */ + n = 3; + get_t_next(mp); + } + mp_type(mp->warning_info_node) = mp_unsuffixed_macro_type - 2 + n; + /* |mp_suffixed_macro=mp_unsuffixed_macro+1| */ + mp_set_value_node(mp->warning_info_node, q); + } + k = n; + if (cur_cmd == mp_left_delimiter_command) { + /* Absorb delimited parameters, putting them into lists |q| and |r| */ + do { + l_delim = cur_sym; + r_delim = equiv_sym(cur_sym); + get_t_next(mp); + if (cur_cmd == mp_parameter_commmand) { + switch (cur_mod) { + case mp_expr_parameter: + sym_type = mp_expr_operation; + goto OKAY; + break; + case mp_suffix_parameter: + sym_type = mp_suffix_operation; + goto OKAY; + break; + case mp_text_parameter: + sym_type = mp_text_operation; + goto OKAY; + break; + default: + break; + } + } + mp_back_error( + mp, + "Missing parameter type; 'expr' will be assumed", + "You should've had 'expr' or 'suffix' or 'text' here." + ); + sym_type = mp_expr_operation; + OKAY: + /* Absorb parameter tokens for type |sym_type| */ + do { + mp_link(q) = mp_new_symbolic_node(mp); + q = mp_link(q); + mp_name_type(q) = sym_type; + mp_set_sym_info(q, k); + mp_get_symbol(mp); + rp = mp_memory_allocate(sizeof(mp_subst_list_item)); + rp->link = NULL; + rp->value_data = k; + rp->value_mod = sym_type; + rp->info = cur_sym; + rp->info_mod = cur_sym_mod; + mp_check_param_size(mp, k); + ++k; + rp->link = r; + r = rp; + get_t_next(mp); + } while (cur_cmd == mp_comma_command); + + mp_check_delimiter(mp, l_delim, r_delim); + get_t_next(mp); + } while (cur_cmd == mp_left_delimiter_command); + + } + if (cur_cmd == mp_parameter_commmand) { + /* Absorb undelimited parameters, putting them into list |r| */ + rp = mp_memory_allocate(sizeof(mp_subst_list_item)); + rp->link = NULL; + rp->value_data = k; + switch (cur_mod) { + case mp_expr_parameter: + rp->value_mod = mp_expr_operation; + c = mp_expr_macro; + break; + case mp_suffix_parameter: + rp->value_mod = mp_suffix_operation; + c = mp_suffix_macro; + break; + case mp_text_parameter: + rp->value_mod = mp_text_operation; + c = mp_text_macro; + break; + default: + c = cur_mod; + rp->value_mod = mp_expr_operation; + break; + } + mp_check_param_size(mp, k); + ++k; + mp_get_symbol(mp); + rp->info = cur_sym; + rp->info_mod = cur_sym_mod; + rp->link = r; + r = rp; + get_t_next(mp); + if (c == mp_expr_macro && cur_cmd == mp_of_command) { + c = mp_of_macro; + rp = mp_memory_allocate(sizeof(mp_subst_list_item)); + rp->link = NULL; + mp_check_param_size(mp, k); + rp->value_data = k; + rp->value_mod = mp_expr_operation; + mp_get_symbol(mp); + rp->info = cur_sym; + rp->info_mod = cur_sym_mod; + rp->link = r; + r = rp; + get_t_next(mp); + } + } + mp_check_equals(mp); + p = mp_new_symbolic_node(mp); + mp_set_sym_info(p, c); + mp_name_type(p) = mp_macro_operation; + mp_link(q) = p; + /* + Attach the replacement text to the tail of node |p|. We don't put + |mp->frozen_end_group| into the replacement text of a |vardef|, + because the user may want to redefine |endgroup|. + */ + if (code == mp_def_code) { + mp_link(p) = mp_scan_toks(mp, mp_macro_def_command, r, NULL, (int) n); + } else { + mp_node qq = mp_new_symbolic_node(mp); + mp_set_sym_sym(qq, mp->bg_loc); + mp_link(p) = qq; + p = mp_new_symbolic_node(mp); + mp_set_sym_sym(p, mp->eg_loc); + mp_link(qq) = mp_scan_toks(mp, mp_macro_def_command, r, p, (int) n); + } + if (mp->warning_info_node == mp->bad_vardef) { + mp_flush_token_list(mp, mp_get_value_node(mp->bad_vardef)); + } + mp->scanner_status = mp_normal_state; + mp_get_x_next(mp); +} + +@ @<Glob...@>= +mp_sym bg_loc; +mp_sym eg_loc; /* hash addresses of |begingroup| and |endgroup| */ + +@ @<Initialize table entries@>= +mp->bad_vardef = mp_new_value_node(mp); +mp_name_type(mp->bad_vardef) = mp_root_operation; +mp_set_value_sym(mp->bad_vardef, mp->frozen_bad_vardef); + +@ @<Free table entries@>= +mp_free_value_node(mp, mp->bad_vardef); + +@* Expanding the next token. + +Only a few command codes |<min_command| can possibly be returned by |get_t_next|; +in increasing order, they are |if_test|, |fi_or_else|, |input|, |iteration|, +|repeat_loop|, |exit_test|, |relax|, |scan_tokens|, |run_script|, |expand_after|, +and |defined_macro|. + +\MP\ usually gets the next token of input by saying |get_x_next|. This is like +|get_t_next| except that it keeps getting more tokens until finding +|cur_cmd>=min_command|. In other words, |get_x_next| expands macros and removes +conditionals or iterations or input instructions that might be present. + +It follows that |get_x_next| might invoke itself recursively. In fact, there is +massive recursion, since macro expansion can involve the scanning of arbitrarily +complex expressions, which in turn involve macro expansion and conditionals, etc. +@^recursion@> + +Therefore it's necessary to declare a whole bunch of |forward| procedures at this +point, and to insert some other procedures that will be invoked by |get_x_next|. + +@<Declarations@>= +static void mp_scan_primary (MP mp); +static void mp_scan_secondary (MP mp); +static void mp_scan_tertiary (MP mp); +static void mp_scan_expression (MP mp); +static void mp_scan_suffix (MP mp); +static void mp_pass_text (MP mp); +static void mp_conditional (MP mp); +static void mp_start_input (MP mp); +static void mp_begin_iteration (MP mp); +static void mp_resume_iteration (MP mp); +static void mp_stop_iteration (MP mp); + +@ A recursion depth counter is used to discover infinite recursions. (Near) +infinite recursion is a problem because it translates into C function calls that +eat up the available call stack. A better solution would be to depend on signal +trapping, but that is problematic when Metapost is used as a library. + +@<Global...@>= +int expand_depth_count; /* current expansion depth */ +int expand_depth; /* current expansion depth */ + +@ The limit is set at |10000|, which should be enough to allow normal usages of +metapost while preventing the most obvious crashes on most all operating systems, +but the value can be raised if the runtime system allows a larger C stack. +@^system dependencies@> + +@<Set initial...@>= +mp->expand_depth = 10000; + +@ Even better would be if the system allows discovery of the amount of space +available on the call stack. @^system dependencies@> + +In any case, when the limit is crossed, that is a fatal error. + +@c +static void mp_check_expansion_depth (MP mp) +{ + if (++mp->expand_depth_count >= mp->expand_depth) { + if (mp->interaction >= mp_error_stop_mode) { + mp->interaction=mp_scroll_mode; /* no more interaction */ + } + mp_error( + mp, + "Maximum expansion depth reached", + "Recursive macro expansion cannot be unlimited because of runtime stack\n" + "constraints. The limit is 10000 recursion levels in total." + ); + mp->history=mp_fatal_error_stop; + mp_jump_out(mp); + } +} + +@ An auxiliary subroutine called |expand| is used by |get_x_next| +when it has to do exotic expansion commands. + +@c +static void mp_expand (MP mp) +{ + mp_check_expansion_depth(mp); + if (number_greater(internal_value(mp_tracing_commands_internal), unity_t) && cur_cmd != mp_defined_macro_command) { + mp_show_cmd_mod(mp, cur_cmd, cur_mod); + } + switch (cur_cmd) { + case mp_if_test_command: + mp_conditional(mp); /* this procedure is discussed in Part 36 below */ + break; + case mp_fi_or_else_command: + @<Terminate the current conditional and skip to |fi|@> + break; + case mp_input_command: + @<Initiate or terminate input from a file@> + break; + case mp_iteration_command: + if (cur_mod == mp_end_for_code) { + @<Scold the user for having an extra |endfor|@> + } else { + mp_begin_iteration(mp); /* this procedure is discussed in Part 37 below */ + } + break; + case mp_repeat_loop_command: + @<Repeat a loop@> + break; + case mp_exit_test_command: + @<Exit a loop if the proper time has come@> + break; + case mp_relax_command: + break; + case mp_expand_after_command: + @<Expand the token after the next token@> + break; + case mp_scan_tokens_command: + @<Put a string into the input buffer@> + break; + case mp_runscript_command: + @<Put a script result string into the input buffer@> + break; + case mp_maketext_command: + @<Put a maketext result string into the input buffer@> + break; + case mp_defined_macro_command: + mp_macro_call(mp, cur_mod_node, NULL, cur_sym); + break; + default: + break; + }; + mp->expand_depth_count--; +} + +@ @<Scold the user...@>= +{ + mp_error( + mp, + "Extra 'endfor'", + "I'm not currently working on a for loop, so I had better not try to end anything." + ); + @.Extra `endfor'@> +} + +@ The processing of |input| involves the |start_input| subroutine, which will +be declared later; the processing of |endinput| is trivial. + +@<Put each...@>= +mp_primitive(mp, "input", mp_input_command, 0); +@:input_}{|input| primitive@> +mp_primitive(mp, "endinput", mp_input_command, 1); +@:end_input_}{|endinput| primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case mp_input_command: + return m == 0 ? "input" : "endinput"; + +@ @<Initiate or terminate input...@>= +if (cur_mod > 0) { + mp->force_eof = 1; +} else { + mp_start_input(mp); +} + +@ We'll discuss the complicated parts of loop operations later. For now it +suffices to know that there's a global variable called |loop_ptr| that will be +|NULL| if no loop is in progress. + +@<Repeat a loop@>= +{ + while (token_state && (nloc == NULL)) { + mp_end_token_list(mp); /* conserve stack space */ + } + if (mp->loop_ptr == NULL) { + mp_error( + mp, + "Lost loop", + "I'm confused; after exiting from a loop, I still seem to want to repeat it. I'll\n" + "try to forget the problem." + ); + @.Lost loop@> + } else { + mp_resume_iteration(mp); /* this procedure is in Part 37 below */ + } +} + +@ @<Exit a loop if the proper time has come@>= +{ + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_boolean_type) { + do_boolean_error(mp); + } + if (number_greater(internal_value(mp_tracing_commands_internal), unity_t)) { + mp_show_cmd_mod(mp, mp_nullary_command, cur_exp_value_boolean); + } + if (cur_exp_value_boolean == mp_true_operation) { + if (mp->loop_ptr != NULL) { + @<Exit prematurely from an iteration@> + } else if (cur_cmd == mp_semicolon_command) { + mp_error( + mp, + "No loop is in progress", + "Why say 'exitif' when there's nothing to exit from?" + ); + } else { + mp_back_error( + mp, + "No loop is in progress", + "Why say 'exitif' when there's nothing to exit from?" + ); + @.No loop is in progress@> + } + } else if (cur_cmd != mp_semicolon_command) { + mp_back_error( + mp, + "Missing ';' has been inserted", + "After 'exitif <boolean exp>' I expect to see a semicolon. I shall pretend that\n" + "one was there." + ); + @.Missing `;'@> + } +} + +@ Here we use the fact that |forever_text| is the only |token_type| that is less +than |loop_text|. + +@<Exit prematurely...@>= +mp_node p = NULL; +do { + if (file_state) { + mp_end_file_reading(mp); + } else { + if (token_type <= mp_loop_text) { + p = nstart; + } + mp_end_token_list(mp); + } +} while (p == NULL); +if (p != mp->loop_ptr->info) { + mp_fatal_error(mp, "*** (loop confusion)"); + @.loop confusion@> +} +mp_stop_iteration(mp); /* this procedure is in Part 34 below */ + +@ @<Expand the token after the next token@>= +{ + mp_node p; + get_t_next(mp); + p = mp_cur_tok(mp); + get_t_next(mp); + if (cur_cmd < mp_min_command) { + mp_expand(mp); + } else { + mp_back_input(mp); + } + mp_begin_token_list(mp, p, mp_backed_up_text); +} + +@ @<Put a string into the input buffer@>= +{ + mp_get_x_next(mp); + mp_scan_primary(mp); + if (mp->cur_exp.type != mp_string_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Not a string", + "I'm going to flush this expression, since scantokens should be followed by a\n" + "known string." + ); + @.Not a string@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + mp_back_input(mp); + if (cur_exp_str->len > 0) { + @<Pretend we're reading a new one-line file@> + } + } +} + +@ @<Declarations@>= +static void check_script_result (MP mp, char *s); + +@c +void check_script_result (MP mp, char *s) +{ + if (s) { + size_t size = strlen(s); + if (size > 0) { + size_t k ; + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_begin_file_reading(mp); + name = is_scantok; + mp->last = mp->first; + k = mp->first + size; + if (k >= mp->max_buf_stack) { + while (k >= mp->buf_size) { + mp_reallocate_buffer(mp, (mp->buf_size + (mp->buf_size / 4))); + } + mp->max_buf_stack = k + 1; + } + limit = (int) k; + memcpy((mp->buffer + mp->first), s, size); + mp->buffer[limit] = '%'; + mp->first = (size_t) (limit + 1); + loc = start; + mp_flush_cur_exp(mp, new_expr); + } + lmt_memory_free(s); + } +} + +@ @<Put a script result string into the input buffer@>= +{ + if (mp->extensions) { + mp_get_x_next(mp); + mp_scan_primary(mp); + switch (mp->cur_exp.type) { + case mp_string_type: + { + mp_back_input(mp); + if (cur_exp_str->len > 0) { + check_script_result(mp, mp->run_script(mp, (const char*) cur_exp_str->str, cur_exp_str->len, 0)); + } + } + break; + case mp_numeric_type: + case mp_known_type: + { + int n = 0 ; + mp_back_input(mp); + n = (int) number_to_scaled (cur_exp_value_number) / 65536; + if (n > 0) { + check_script_result(mp, mp->run_script(mp, NULL, 0, n)); + } + } + break; + default: + { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Not a string", + "I'm going to flush this expression, since runscript should be followed by a known\n" + "string or number." + ); + @.Not a string@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + break; + } + } +} + +@ The |texscriptmode| parameter controls how spaces and newlines get honoured in +|btex| or |verbatimtex| ... |etex|. The default value is~1. Possible values are: +0: no newlines, 1: newlines in |verbatimtex|, 2: newlines in |verbatimtex| and +|etex|, 3: no leading and trailing strip in |verbatimtex|, 4: no leading and +trailing strip in |verbatimtex| and |btex|. That way the Lua handler can do what +it likes. An |etex| has to be followed by a space or |;| or be at the end of a +line and preceded by a space or at the beginning of a line. + +@<Pass btex ... etex to script@>= +char *txt = NULL; +char *ptr = NULL; +int slin = line; +int size = 0; +int done = 0; +int mode = round_unscaled(internal_value(mp_texscriptmode_internal)) ; /* default: 1 */ +int verb = cur_mod == mp_verbatim_code; +int first; +/* we had a (mandate) trailing space */ +if (loc <= limit && mp->char_class[mp->buffer[loc]] == mp_space_class) { + ++loc; +} else { + /* maybe issue an error message and quit */ +} +/* we loop over lines */ +first = loc; +while (1) { + /* we don't need to check when we have less than 4 characters left */ + if (loc < limit - 4) { + if (mp->buffer[loc] == 'e') { + ++loc; + if (mp->buffer[loc] == 't') { + ++loc; + if (mp->buffer[loc] == 'e') { + ++loc; + if (mp->buffer[loc] == 'x') { + /* let's see if we have the right boundary */ + if (first == (loc - 3)) { + /* when we're at the start of a line no leading space is required */ + done = 1; + } else if (mp->char_class[mp->buffer[loc - 4]] == mp_space_class) { + /* when we're beyond the start of a line a leading space is required */ + done = 2; + } + if (done) { + if ((loc + 1) <= limit) { + int c = mp->char_class[mp->buffer[loc + 1]] ; + if (c != mp_letter_class) { + ++loc; + /* we're past the 'x' */ + break; + } else { + /* this is no valid etex */ + done = 0; + } + } else { + /* when we're at the end of a line we're ok */ + ++loc; + /* we're past the 'x' */ + break; + } + } + } + } + } + } + } + /* no etex seen (yet) */ + if (loc >= limit) { + if (size) { + txt = mp_memory_reallocate(txt, (size_t) (size + limit - first + 1)); + } else { + txt = mp_memory_allocate((size_t) (limit - first + 1)); + } + memcpy(txt + size, mp->buffer + first, limit - first); + size += limit - first + 1; + if (mode <= 0) { + txt[size - 1] = ' '; + } else if (verb) { + /* modes $\geq 1$ permit a newline in verbatimtex */ + txt[size - 1] = '\n'; + } else if (mode >= 2) { + /* modes $\geq 2$ permit a newline in btex */ + txt[size - 1] = '\n'; + } else { + txt[size - 1] = ' '; + } + if (mp_move_to_next_line(mp)) { + /* we abort the scanning */ + goto FATAL_ERROR; + } + first = loc; + } else { + ++loc; + } +} +if (done) { + /* we're past the 'x' */ + int l = loc - 5 ; // 4 + int n = l - first + 1 ; + /* we're before the 'etex' */ + if (done == 2) { + /* we had ' etex' */ + l -= 1; + n -= 1; + /* we're before the ' etex' */ + } + if (size) { + txt = mp_memory_reallocate(txt, (size_t) (size + n + 1)); + } else { + txt = mp_memory_allocate((size_t) (n + 1)); + } + memcpy(txt + size, mp->buffer + first, n); /* 0 */ + size += n; + if (verb && mode >= 3) { + /* don't strip verbatimtex */ + txt[size] = '\0'; + ptr = txt; + } else if (mode >= 4) { + /* don't strip btex */ + txt[size] = '\0'; + ptr = txt; + } else { + /* strip trailing whitespace, we have a |'\0'| so we are off by one */ + while ((size > 1) && (mp->char_class[(unsigned char) txt[size-1]] == mp_space_class || txt[size-1] == '\n')) { + --size; + } + /* prune the string */ + txt[size] = '\0'; + /* strip leading whitespace */ + ptr = txt; + while ((size > 1) && (mp->char_class[(unsigned char) ptr[0]] == mp_space_class || ptr[0] == '\n')) { + ++ptr; + --size; + } + } + /* action */ + check_script_result(mp, mp->make_text(mp, ptr, size, verb)); + mp_memory_free(txt); + /* really needed */ + mp_get_next(mp); + return; +} +/* + We don't recover because in practice the graphic will be broken anyway and + we're not really interacting in mplib .. just fix the input. +*/ +FATAL_ERROR: +{ + /* line numbers are not always meaningfull so we can get a 0 reported */ + char msg[256]; + if (slin > 0) { + mp_snprintf(msg, 256, "No matching 'etex' for '%stex'.", verb ? "verbatim" : "b"); + } else { + mp_snprintf(msg, 256, "No matching 'etex' for '%stex' in line %d.", verb ? "verbatim" : "b",slin); + } + mp_error(mp, msg, "An 'etex' is missing at this input level, nothing gets done."); + mp_memory_free(txt); +} + +@ @<Put a maketext result string into the input buffer@>= +{ + if (mp->extensions) { + mp_get_x_next(mp); + mp_scan_primary(mp); + if (mp->cur_exp.type == mp_string_type) { + mp_back_input(mp); + if (cur_exp_str->len > 0) { + check_script_result(mp, mp->make_text(mp, (const char*) cur_exp_str->str, cur_exp_str->len, 0)); + } + } else { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Not a string", + "I'm going to flush this expression, since 'maketext' should be followed by a\n" + "known string." + ); + @.Not a string@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + } +} + +@ @<Pretend we're reading a new one-line file@>= +size_t k; /* something that we hope is |<=buf_size| */ +size_t j; /* index into |str_pool| */ +mp_value new_expr; +memset(&new_expr, 0, sizeof(mp_value)); +new_number(new_expr.data.n); +mp_begin_file_reading(mp); +name = is_scantok; +k = mp->first + (size_t) cur_exp_str->len; +if (k >= mp->max_buf_stack) { + while (k >= mp->buf_size) { + mp_reallocate_buffer(mp, (mp->buf_size + (mp->buf_size / 4))); + } + mp->max_buf_stack = k + 1; +} +j = 0; +limit = (int) k; +while (mp->first < (size_t) limit) { + mp->buffer[mp->first] = *(cur_exp_str->str + j); + j++; + ++mp->first; +} +mp->buffer[limit] = '%'; +mp->first = (size_t) (limit + 1); +loc = start; +mp_flush_cur_exp(mp, new_expr); + +@ Here finally is |get_x_next|. + +The expression scanning routines to be considered later communicate via the +global quantities |cur_type| and |cur_exp|; we must be very careful to save and +restore these quantities while macros are being expanded. @^inner loop@> + +@<Declarations@>= +static void mp_get_x_next (MP mp); + +@ @c +static void mp_get_x_next (MP mp) +{ + get_t_next(mp); + if (cur_cmd < mp_min_command) { + /* the capsule to save |cur_type| and |cur_exp| */ + mp_node save_exp = mp_stash_cur_exp(mp); + do { + if (cur_cmd == mp_defined_macro_command) { + mp_macro_call(mp, cur_mod_node, NULL, cur_sym); + } else { + mp_expand(mp); + } + get_t_next(mp); + } while (cur_cmd < mp_min_command); + /* that restores |cur_type| and |cur_exp| */ + mp_unstash_cur_exp(mp, save_exp); + } +} + +@ Now let's consider the |macro_call| procedure, which is used to start up all +user-defined macros. Since the arguments to a macro might be expressions, +|macro_call| is recursive. @^recursion@> + +The first parameter to |macro_call| points to the reference count of the token +list that defines the macro. The second parameter contains any arguments that +have already been parsed (see below). The third parameter points to the symbolic +token that names the macro. If the third parameter is |NULL|, the macro was +defined by |vardef|, so its name can be reconstructed from the prefix and +\quote {at} arguments found within the second parameter. + +What is this second parameter? It's simply a linked list of symbolic items, whose +|info| fields point to the arguments. In other words, if |arg_list=NULL|, no +arguments have been scanned yet; otherwise |mp_info(arg_list)| points to the +first scanned argument, and |mp_link(arg_list)| points to the list of further +arguments (if any). + +Arguments of type |expr| are so-called capsules, which we will discuss later +when we concentrate on expressions; they can be recognized easily because their +|link| field is |void|. Arguments of type |suffix| and |text| are token lists +without reference counts. + +@ After argument scanning is complete, the arguments are moved to the +|param_stack|. (They can't be put on that stack any sooner, because the stack is +growing and shrinking in unpredictable ways as more arguments are being +acquired.) Then the macro body is fed to the scanner; i.e., the replacement text +of the macro is placed at the top of the \MP's input stack, so that |get_t_next| +will proceed to read it next. + +@<Declarations@>= +static void mp_macro_call (MP mp, mp_node def_ref, mp_node arg_list, mp_sym macro_name); + +@ This invokes a user-defined control sequence. + +@c +static void mp_macro_call (MP mp, mp_node def_ref, mp_node arg_list, mp_sym macro_name) +{ + int n; /* the number of arguments */ + mp_node tail = 0; /* tail of the argument list */ + mp_sym l_delim = NULL; /* a delimiter pair */ + mp_sym r_delim = NULL; /* a delimiter pair */ + mp_node r = mp_link(def_ref); /* current node in the macro's token list */ + mp_add_mac_ref(def_ref); + if (arg_list == NULL) { + n = 0; + } else { + @<Determine the number |n| of arguments already supplied, and set |tail| to the tail of |arg_list|@> + } + if (number_positive(internal_value(mp_tracing_macros_internal))) { + @<Show the text of the macro being expanded, and the existing arguments@> + } + @<Scan the remaining arguments, if any; set |r| to the first token of the replacement text@> + @<Feed the arguments and replacement text to the scanner@> +} + +@ @<Show the text of the macro...@>= +mp_begin_diagnostic(mp); +mp_print_ln(mp); +mp_print_macro_name(mp, arg_list, macro_name); +if (n == 3) { + mp_print_str(mp, "@@#"); /* indicate a suffixed macro */ +} +mp_show_macro (mp, def_ref, NULL); +if (arg_list != NULL) { + mp_node p = arg_list; + n = 0; + do { + mp_node q = (mp_node) mp_get_sym_sym(p); + mp_print_arg(mp, q, n, 0, 0); + ++n; + p = mp_link(p); + } while (p != NULL); +} +mp_end_diagnostic(mp, 0); + +@ @<Declarations@>= +static void mp_print_macro_name (MP mp, mp_node a, mp_sym n); + +@ @c +static void mp_print_macro_name (MP mp, mp_node a, mp_sym n) +{ + if (n) { + mp_print_mp_str(mp,text(n)); + } else { + mp_node p = (mp_node) mp_get_sym_sym(a); + if (p) { + mp_node q = p; /* they traverse the first part of |a| */ + while (mp_link(q) != NULL) { + q = mp_link(q); + } + mp_link(q) = (mp_node) mp_get_sym_sym(mp_link(a)); + mp_show_token_list(mp, p, NULL); + mp_link(q) = NULL; + } else { + mp_print_mp_str(mp,text(mp_get_sym_sym((mp_node) mp_get_sym_sym(mp_link(a))))); + } + } +} + +@ @<Declarations@>= +static void mp_print_arg (MP mp, mp_node q, int n, int b, int bb); + +@ @c +static void mp_print_arg (MP mp, mp_node q, int n, int b, int bb) +{ + if (q && mp_link(q) == MP_VOID) { + mp_print_nl(mp, "(EXPR"); + } else if ((bb < mp_text_operation) && (b != mp_text_macro)) { + mp_print_nl(mp, "(SUFFIX"); + } else { + mp_print_nl(mp, "(TEXT"); + } + mp_print_int(mp, n); + mp_print_str(mp, ")<-"); + if (q && mp_link(q) == MP_VOID) { + mp_print_exp(mp, q, 1); + } else { + mp_show_token_list(mp, q, NULL); + } +} + +@ @<Determine the number |n| of arguments already supplied...@>= +n = 1; +tail = arg_list; +while (mp_link(tail) != NULL) { + ++n; + tail = mp_link(tail); +} + +@ @<Scan the remaining arguments, if any; set |r|...@>= +set_cur_cmd(mp_comma_command + 1); /* anything |<>comma| will do */ +while (mp_name_type(r) == mp_expr_operation || mp_name_type(r) == mp_suffix_operation || mp_name_type(r) == mp_text_operation) { + @<Scan the delimited argument represented by |mp_get_sym_info(r)|@> + r = mp_link(r); +} +if (cur_cmd == mp_comma_command) { + char msg[256]; + mp_string rname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_macro_name(mp, arg_list, macro_name); + rname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Too many arguments to %s; Missing '%s' has been inserted", + mp_str(mp, rname), mp_str(mp, text(r_delim))); + delete_str_ref(rname); + @.Too many arguments...@> + @.Missing `)'...@> + mp_error( + mp, + msg, + "I'm going to assume that the comma I just read was a right delimiter, and then:\n" + "I'll begin expanding the macro." + ); +} +if (mp_get_sym_info(r) != mp_general_macro) { + @<Scan undelimited argument(s)@> +} +r = mp_link(r); + +@ At this point, the reader will find it advisable to review the explanation of +token list format that was presented earlier, paying special attention to the +conventions that apply only at the beginning of a macro's token list. + +On the other hand, the reader will have to take the expression-parsing aspects of +the following program on faith; we will explain |cur_type| and |cur_exp| later. +(Several things in this program depend on each other, and it's necessary to jump +into the circle somewhere.) + +@<Scan the delimited argument represented by |mp_get_sym_info(r)|@>= +if (cur_cmd != mp_comma_command) { + mp_get_x_next(mp); + if (cur_cmd != mp_left_delimiter_command) { + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_macro_name(mp, arg_list, macro_name); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Missing argument to %s", mp_str(mp, sname)); + @.Missing argument...@> + delete_str_ref(sname); + if (mp_name_type(r) == mp_suffix_operation || mp_name_type(r) == mp_text_operation) { + mp_set_cur_exp_value_number(mp, &zero_t); /* todo: this was |null| */ + mp->cur_exp.type = mp_token_list_type; + } else { + mp_set_cur_exp_value_number(mp, &zero_t); + mp->cur_exp.type = mp_known_type; + } + mp_back_error( + mp, + msg, + "That macro has more parameters than you thought. I'll continue by pretending that\n" + "each missing argument is either zero or null." + ); + set_cur_cmd(mp_right_delimiter_command); + goto FOUND; + } + l_delim = cur_sym; + r_delim = equiv_sym(cur_sym); +} +@<Scan the argument represented by |mp_get_sym_info(r)|@> +if ((cur_cmd != mp_comma_command) && ((cur_cmd != mp_right_delimiter_command) || (equiv_sym(cur_sym) != l_delim))) { + switch (mp_name_type(mp_link(r))) { + case mp_expr_operation: + case mp_suffix_operation: + case mp_text_operation: + { + mp_back_error( + mp, + "Missing ',' has been inserted", + "I've finished reading a macro argument and am about to read another; the\n" + "arguments weren't delimited correctly." + ); + @.Missing `,'@> + set_cur_cmd(mp_comma_command); + } + break; + default: + { + char msg[256]; + mp_snprintf(msg, 256, "Missing '%s' has been inserted", mp_str(mp, text(r_delim))); + @.Missing `)'@> + mp_back_error(mp, msg, "I've gotten to the end of the macro parameter list."); + } + break; + } +} +FOUND: +@<Append the current expression to |arg_list|@> + +@ A |suffix| or |text| parameter will have been scanned as a token list +pointed to by |cur_exp|, in which case we will have |cur_type=token_list|. + +@<Append the current expression to |arg_list|@>= +{ + mp_node p = mp_new_symbolic_node(mp); + if (mp->cur_exp.type == mp_token_list_type) { + mp_set_sym_sym(p, mp->cur_exp.data.node); + } else { + mp_set_sym_sym(p, mp_stash_cur_exp(mp)); + } + if (number_positive(internal_value(mp_tracing_macros_internal))) { + mp_begin_diagnostic(mp); + mp_print_arg(mp, (mp_node) mp_get_sym_sym(p), n, mp_get_sym_info(r), mp_name_type(r)); + mp_end_diagnostic(mp, 0); + } + if (arg_list == NULL) { + arg_list = p; + } else { + mp_link(tail) = p; + } + tail = p; + ++n; +} + +@ @<Scan the argument represented by |mp_get_sym_info(r)|@>= +if (mp_name_type(r) == mp_text_operation) { + mp_scan_text_arg(mp, l_delim, r_delim); +} else { + mp_get_x_next(mp); + if (mp_name_type(r) == mp_suffix_operation) { + mp_scan_suffix(mp); + } else { + mp_scan_expression(mp); + } +} + +@ The parameters to |scan_text_arg| are either a pair of delimiters or zero; the +latter case is for undelimited text arguments, which end with the first semicolon +or |endgroup| or |end| that is not contained in a group. + +@<Declarations@>= +static void mp_scan_text_arg (MP mp, mp_sym l_delim, mp_sym r_delim); + +@ @c +void mp_scan_text_arg (MP mp, mp_sym l_delim, mp_sym r_delim) +{ + int balance = 1; /* excess of |l_delim| over |r_delim| */ + mp->warning_info = l_delim; + mp->scanner_status = mp_absorbing_state; + mp_node p = mp->hold_head; /* list tail */ + mp_link(mp->hold_head) = NULL; + while (1) { + get_t_next(mp); + if (l_delim == NULL) { + @<Adjust the balance for an undelimited argument; |break| if done@> + } else { + @<Adjust the balance for a delimited argument; |break| if done@> + } + mp_link(p) = mp_cur_tok(mp); + p = mp_link(p); + } + mp_set_cur_exp_node(mp, mp_link(mp->hold_head)); + mp->cur_exp.type = mp_token_list_type; + mp->scanner_status = mp_normal_state; +} + +@ @<Adjust the balance for a delimited argument...@>= +if (cur_cmd == mp_right_delimiter_command) { + if (equiv_sym(cur_sym) == l_delim) { + --balance; + if (balance == 0) { + break; + } + } +} else if (cur_cmd == mp_left_delimiter_command) { + if (equiv_sym(cur_sym) == r_delim) { + ++balance; + } +} + +@ @<Adjust the balance for an undelimited...@>= +if (mp_end_of_statement) { + /* |cur_cmd=semicolon|, |end_group|, or |stop| */ + if (balance == 1) { + break; + } else if (cur_cmd == mp_end_group_command) { + --balance; + } +} else if (cur_cmd == mp_begin_group_command) { + ++balance; +} + +@ @<Scan undelimited argument(s)@>= +if (mp_get_sym_info(r) < mp_text_macro) { + mp_get_x_next(mp); + if (mp_get_sym_info(r) != mp_suffix_macro) { + if ((cur_cmd == mp_equals_command) || (cur_cmd == mp_assignment_command)) { + mp_get_x_next(mp); + } + } +} +switch (mp_get_sym_info(r)) { + case mp_primary_macro: + mp_scan_primary(mp); + break; + case mp_secondary_macro: + mp_scan_secondary(mp); + break; + case mp_tertiary_macro: + mp_scan_tertiary(mp); + break; + case mp_expr_macro: + mp_scan_expression(mp); + break; + case mp_of_macro: + { + @<Scan an expression followed by |of| $\langle$primary$\rangle$@> + } + break; + case mp_suffix_macro: + { + @<Scan a suffix with optional delimiters@> + } + break; + case mp_text_macro: + mp_scan_text_arg(mp, NULL, NULL); + break; +} +mp_back_input(mp); +@<Append the current expression to |arg_list|@> + +@ @<Scan an expression followed by |of| $\langle$primary$\rangle$@>= +mp_node p; +mp_scan_expression(mp); +p = mp_new_symbolic_node(mp); +mp_set_sym_sym(p, mp_stash_cur_exp(mp)); +if (number_positive(internal_value(mp_tracing_macros_internal))) { + mp_begin_diagnostic(mp); + mp_print_arg(mp, (mp_node) mp_get_sym_sym(p), n, 0, 0); + mp_end_diagnostic(mp, 0); +} +if (arg_list == NULL) { + arg_list = p; +} else { + mp_link(tail) = p; +} +tail = p; +++n; +if (cur_cmd != mp_of_command) { + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_macro_name(mp, arg_list, macro_name); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Missing 'of' has been inserted for %s", mp_str(mp, sname)); + delete_str_ref(sname); + @.Missing `of'@> + mp_back_error(mp, msg, "I've got the first argument; will look now for the other."); +} +mp_get_x_next(mp); +mp_scan_primary(mp); + +@ @<Scan a suffix with optional delimiters@>= +if (cur_cmd != mp_left_delimiter_command) { + l_delim = NULL; +} else { + l_delim = cur_sym; + r_delim = equiv_sym(cur_sym); + mp_get_x_next(mp); +} +mp_scan_suffix(mp); +if (l_delim != NULL) { + if ((cur_cmd != mp_right_delimiter_command) || (equiv_sym(cur_sym) != l_delim)) { + char msg[256]; + mp_snprintf(msg, 256, "Missing '%s' has been inserted", mp_str(mp, text(r_delim))); + @.Missing `)'@> + mp_back_error(mp, msg, "I've gotten to the end of the macro parameter list."); + } + mp_get_x_next(mp); +} + +@ Before we put a new token list on the input stack, it is wise to clean off +all token lists that have recently been depleted. Then a user macro that ends +with a call to itself will not require unbounded stack space. + +@<Feed the arguments and replacement text to the scanner@>= +while (token_state && (nloc == NULL)) { + /* conserve stack space */ + mp_end_token_list(mp); +} +if (mp->param_ptr + n > mp->max_param_stack) { + mp->max_param_stack = mp->param_ptr + n; + mp_check_param_size(mp, mp->max_param_stack); + @:MetaPost capacity exceeded parameter stack size}{\quad parameter stack size@> +} +mp_begin_token_list(mp, def_ref, mp_macro_text); +name = macro_name ? text(macro_name) : NULL; +nloc = r; +if (n > 0) { + mp_node p = arg_list; + do { + mp->param_stack[mp->param_ptr] = (mp_node) mp_get_sym_sym(p); + ++mp->param_ptr; + p = mp_link(p); + } while (p != NULL); + mp_flush_node_list(mp, arg_list); +} + +@ It's sometimes necessary to put a single argument onto |param_stack|. The +|stack_argument| subroutine does this. + +@c +static void mp_stack_argument (MP mp, mp_node p) +{ + if (mp->param_ptr == mp->max_param_stack) { + ++mp->max_param_stack; + mp_check_param_size(mp, mp->max_param_stack); + } + mp->param_stack[mp->param_ptr] = p; + ++mp->param_ptr; +} + +@* Conditional processing. + +Let's consider now the way |if| commands are handled. + +Conditions can be inside conditions, and this nesting has a stack that is +independent of other stacks. Four global variables represent the top of the +condition stack: |cond_ptr| points to pushed-down entries, if~any; |cur_if| tells +whether we are processing |if| or |elseif|; |if_limit| specifies the largest +code of a |fi_or_else| command that is syntactically legal; and |if_line| is the +line number at which the current conditional began. + +If no conditions are currently in progress, the condition stack has the special +state |cond_ptr=NULL|, |if_limit=normal|, |cur_if=0|, |if_line=0|. Otherwise +|cond_ptr| points to a non-symbolic node; the |type|, |name_type|, and |link| +fields of the first word contain |if_limit|, |cur_if|, and |cond_ptr| at the next +level, and the second word contains the corresponding |if_line|. + +@ @d mp_if_line_field(A) ((mp_if_node) (A))->if_line_field + +@ @<Enumeration types@>= +typedef enum mp_if_codes { + mp_no_if_code, + mp_if_code, /* code for |if| being evaluated */ + mp_fi_code, /* code for |fi| */ + mp_else_code, /* code for |else| */ + mp_else_if_code, /* code for |elseif| */ +} mp_if_codes; + +@ @<MPlib internal header stuff@>= +typedef struct mp_if_node_data { + mp_variable_type type; + mp_name_type_type name_type; + int hasnumber; + int if_line_field; + struct mp_node_data *link; +} mp_if_node_data; + +typedef struct mp_if_node_data *mp_if_node; + +@c +static mp_node mp_get_if_node (MP mp) { + mp_if_node p = (mp_if_node) mp_allocate_node(mp, sizeof(mp_if_node_data)); + mp_type(p) = mp_if_node_type; + return (mp_node) p; +} + +@ @<Glob...@>= +mp_node cond_ptr; /* top of the condition stack */ +int if_limit; /* upper bound on |fi_or_else| codes */ +int cur_if; /* type of conditional being worked on */ +int if_line; /* line where that conditional began */ + +@ @<Set init...@>= +mp->cond_ptr = NULL; +mp->if_limit = mp_no_if_code; +mp->cur_if = 0; +mp->if_line = 0; + +@ @<Put each...@>= +mp_primitive(mp, "if", mp_if_test_command, mp_if_code); +@:if_}{|if| primitive@> +mp_primitive(mp, "fi", mp_fi_or_else_command, mp_fi_code); +mp->frozen_fi = mp_frozen_primitive (mp, "fi", mp_fi_or_else_command, mp_fi_code); +@:fi_}{|fi| primitive@> +mp_primitive(mp, "else", mp_fi_or_else_command, mp_else_code); +@:else_}{|else| primitive@> +mp_primitive(mp, "elseif", mp_fi_or_else_command, mp_else_if_code); +@:else_if_}{|elseif| primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case mp_if_test_command: +case mp_fi_or_else_command: + switch (m) { + case mp_if_code : return "if"; + case mp_fi_code : return "fi"; + case mp_else_code : return "else"; + case mp_else_if_code: return "elseif"; + } + break; + +@ Here is a procedure that ignores text until coming to an |elseif|, |else|, +or |fi| at level zero of $|if|\ldots|fi|$ nesting. After it has acted, +|cur_mod| will indicate the token that was found. + +\MP's smallest two command codes are |if_test| and |fi_or_else|; this makes the +skipping process a bit simpler. + +@c +void mp_pass_text (MP mp) +{ + int level = 0; + mp->scanner_status = mp_skipping_state; + mp->warning_line = mp_true_line(mp); + while (1) { + get_t_next(mp); + if (cur_cmd <= mp_fi_or_else_command) { + if (cur_cmd < mp_fi_or_else_command) { + ++level; + } else if (level == 0) { + break; + } else if (cur_mod == mp_fi_code) { + --level; + } + } else { + @<Decrease the string reference count, if the current token is a string@> + } + } + mp->scanner_status = mp_normal_state; +} + +@ @<Decrease the string reference count...@>= +if (cur_cmd == mp_string_command) { + delete_str_ref(cur_mod_str); +} + +@ When we begin to process a new |if|, we set |if_limit:=mp_if_code|; then if +|elseif| or |else| or |fi| occurs before the current |if| condition has +been evaluated, a colon will be inserted. A construction like |if fi| would +otherwise get \MP\ confused. + +@<Declarations@>= +static void mp_push_condition_stack (MP mp); +static void mp_pop_condition_stack (MP mp); + +@ Push and pop the condition stack: + +@c +static void mp_push_condition_stack (MP mp) +{ + mp_node p = mp_get_if_node(mp); + mp_link(p) = mp->cond_ptr; + mp_type(p) = (int) mp->if_limit; + mp_name_type(p) = mp->cur_if; + mp_if_line_field(p) = mp->if_line; + mp->cond_ptr = p; + mp->if_limit = mp_if_code; + mp->if_line = mp_true_line(mp); + mp->cur_if = mp_if_code; +} + +static void mp_pop_condition_stack (MP mp) +{ + mp_node p = mp->cond_ptr; + mp->if_line = mp_if_line_field(p); + mp->cur_if = mp_name_type(p); + mp->if_limit = mp_type(p); + mp->cond_ptr = mp_link(p); + mp_free_node(mp, p, sizeof(mp_if_node_data)); +} +@ Here's a procedure that changes the |if_limit| code corresponding to +a given value of |cond_ptr|. + +@c +static void mp_change_if_limit (MP mp, int l, mp_node p) +{ + if (p == mp->cond_ptr) { + /* that's the easy case */ + mp->if_limit = l; + } else { + mp_node q = mp->cond_ptr; + while (1) { + if (q == NULL) { + mp_confusion(mp, "if"); + @:this can't happen if}{\quad if@> + return; + } else if (mp_link(q) == p) { + mp_type(q) = l; + return; + } else { + q = mp_link(q); + } + } + } +} + +@ The user is supposed to put colons into the proper parts of conditional +statements. Therefore, \MP\ has to check for their presence. + +@c +static void mp_check_colon (MP mp) +{ + if (cur_cmd != mp_colon_command) { + mp_back_error( + mp, + "Missing ':' has been inserted", + "There should've been a colon after the condition. I shall pretend that one was\n" + "there." + ); + @.Missing `:'@> + } +} + +@ A condition is started when the |get_x_next| procedure encounters an |if_test| +command; in that case |get_x_next| calls |conditional|, which is a recursive +procedure. @^recursion@> + +@c +void mp_conditional (MP mp) +{ + mp_node save_cond_ptr; /* |cond_ptr| corresponding to this conditional */ + int new_if_limit; /* future value of |if_limit| */ + mp_push_condition_stack(mp); + save_cond_ptr = mp->cond_ptr; + RESWITCH: + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_boolean_type) { + do_boolean_error(mp); + } + new_if_limit = mp_else_if_code; + if (number_greater(internal_value(mp_tracing_commands_internal), unity_t)) { + @<Display the boolean value of |cur_exp|@> + } + FOUND: + mp_check_colon(mp); + if (cur_exp_value_boolean == mp_true_operation) { + mp_change_if_limit (mp, (int) new_if_limit, save_cond_ptr); + /* wait for |elseif|, |else|, or |fi| */ + return; + } + @<Skip to |elseif| or |else| or |fi|, then |goto done|@> + DONE: + mp->cur_if = (int) cur_mod; + mp->if_line = mp_true_line(mp); + if (cur_mod == mp_fi_code) { + mp_pop_condition_stack(mp); + } else if (cur_mod == mp_else_if_code) { + goto RESWITCH; + } else { + mp_set_cur_exp_value_boolean(mp, mp_true_operation); + new_if_limit = mp_fi_code; + mp_get_x_next(mp); + goto FOUND; + } +} + +@ In a construction like `|if| |if| |true|: $0=1$: |foo| |else|: +|bar| |fi|', the first |else| that we come to after learning that the +|if| is false is not the |else| we're looking for. Hence the following +curious logic is needed. + +@<Skip to |elseif|...@>= +while (1) { + mp_pass_text(mp); + if (mp->cond_ptr == save_cond_ptr) { + goto DONE; + } else if (cur_mod == mp_fi_code) { + mp_pop_condition_stack(mp); + } +} + +@ @<Display the boolean value...@>= +mp_begin_diagnostic(mp); +mp_print_str(mp, cur_exp_value_boolean == mp_true_operation ? "{true}" : "{false}"); +mp_end_diagnostic(mp, 0); + +@ The processing of conditionals is complete except for the following code, which +is actually part of |get_x_next|. It comes into play when |elseif|, |else|, +or |fi| is scanned. + +@<Terminate the current conditional and skip to |fi|@>= +if (cur_mod > mp->if_limit) { + if (mp->if_limit == mp_if_code) { + /* condition not yet evaluated */ + mp_back_input(mp); + set_cur_sym(mp->frozen_colon); + mp_ins_error(mp, "Missing ':' has been inserted", "Something was missing here"); + @.Missing `:'@> + } else { + const char *hlp = "I'm ignoring this; it doesn't match any if."; + switch (cur_mod) { + case mp_fi_code: + mp_error(mp, "Extra 'fi'", hlp); + @.Extra fi@> + break; + case mp_else_code: + mp_error(mp, "Extra 'else'", hlp); + @.Extra else@> + break; + default: + mp_error(mp, "Extra 'elseif'", hlp); + @.Extra elseif@> + break; + } + } +} else { + while (cur_mod != mp_fi_code) { + /* skip to |fi| */ + mp_pass_text(mp); + } + mp_pop_condition_stack(mp); +} + +@* Iterations. + +To bring our treatment of |get_x_next| to a close, we need to consider what \MP\ +does when it sees |for|, |forsuffixes|, and |forever|. + +There's a global variable |loop_ptr| that keeps track of the |for| loops that +are currently active. If |loop_ptr=NULL|, no loops are in progress; otherwise +|loop_ptr.info| points to the iterative text of the current (innermost) loop, and +|loop_ptr.link| points to the data for any other loops that enclose the current +one. + +A loop-control node also has two other fields, called |type| and |list|, whose +contents depend on the type of loop: + +\yskip\indent|loop_ptr.type=NULL| means that the link of |loop_ptr.list| points +to a list of symbolic nodes whose |info| fields point to the remaining argument +values of a suffix list and expression list. In this case, an extra field +|loop_ptr.start_list| is needed to make sure that |resume_operation| skips ahead. + +\yskip\indent|loop_ptr.type=MP_VOID| means that the current loop is +|forever|. + +\yskip\indent|loop_ptr.type=MP_PROGRESSION_FLAG| means that |loop_ptr.value|, +|loop_ptr.step_size|, and |loop_ptr.final_value| contain the data for an +arithmetic progression. + +\yskip\indent|loop_ptr.type=p>MP_PROGRESSION_FLAG| means that |p| points to an edge +header and |loop_ptr.list| points into the graphical object list for that edge +header. + +@d MP_VOID (mp_node) (1) /* |NULL+1|, a |NULL| pointer different from |NULL| */ +@d MP_PROGRESSION_FLAG (mp_node) (2) /* |NULL+2| */ + +/* |loop_type| value when |loop_list| points to a progression node */ + +@<Types...@>= +typedef struct mp_loop_data { + mp_sym var ; /* the var of the loop */ + mp_node info; /* iterative text of this loop */ + mp_node type; /* the special type of this loop, or a pointer into mem */ + mp_node list; /* the remaining list elements */ + mp_node list_start; /* head fo the list of elements */ + mp_number old_value; /* previous value of current arithmetic value */ + mp_number value; /* current arithmetic value */ + mp_number step_size; /* arithmetic step size */ + mp_number final_value; /* end arithmetic value */ + struct mp_loop_data *link; /* the enclosing loop, if any */ + mp_knot point; +} mp_loop_data; + +@ @<Glob...@>= +mp_loop_data *loop_ptr; /* top of the loop-control-node stack */ + +@ @<Set init...@>= +mp->loop_ptr = NULL; + +@ If the expressions that define an arithmetic progression in a |for| loop +don't have known numeric values, the |bad_for| subroutine screams at the user. + +@c +static void mp_bad_for (MP mp, const char *s) +{ + char msg[256]; + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + /* show the bad expression above the message */ + mp_snprintf(msg, 256, "Improper %s has been replaced by 0", s); + @.Improper...replaced by 0@> + mp_back_error( + mp, + msg, + "When you say 'for x=a step b until c', the initial value 'a' and the step size\n" + "'b' and the final value 'c' must have known numeric values. I'm zeroing this one.\n" + "Proceed, with fingers crossed." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); +} + +@ Here's what \MP\ does when |for|, |forsuffixes|, or |forever| has just +been scanned. (This code requires slight familiarity with expression-parsing +routines that we have not yet discussed; but it seems to belong in the present +part of the program, even though the original author didn't write it until later. +The reader may wish to come back to it.) + +@c +void mp_begin_iteration (MP mp) +{ + mp_node q; /* link manipulation register */ + mp_sym n = cur_sym; /* hash address of the current symbol */ + mp_subst_list_item *p = NULL; /* substitution list for |scan_toks| */ + int m = cur_mod; /* |start_for| (|for|) or |start_forsuffixes| (|forsuffixes|) */ + mp_loop_data *s = mp_memory_allocate(sizeof(mp_loop_data)); /* the new loop-control node */ + s->type = NULL; + s->list = NULL; + s->info = NULL; + s->list_start = NULL; + s->link = NULL; + s->var = NULL; + s->point = NULL; + new_number(s->value); + new_number(s->old_value); + new_number(s->step_size); + new_number(s->final_value); + if (m == mp_start_forever_code) { + s->type = MP_VOID; + mp_get_x_next(mp); + } else { + mp_get_symbol(mp); + p = mp_memory_allocate(sizeof(mp_subst_list_item)); + p->link = NULL; + p->info = cur_sym; + s->var = cur_sym; + p->info_mod = cur_sym_mod; + p->value_data = 0; + if (m == mp_start_for_code) { + p->value_mod = mp_expr_operation; + } else { + /* |start_forsuffixes| */ + p->value_mod = mp_suffix_operation; + } + mp_get_x_next(mp); + if (p->value_mod == mp_expr_operation && cur_cmd == mp_within_command) { + @<Set up a picture iteration@> + } else { + @<Check for the assignment in a loop header@> + @<Scan the values to be used in the loop@> + } + } + @<Check for the presence of a colon@> + @<Scan the loop text and put it on the loop control stack@> + mp_resume_iteration(mp); +} + + +@ @<Check for the assignment in a loop header@>= +if ((cur_cmd != mp_equals_command) && (cur_cmd != mp_assignment_command)) { + mp_back_error( + mp, + "Missing '=' has been inserted", + "The next thing in this loop should have been '=' or ':='. But don't worry; I'll\n" + "pretend that an equals sign was present, and I'll look for the values next." + ); + @.Missing `='@> +} + +@ @<Check for the presence of a colon@>= +if (cur_cmd != mp_colon_command) { + mp_back_error( + mp, + "Missing ':' has been inserted", + "The next thing in this loop should have been a ':'. So I'll pretend that a colon\n" + "was present; everything from here to 'endfor' will be iterated." + ); + @.Missing `:'@> +} + +@ We append a special |mp->frozen_repeat_loop| token in place of the |endfor| +at the end of the loop. This will come through \MP's scanner at the proper time +to cause the loop to be repeated. + +(If the user tries some shenanigan like `|for| $\ldots$ |let| |endfor|', he +will be foiled by the |get_symbol| routine, which keeps frozen tokens unchanged. +Furthermore the |mp->frozen_repeat_loop| is an |outer| token, so it won't be +lost accidentally.) + +@ @<Scan the loop text...@>= +q = mp_new_symbolic_node(mp); +mp_set_sym_sym(q, mp->frozen_repeat_loop); +mp->scanner_status = mp_loop_defining_state; +mp->warning_info = n; +s->info = mp_scan_toks(mp, mp_iteration_command, p, q, 0); +mp->scanner_status = mp_normal_state; +s->link = mp->loop_ptr; +mp->loop_ptr = s; + +@ @<Initialize table...@>= +mp->frozen_repeat_loop = +//mp_frozen_primitive (mp, " ENDFOR", mp_repeat_loop_command + mp_outer_tag_command, 0); +mp_frozen_primitive (mp, " ENDFOR", mp_repeat_loop_command, 0); + +@ The loop text is inserted into \MP's scanning apparatus by the +|resume_iteration| routine. + +@c +void mp_resume_iteration (MP mp) +{ + mp_node p, q; /* link registers */ + p = mp->loop_ptr->type; + if (p == MP_PROGRESSION_FLAG) { + mp_set_cur_exp_value_number(mp, &(mp->loop_ptr->value)); + if ((number_positive(mp->loop_ptr->step_size) && number_greater(cur_exp_value_number, mp->loop_ptr->final_value)) + || (number_negative(mp->loop_ptr->step_size) && number_less (cur_exp_value_number, mp->loop_ptr->final_value))) { + mp_stop_iteration(mp); + return; + } + mp->cur_exp.type = mp_known_type; + /* make |q| an |expr| argument */ + q = mp_stash_cur_exp(mp); + number_clone(mp->loop_ptr->old_value, cur_exp_value_number); + set_number_from_addition(mp->loop_ptr->value, cur_exp_value_number, mp->loop_ptr->step_size); + /* Set |value(p)| for the next iteration and detect numeric overflow */ + if (number_positive(mp->loop_ptr->step_size) && number_less(mp->loop_ptr->value, cur_exp_value_number)) { + if (number_positive(mp->loop_ptr->final_value)) { + number_clone(mp->loop_ptr->value, mp->loop_ptr->final_value); + number_add_scaled(mp->loop_ptr->final_value, -1); + } else { + number_clone(mp->loop_ptr->value, mp->loop_ptr->final_value); + number_add_scaled(mp->loop_ptr->value, 1); + } + } else if (number_negative(mp->loop_ptr->step_size) && number_greater(mp->loop_ptr->value, cur_exp_value_number)) { + if (number_negative(mp->loop_ptr->final_value)) { + number_clone(mp->loop_ptr->value, mp->loop_ptr->final_value); + number_add_scaled(mp->loop_ptr->final_value, 1); + } else { + number_clone(mp->loop_ptr->value, mp->loop_ptr->final_value); + number_add_scaled(mp->loop_ptr->value, -1); + } + } + if (mp->loop_ptr->point != NULL) { + mp->loop_ptr->point = mp_next_knot(mp->loop_ptr->point); + } + } else if (p == NULL) { + p = mp->loop_ptr->list; + if (p != NULL && p == mp->loop_ptr->list_start) { + q = p; + p = mp_link(p); + mp_free_symbolic_node(mp, q); + mp->loop_ptr->list = p; + } + if (p == NULL) { + mp_stop_iteration(mp); + return; + } + mp->loop_ptr->list = mp_link(p); + q = (mp_node) mp_get_sym_sym(p); + if (q) { + number_clone(mp->loop_ptr->old_value, q->data.n); + } + mp_free_symbolic_node(mp, p); + } else if (p == MP_VOID) { + mp_begin_token_list(mp, mp->loop_ptr->info, mp_forever_text); + return; + } else { + @<Make |q| a capsule containing the next picture component from |loop_list(loop_ptr)| or |goto not_found|@> + } + mp_begin_token_list(mp, mp->loop_ptr->info, mp_loop_text); + mp_stack_argument(mp, q); + if (number_greater(internal_value(mp_tracing_commands_internal), unity_t)) { + @<Trace the start of a loop@> + } + return; + NOT_FOUND: + mp_stop_iteration(mp); +} + +@ @<Trace the start of a loop@>= +mp_begin_diagnostic(mp); +mp_print_nl(mp, "{loop value="); +@.loop value=n@> +if ((q != NULL) && (mp_link(q) == MP_VOID)) { + mp_print_exp(mp, q, 1); +} else { + mp_show_token_list(mp, q, NULL); +} +mp_print_chr(mp, '}'); +mp_end_diagnostic(mp, 0); + +@ @<Make |q| a capsule containing the next picture component from...@>= +q = mp->loop_ptr->list; +if (q == NULL) { + goto NOT_FOUND; +} else if (! mp_is_start_or_stop(q)) { + q = mp_link(q); +} else if (! mp_is_stop(q)) { + q = mp_skip_1component(mp, q); +} else { + goto NOT_FOUND; +} +mp_set_cur_exp_node(mp, (mp_node) mp_copy_objects (mp, mp->loop_ptr->list, q)); +mp_init_bbox(mp, (mp_edge_header_node) cur_exp_node); +mp->cur_exp.type = mp_picture_type; +mp->loop_ptr->list = q; +q = mp_stash_cur_exp(mp); + +@ A level of loop control disappears when |resume_iteration| has decided not to +resume, or when an |exitif| construction has removed the loop text from the +input stack. + +@c +void mp_stop_iteration (MP mp) +{ + mp_node p = mp->loop_ptr->type; + if (p == MP_PROGRESSION_FLAG) { + mp_free_symbolic_node(mp, mp->loop_ptr->list); + if (mp->loop_ptr->point) { + mp_toss_knot_list(mp, mp->loop_ptr->point); + } + } else if (p == NULL) { + mp_node q = mp->loop_ptr->list; + while (q != NULL) { + p = (mp_node) mp_get_sym_sym(q); + if (p != NULL) { + if (mp_link(p) == MP_VOID) { + /* it's an |expr| parameter */ + mp_recycle_value(mp, p); + mp_free_value_node(mp, p); + } else { + /* it's a |suffix| or |text| parameter */ + mp_flush_token_list(mp, p); + } + } + p = q; + q = mp_link(q); + mp_free_symbolic_node(mp, p); + } + } else if (p > MP_PROGRESSION_FLAG) { + mp_delete_edge_ref(mp, p); + } + { + mp_loop_data *tmp = mp->loop_ptr; + mp->loop_ptr = tmp->link; + mp_flush_token_list(mp, tmp->info); + free_number(tmp->value); + free_number(tmp->step_size); + free_number(tmp->final_value); + mp_memory_free(tmp); + } +} + +@ Now that we know all about loop control, we can finish up the missing portion +of |begin_iteration| and we'll be done. + +The following code is performed after the |=| has been scanned in a |for| +construction (if |m=start_for|) or a |forsuffixes| construction (if +|m=start_forsuffixes|). + +@<Scan the values to be used in the loop@>= +s->type = NULL; +s->list = mp_new_symbolic_node(mp); +s->list_start = s->list; +q = s->list; +do { + mp_get_x_next(mp); + if (m != mp_start_for_code) { + mp_scan_suffix(mp); + } else { + if (cur_cmd >= mp_colon_command && cur_cmd <= mp_comma_command) { + goto CONTINUE; + } + mp_scan_expression(mp); + if (cur_cmd == mp_step_command && q == s->list) { + @<Prepare for step-until construction and |break|@> + } + mp_set_cur_exp_node(mp, mp_stash_cur_exp(mp)); + } + mp_link(q) = mp_new_symbolic_node(mp); + q = mp_link(q); + mp_set_sym_sym(q, mp->cur_exp.data.node); + if (m == mp_start_for_code) { + mp_name_type(q) = mp_expr_operation; + } else if (m == mp_start_forsuffixes_code) { + mp_name_type(q) = mp_suffix_operation; + } + mp->cur_exp.type = mp_vacuous_type; + CONTINUE: + ; /* needed */ +} while (cur_cmd == mp_comma_command); + +@ @<Prepare for step-until construction and |break|@>= +{ + if (mp->cur_exp.type != mp_known_type) { + mp_bad_for (mp, "initial value"); + } + number_clone(s->value, cur_exp_value_number); + number_clone(s->old_value, cur_exp_value_number); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_bad_for (mp, "step size"); + } + number_clone(s->step_size, cur_exp_value_number); + if (cur_cmd != mp_until_command) { + mp_back_error( + mp, + "Missing 'until' has been inserted", + "I assume you meant to say 'until' after 'step'. So I'll look for the final value\n" + "and colon next." + ); + @.Missing `until'@> + } + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_bad_for (mp, "final value"); + } + number_clone(s->final_value, cur_exp_value_number); + s->type = MP_PROGRESSION_FLAG; + break; +} + +@ The last case is when we have just seen |within|, and we need to parse a +picture expression and prepare to iterate over it. + +@<Set up a picture iteration@>= +mp_get_x_next(mp); +mp_scan_expression(mp); +if (mp->cur_exp.type == mp_path_type) { + number_clone(s->value, zero_t); + number_clone(s->old_value, zero_t); + number_clone(s->step_size, unity_t); + /* */ + { + mp_knot p = cur_exp_knot; + // int l = mp_left_type(p) == mp_endpoint_knot ? -1 : 0; + int l = 0; + while (1) { + mp_knot n = mp_next_knot(p); + if (n == cur_exp_knot) { + /* So we actually start at the end because we next first. */ + s->point = p; + set_number_from_int(s->final_value, l); + break; + } else { + p = n; + ++l; + } + } + } + /* */ + s->type = MP_PROGRESSION_FLAG; + s->list = mp_new_symbolic_node(mp); + s->list_start = s->list; + q = s->list; +} else { + @<Make sure the current expression is a known picture@> + s->type = mp->cur_exp.data.node; + mp->cur_exp.type = mp_vacuous_type; + q = mp_link(mp_edge_list(mp->cur_exp.data.node)); + if (q != NULL && mp_is_start_or_stop (q) && mp_skip_1component(mp, q) == NULL) { + q = mp_link(q); + } + s->list = q; +} + +@ @<Make sure the current expression is a known picture@>= +if (mp->cur_exp.type != mp_picture_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + new_expr.data.node = (mp_node) mp_get_edge_header_node(mp); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Improper iteration spec has been replaced by nullpicture", + "When you say 'for x in p', p must be a known picture." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + mp_init_edges(mp, (mp_edge_header_node) mp->cur_exp.data.node); + mp->cur_exp.type = mp_picture_type; +} + +@* File names. + +It's time now to fret about file names. Besides the fact that different operating +systems treat files in different ways, we must cope with the fact that completely +different naming conventions are used by different groups of people. The +following programs show what is required for one particular operating system; +similar routines for other systems are not difficult to devise. @^system +dependencies@> + +\MP\ assumes that a file name has three parts: the name proper; its +\quote {extension}; and a \quote {file area} where it is found in an external file system. +The extension of an input file is assumed to be |.mp| unless otherwise +specified; it is |.log| on the transcript file that records each run of \MP; +it is |.tfm| on the font metric files that describe characters in any fonts +created by \MP; it is |.ps| or `.{\it nnn}' for some number {\it nnn} on the +\ps\ output files. The file area can be arbitrary on input files, but files are +usually output to the user's current area. If an input file cannot be found on +the specified area, \MP\ will look for it on a special system area; this special +area is intended for commonly used input files. + +Simple uses of \MP\ refer only to file names that have no explicit extension or +area. For example, a person usually says `|input| |cmr10|' instead of +`|input| |cmr10.new|'. Simple file names are best, because they make the \MP\ +source files portable; whenever a file name consists entirely of letters and +digits, it should be treated in the same way by all implementations of \MP. +However, users need the ability to refer to other files in their environment, +especially when responding to error messages concerning unopenable files; +therefore we want to let them use the syntax that appears in their favorite +operating system. + +@ \MP\ uses the same conventions that have proved to be satisfactory for \TeX\ +and \MF. In order to isolate the system-dependent aspects of file names, @^system +dependencies@> the system-independent parts of \MP\ are expressed in terms of +three system-dependent procedures called |begin_name|, |more_name|, and +|end_name|. In essence, if the user-specified characters of the file name are +$c_1\ldots c_n$, the system-independent driver program does the operations +$$|begin_name|;\,|more_name|(c_1);\,\ldots\,;\,|more_name|(c_n); \,|end_name|.$$ +These three procedures communicate with each other via global variables. +Afterwards the file name will appear in the string pool as |cur_name|. + +Actually the situation is slightly more complicated, because \MP\ needs to know +when the file name ends. The |more_name| routine is a function (with side +effects) that returns |true| on the calls |more_name|$(c_1)$, \dots, +|more_name|$(c_{n-1})$. The final call |more_name|$(c_n)$ returns |false|; or, it +returns |true| and $c_n$ is the last character on the current input line. In +other words, |more_name| is supposed to return |true| unless it is sure that the +file name has been completely scanned; and |end_name| is supposed to be able to +finish the assembly of |cur_name| regardless of whether $|more_name|(c_n)$ returned +|true| or |false|. + +@<Glob...@>= +char *cur_name; /* name of file just scanned */ + +@ It is easier to maintain reference counts if we assign initial values. + +@<Set init...@>= +mp->cur_name = mp_strdup(""); + +@ @<Dealloc variables@>= +mp_memory_free(mp->cur_name); + +@ The file names we shall deal with for illustrative purposes have the following +structure: If the name contains |>| or |:|, the file area consists of all +characters up to and including the final such character; otherwise the file area +is null. If the remaining file name contains |.|, the file extension consists +of all such characters from the first remaining |.| to the end, otherwise the +file extension is null. @^system dependencies@> + +We can scan such file names easily by using two global variables that keep track +of the occurrences of area and extension delimiters. + +@<Glob...@>= +int quoted_filename; /* whether the filename is wrapped in " markers */ + +@ Here are the routines for file name scanning. + +@<Declarations@>= +static void mp_begin_name (MP mp); +static int mp_more_name (MP mp, unsigned char c); +static void mp_end_name (MP mp); + +@ @c +void mp_begin_name (MP mp) +{ + mp_memory_free(mp->cur_name); + mp->cur_name = NULL; + mp->quoted_filename = 0; +} + +int mp_more_name (MP mp, unsigned char c) +{ + if (c == '"') { + mp->quoted_filename = ! mp->quoted_filename; + } else if ((c == ' ' || c == '\t') && (mp->quoted_filename == 0)) { + return 0; + } else { + mp_str_room(mp, 1); + mp_append_char(mp, c); + } + return 1; +} + +void mp_end_name (MP mp) +{ + mp->cur_name = mp_memory_allocate((size_t) (mp->cur_length + 1) * sizeof(char)); + (void) memcpy(mp->cur_name, (char *) (mp->cur_string), mp->cur_length); + mp->cur_name[mp->cur_length] = 0; + mp_reset_cur_string(mp); +} + +void mp_pack_file_name (MP mp, const char *n) +{ + mp_memory_free(mp->name_of_file); + mp->name_of_file = mp_strdup(n); +} + +@ @<Internal library declarations@>= +void mp_pack_file_name (MP mp, const char *n); + +@ Operating systems often make it possible to determine the exact name (and +possible version number) of a file that has been opened. The following routine, +which simply makes a \MP\ string from the value of |name_of_file|, should ideally +be changed to deduce the full name of file~|f|, which is the file most recently +opened, if it is possible to do this. @^system dependencies@> + +@ @c +static mp_string mp_make_name_string (MP mp) +{ + int name_length = (int) strlen(mp->name_of_file); + mp_str_room(mp, name_length); + for (int k = 0; k < name_length; k++) { + mp_append_char(mp, (unsigned char) mp->name_of_file[k]); + } + return mp_make_string(mp); +} + +@ Now let's consider the \quote {driver} routines by which \MP\ deals with file names +in a system-independent manner. First comes a procedure that looks for a file +name in the input by taking the information from the input buffer. (We can't use +|get_next|, because the conversion to tokens would destroy necessary +information.) + +This procedure doesn't allow semicolons or percent signs to be part of file +names, because of other conventions of \MP. {\sl The {\logos METAFONT}book} +doesn't use semicolons or percents immediately after file names, but some users +no doubt will find it natural to do so; therefore system-dependent changes to +allow such characters in file names should probably be made with reluctance, and +only when an entire file name that includes special characters is \quote {quoted} +somehow. @^system dependencies@> + +@c +static void mp_scan_file_name (MP mp) +{ + mp_begin_name(mp); + while (mp->buffer[loc] == ' ') { + ++loc; + } + while (1) { + if ((mp->buffer[loc] == ';') || (mp->buffer[loc] == '%')) { + break; + } else if (! mp_more_name(mp, mp->buffer[loc])) { + break; + } else { + ++loc; + } + } + mp_end_name(mp); +} + +static void mp_ptr_scan_file (MP mp, char *s) +{ + char *p = s; + char *q = p + strlen(s); + mp_begin_name(mp); + while (p < q) { + if (! mp_more_name(mp, (unsigned char) (*p))) { + break; + } else { + p++; + } + } + mp_end_name(mp); +} + +@ The option variable |job_name| has no real meaning and is dealt with by the caller, but +it is available in a variable in \MP. + +@ @<Option variables@>= +char *job_name; + +@ Initially |job_name = NULL| and when it is not set the initializer will quit. Setting +it happens elsewhere. + +@ @<Dealloc variables@>= +mp_memory_free(mp->job_name); + +@ Cannot do this earlier because at the |<Allocate or ...>|, the string pool is +not yet initialized. + +@<Fix up |job_name|@>= +if (mp->job_name != NULL) { + if (internal_string(mp_job_name_internal) != 0) { + delete_str_ref(internal_string(mp_job_name_internal)); + } + set_internal_string(mp_job_name_internal, mp_rts(mp, mp->job_name)); +} + +@ Let's turn now to the procedure that is used to initiate file reading when an +|input| command is being processed. + +@c +void mp_start_input (MP mp) +{ + @<Put the desired file name in |cur_name|@> + mp_begin_file_reading(mp); /* set up |cur_file| and new level of input */ + mp_pack_file_name(mp, mp->cur_name); + if (mp_open_in(mp, &cur_file, mp_filetype_program)) { + char *fname = NULL; + name = mp_make_name_string(mp); + fname = mp_strdup(mp->name_of_file); + if (mp->interaction < mp_silent_mode) { + /* This needs a cleanup! */ + if ((mp->term_offset > 0) || (mp->file_offset > 0)) { + mp_print_chr(mp, ' '); + } + mp_print_chr(mp, '('); + ++mp->open_parens; + mp_print_str(mp, fname); + } + mp_memory_free(fname); + update_terminal(); + @<Flush |name| and replace it with |cur_name| if it won't be needed@> + @<Read the first line of the new file@> + } else { + mp_fatal_error(mp, "invalid input file"); + mp_end_file_reading(mp); + } +} + +@<Flush |name| and replace it with |cur_name| if it won't be needed@>= +mp_flush_string(mp, name); +name = mp_rts(mp, mp->cur_name); +mp_memory_free(mp->cur_name); +mp->cur_name = NULL; + +@ If the file is empty, it is considered to contain a single blank line, so there +is no need to test the return value. + +@<Read the first line...@>= +line = 1; +mp_input_ln(mp, cur_file); +mp_firm_up_the_line(mp); +mp->buffer[limit] = '%'; +mp->first = (size_t) (limit + 1); +loc = start; + +@ @<Put the desired file name in |cur_name|@>= +while (token_state && (nloc == NULL)) { + mp_end_token_list(mp); +} +if (token_state) { + mp_error( + mp, + "File names can't appear within macros", + "Sorry ... I've converted what follows to tokens, possibly garbaging the name you\n" + "gave. Please delete the tokens and insert the name again." + ); + @.File names can't...@> +} +if (file_state) { + mp_scan_file_name(mp); +} else { + mp_memory_free(mp->cur_name); + mp->cur_name = mp_strdup(""); +} + +@ The last file-opening commands are for files accessed via the |readfrom| +@:read_from_}{|readfrom| primitive@> operator and the |write| command. Such +files are stored in separate arrays. @:write_}{|write| primitive@> + + +@ @<Glob...@>= +int max_read_files; /* maximum number of simultaneously open |readfrom| files */ +void **rd_file; /* |readfrom| files */ +char **rd_fname; /* corresponding file name or 0 if file not open */ +int read_files; /* number of valid entries in the above arrays */ +int max_write_files; /* maximum number of simultaneously open |write| */ +void **wr_file; /* |write| files */ +char **wr_fname; /* corresponding file name or 0 if file not open */ +int write_files; /* number of valid entries in the above arrays */ + +@ @<Allocate or initialize ...@>= +mp->max_read_files = 8; +mp->rd_file = mp_memory_allocate((size_t) (mp->max_read_files + 1) * sizeof(void *)); +mp->rd_fname = mp_memory_allocate((size_t) (mp->max_read_files + 1) * sizeof(char *)); +mp->max_write_files = 8; +mp->wr_file = mp_memory_allocate((size_t) (mp->max_write_files + 1) * sizeof(void *)); +mp->wr_fname = mp_memory_allocate((size_t) (mp->max_write_files + 1) * sizeof(char *)); + +memset(mp->rd_fname, 0, sizeof(char *) * (mp->max_read_files + 1)); +memset(mp->wr_fname, 0, sizeof(char *) * (mp->max_write_files + 1)); + +@ This routine starts reading the file named by string~|s| without setting +|loc|, |limit|, or |name|. It returns |false| if the file is empty or cannot +be opened. Otherwise it updates |rd_file[n]| and |rd_fname[n]|. + +@c +static int mp_start_read_input (MP mp, char *s, int n) +{ + mp_ptr_scan_file(mp, s); + mp_pack_file_name(mp, mp->cur_name); + mp_begin_file_reading(mp); + if (! mp_open_in(mp, &mp->rd_file[n], mp_filetype_text + n)) { + mp_end_file_reading(mp); + return 0; + } else if (! mp_input_ln(mp, mp->rd_file[n])) { + (mp->close_file)(mp, mp->rd_file[n]); + mp_end_file_reading(mp); + return 0; + } else { + mp->rd_fname[n] = mp_strdup(s); + return 1; + } +} + +@ Open |wr_file[n]| using file name~|s| and update |wr_fname[n]|. + +@<Declarations@>= +static void mp_open_write_file (MP mp, char *s, int n); + +@ @c +void mp_open_write_file (MP mp, char *s, int n) +{ + mp_ptr_scan_file(mp, s); + mp_pack_file_name(mp, mp->cur_name); + if (mp_open_out(mp, &mp->wr_file[n], mp_filetype_text + n)) { + mp->wr_fname[n] = mp_strdup(s); + } else { + mp_fatal_error(mp, "invalid write file"); + } +} + +@* Introduction to the parsing routines. + +We come now to the central nervous system that sparks many of \MP's activities. +By evaluating expressions, from their primary constituents to ever larger +subexpressions, \MP\ builds the structures that ultimately define complete +pictures or fonts of type. + +Four mutually recursive subroutines are involved in this process: We call them + +$$\hbox{|scan_primary|, |scan_secondary|, |scan_tertiary|, and +|scan_expression|.}$$ + +@^recursion@> Each of them is parameterless and begins with the first token to be +scanned already represented in |cur_cmd|, |cur_mod|, and |cur_sym|. After +execution, the value of the primary or secondary or tertiary or expression that +was found will appear in the global variables |cur_type| and |cur_exp|. The token +following the expression will be represented in |cur_cmd|, |cur_mod|, and +|cur_sym|. + +Technically speaking, the parsing algorithms are \quote {LL(1),} more or less; backup +mechanisms have been added in order to provide reasonable error recovery. + +@d cur_exp_value_boolean number_to_int(mp->cur_exp.data.n) +@d cur_exp_value_number mp->cur_exp.data.n +@d cur_exp_node mp->cur_exp.data.node +@d cur_exp_str mp->cur_exp.data.str +@d cur_exp_knot mp->cur_exp.data.p + +@<Declarations@>= +static void mp_set_cur_exp_knot (MP mp, mp_knot n); +static void mp_set_cur_exp_node (MP mp, mp_node n); +static void mp_set_cur_exp_value_boolean (MP mp, int b); +static void mp_set_cur_exp_value_scaled (MP mp, int s); +static void mp_set_cur_exp_value_number (MP mp, mp_number *n); +static void mp_set_cur_exp_str (MP mp, mp_string s); + +@ @c +void mp_set_cur_exp_node (MP mp, mp_node n) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + cur_exp_node = n; + cur_exp_str = NULL; + cur_exp_knot = NULL; + set_number_to_zero(mp->cur_exp.data.n); +} + +void mp_set_cur_exp_knot (MP mp, mp_knot n) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + cur_exp_knot = n; + cur_exp_node = NULL; + cur_exp_str = NULL; + set_number_to_zero(mp->cur_exp.data.n); +} + +void mp_set_cur_exp_value_boolean (MP mp, int b) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + set_number_from_boolean(mp->cur_exp.data.n, b); + cur_exp_node = NULL; + cur_exp_str = NULL; + cur_exp_knot = NULL; +} + +void mp_set_cur_exp_value_scaled (MP mp, int s) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + set_number_from_scaled(mp->cur_exp.data.n, s); + cur_exp_node = NULL; + cur_exp_str = NULL; + cur_exp_knot = NULL; +} + +void mp_set_cur_exp_value_number (MP mp, mp_number *n) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + number_clone(mp->cur_exp.data.n, *n); + cur_exp_node = NULL; + cur_exp_str = NULL; + cur_exp_knot = NULL; +} + +void mp_set_cur_exp_str (MP mp, mp_string s) +{ + if (cur_exp_str) { + delete_str_ref(cur_exp_str); + } + cur_exp_str = s; + add_str_ref(cur_exp_str); + cur_exp_node = NULL; + cur_exp_knot = NULL; + set_number_to_zero(mp->cur_exp.data.n); +} + +@ @<Glob...@>= +mp_value cur_exp; /* the value of the expression just found */ + +@ @<Set init...@>= +memset(&mp->cur_exp.data, 0, sizeof(mp_value)); +new_number(mp->cur_exp.data.n); + +@ @<Free table ...@>= +free_number(mp->cur_exp.data.n); + +@ Many different kinds of expressions are possible, so it is wise to have precise +descriptions of what |cur_type| and |cur_exp| mean in all cases: + +\smallskip\hang |cur_type=mp_vacuous| means that this expression didn't turn out +to have a value at all, because it arose from a +|begingroup|$\,\ldots\,$|endgroup| construction in which there was no +expression before the |endgroup|. In this case |cur_exp| has some irrelevant +value. + +\smallskip\hang |cur_type = mp_boolean_type| means that |cur_exp| is either +|true_code| or |false_code|. + +\smallskip\hang |cur_type = mp_unknown_boolean| means that |cur_exp| points to a +capsule node that is in a ring of equivalent booleans whose value has not yet +been defined. + +\smallskip\hang |cur_type = mp_string_type| means that |cur_exp| is a string number +(i.e., an integer in the range |0<=cur_exp<str_ptr|). That string's reference +count includes this particular reference. + +\smallskip\hang |cur_type = mp_unknown_string| means that |cur_exp| points to a +capsule node that is in a ring of equivalent strings whose value has not yet been +defined. + +\smallskip\hang |cur_type = mp_pen_type| means that |cur_exp| points to a node in a +pen. Nobody else points to any of the nodes in this pen. The pen may be polygonal +or elliptical. + +\smallskip\hang |cur_type=mp_unknown_pen| means that |cur_exp| points to a +capsule node that is in a ring of equivalent pens whose value has not yet been +defined. + +\smallskip\hang |cur_type = mp_path_type| means that |cur_exp| points to a the +first node of a path; nobody else points to this particular path. The control +points of the path will have been chosen. + +\smallskip\hang +|cur_type = mp_unknown_path| means that |cur_exp| points to a capsule +node that is in +a ring of equivalent paths whose value has not yet been defined. + +\smallskip\hang +|cur_type = mp_picture_type| means that |cur_exp| points to an edge header node. +There may be other pointers to this particular set of edges. The header node +contains a reference count that includes this particular reference. + +\smallskip\hang |cur_type = mp_unknown_picture| means that |cur_exp| points to a +capsule node that is in a ring of equivalent pictures whose value has not yet +been defined. + +\smallskip\hang |cur_type = mp_transform_type| means that |cur_exp| points to a +|mp_transform_type| capsule node. The |value| part of this capsule points to a +transform node that contains six numeric values, each of which is |independent|, +|dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang |cur_type = mp_color_type| means that |cur_exp| points to a +|color_type| capsule node. The |value| part of this capsule points to a color +node that contains three numeric values, each of which is |independent|, +|dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang |cur_type = mp_cmykcolor_type| means that |cur_exp| points to a +|mp_cmykcolor_type| capsule node. The |value| part of this capsule points to a +color node that contains four numeric values, each of which is |independent|, +|dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang |cur_type = mp_pair_type| means that |cur_exp| points to a capsule +node whose type is |mp_pair_type|. The |value| part of this capsule points to a +pair node that contains two numeric values, each of which is |independent|, +|dependent|, |mp_proto_dependent|, or |known|. + +\smallskip\hang |cur_type = mp_known| means that |cur_exp| is a |scaled| value. + +\smallskip\hang |cur_type = mp_dependent| means that |cur_exp| points to a capsule +node whose type is |dependent|. The |dep_list| field in this capsule points to +the associated dependency list. + +\smallskip\hang |cur_type = mp_proto_dependent| means that |cur_exp| points to a +|mp_proto_dependent| capsule node. The |dep_list| field in this capsule points to +the associated dependency list. + +\smallskip\hang |cur_type = independent| means that |cur_exp| points to a capsule +node whose type is |independent|. This somewhat unusual case can arise, for +example, in the expression `$x+|begingroup|\penalty0\,|string|\,x; +0\,|endgroup|$'. + +\smallskip\hang |cur_type = mp_token_list| means that |cur_exp| points to a linked +list of tokens. + +\smallskip\noindent The possible settings of |cur_type| have been listed here in +increasing numerical order. Notice that |cur_type| will never be +|mp_numeric_type| or |suffixed_macro| or |mp_unsuffixed_macro|, although +variables of those types are allowed. Conversely, \MP\ has no variables of type +|mp_vacuous| or |token_list|. + +@ Capsules are non-symbolic nodes that have a similar meaning to |cur_type| and +|cur_exp|. Such nodes have |name_type=capsule|, and their |type| field is one of +the possibilities for |cur_type| listed above. Also |link<=void| in capsules that +aren't part of a token list. + +The |value| field of a capsule is, in most cases, the value that corresponds to +its |type|, as |cur_exp| corresponds to |cur_type|. However, when |cur_exp| would +point to a capsule, no extra layer of indirection is present; the |value| field +is what would have been called |value(cur_exp)| if it had not been encapsulated. +Furthermore, if the type is |dependent| or |mp_proto_dependent|, the |value| +field of a capsule is replaced by |dep_list| and |prev_dep| fields, since +dependency lists in capsules are always part of the general |dep_list| structure. + +The |get_x_next| routine is careful not to change the values of |cur_type| and +|cur_exp| when it gets an expanded token. However, |get_x_next| might call a +macro, which might parse an expression, which might execute lots of commands in a +group; hence it's possible that |cur_type| might change from, say, +|mp_unknown_boolean| to |mp_boolean_type|, or from |dependent| to |known| or +|independent|, during the time |get_x_next| is called. The programs below are +careful to stash sensitive intermediate results in capsules, so that \MP's +generality doesn't cause trouble. + +Here's a procedure that illustrates these conventions. It takes the contents of +$(|cur_type|\kern-.3pt,|cur_exp|\kern-.3pt)$ and stashes them away in a capsule. +It is not used when |cur_type=mp_token_list|. After the operation, +|cur_type=mp_vacuous|; hence there is no need to copy path lists or to update +reference counts, etc. + +The special link |MP_VOID| is put on the capsule returned by |stash_cur_exp|, +because this procedure is used to store macro parameters that must be easily +distinguishable from token lists. + +@<Declarations@>= +static mp_node mp_stash_cur_exp (MP mp); + +@ @c +static mp_node mp_stash_cur_exp (MP mp) +{ + mp_node p; /* the capsule that will be returned */ + mp_variable_type exp_type = mp->cur_exp.type; + switch (exp_type) { + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + case mp_transform_type: + case mp_color_type: + case mp_pair_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + case mp_cmykcolor_type: + p = cur_exp_node; + break; + default: /* |case mp_path_type: case mp_pen_type: case mp_string_type:| */ + p = mp_new_value_node(mp); + mp_name_type(p) = mp_capsule_operation; + mp_type(p) = mp->cur_exp.type; + mp_set_value_number(p, cur_exp_value_number); /* this also resets the rest to 0/NULL */ + if (cur_exp_str) { + mp_set_value_str(p, cur_exp_str); + } else if (cur_exp_knot) { + mp_set_value_knot(p, cur_exp_knot); + } else if (cur_exp_node) { + mp_set_value_node(p, cur_exp_node); + } + break; + } + mp->cur_exp.type = mp_vacuous_type; + mp_link(p) = MP_VOID; + return p; +} + +@ The inverse of |stash_cur_exp| is the following procedure, which deletes an +unnecessary capsule and puts its contents into |cur_type| and |cur_exp|. + +The program steps of \MP\ can be divided into two categories: those in which +|cur_type| and |cur_exp| are \quote {alive} and those in which they are \quote {dead,} in +the sense that |cur_type| and |cur_exp| contain relevant information or not. It's +important not to ignore them when they're alive, and it's important not to pay +attention to them when they're dead. + +There's also an intermediate category: If |cur_type=mp_vacuous|, then |cur_exp| +is irrelevant, hence we can proceed without caring if |cur_type| and |cur_exp| +are alive or dead. In such cases we say that |cur_type| and |cur_exp| are {\sl +dormant}. It is permissible to call |get_x_next| only when they are alive or +dormant. + +The |stash| procedure above assumes that |cur_type| and |cur_exp| are alive or +dormant. The |unstash| procedure assumes that they are dead or dormant; it +resuscitates them. + +@ @c +void mp_unstash_cur_exp (MP mp, mp_node p) +{ + mp->cur_exp.type = mp_type(p); + switch (mp->cur_exp.type) { + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + case mp_transform_type: + case mp_color_type: + case mp_pair_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + case mp_cmykcolor_type: + mp_set_cur_exp_node(mp, p); + break; + case mp_token_list_type: /* this is how symbols are stashed */ + mp_set_cur_exp_node(mp, mp_get_value_node(p)); + mp_free_value_node(mp, p); + break; + case mp_path_type: + case mp_pen_type: + case mp_nep_type: + mp_set_cur_exp_knot(mp, mp_get_value_knot(p)); + mp_free_value_node(mp, p); + break; + case mp_string_type: + mp_set_cur_exp_str(mp, mp_get_value_str(p)); + mp_free_value_node(mp, p); + break; + case mp_picture_type: + mp_set_cur_exp_node(mp, mp_get_value_node(p)); + mp_free_value_node(mp, p); + break; + case mp_boolean_type: + case mp_known_type: + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(p))); + mp_free_value_node(mp, p); + break; + default: + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(p))); + if (mp_get_value_knot(p)) { + mp_set_cur_exp_knot(mp, mp_get_value_knot(p)); + } else if (mp_get_value_node(p)) { + mp_set_cur_exp_node(mp, mp_get_value_node(p)); + } else if (mp_get_value_str(p)) { + mp_set_cur_exp_str(mp, mp_get_value_str(p)); + } + mp_free_value_node(mp, p); + break; + } +} + +@ The following procedure prints the values of expressions in an abbreviated +format. If its first parameter |p| is NULL, the value of |(cur_type,cur_exp)| is +displayed; otherwise |p| should be a capsule containing the desired value. The +second parameter controls the amount of output. If it is~0, dependency lists will +be abbreviated to |linearform| unless they consist of a single term. If it is +greater than~1, complicated structures (pens, pictures, and paths) will be +displayed in full. @.linearform@> + +@<Declarations@>= +static void mp_print_dp (MP mp, int t, mp_value_node p, int verbosity); +static void mp_unstash_cur_exp (MP mp, mp_node p); +static void mp_print_exp (MP mp, mp_node p, int verbosity); +static void mp_print_big_node (MP mp, mp_node p, int verbosity); + +@ @c +void mp_print_exp (MP mp, mp_node p, int verbosity) +{ + int restore_cur_exp; /* should |cur_exp| be restored? */ + mp_variable_type t; /* the type of the expression */ + mp_number vv; /* the value of the expression */ + mp_node v = NULL; + new_number(vv); + if (p != NULL) { + restore_cur_exp = 0; + } else { + p = mp_stash_cur_exp(mp); + restore_cur_exp = 1; + } + t = mp_type(p); + if (t < mp_dependent_type) { + /* no dep list, could be a capsule */ + if (t != mp_vacuous_type && t != mp_known_type && mp_get_value_node(p) != NULL) { + v = mp_get_value_node(p); + } else { + number_clone(vv, mp_get_value_number(p)); + } + } else if (t < mp_independent_type) { + v = (mp_node) mp_get_dep_list((mp_value_node) p); + } + @<Print an abbreviated value of |v| or |vv| with format depending on |t|@> + if (restore_cur_exp) { + mp_unstash_cur_exp(mp, p); + } + free_number(vv); +} + +void mp_print_big_node (MP mp, mp_node v, int verbosity) +{ + switch (mp_type(v)) { + case mp_known_type: + print_number(mp_get_value_number(v)); + break; + case mp_independent_type: + mp_print_variable_name(mp, v); + break; + default: + mp_print_dp(mp, mp_type(v), (mp_value_node) mp_get_dep_list((mp_value_node) v), verbosity); + break; + } +} + +@ @<Print an abbreviated value of |v| or |vv| with format depending on |t|@>= +switch (t) { + case mp_vacuous_type: + mp_print_str(mp, "vacuous"); + break; + case mp_boolean_type: + mp_print_str(mp, number_to_boolean(vv) == mp_true_operation ? "true": "false"); + break; + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + case mp_numeric_type: + { + @<Display a variable that's been declared but not defined@> + } + break; + case mp_string_type: + mp_print_chr(mp, '"'); + mp_print_mp_str(mp, mp_get_value_str(p)); + mp_print_chr(mp, '"'); + break; + case mp_pen_type: + case mp_nep_type: + case mp_path_type: + case mp_picture_type: + { + @<Display a complex type@> + } + break; + case mp_transform_type: + if (number_zero(vv) && v == NULL) { + mp_print_type(mp, t); + } else { + @<Display a transform node@> + } + break; + case mp_color_type: + if (number_zero(vv) && v == NULL) { + mp_print_type(mp, t); + } else { + @<Display a color node@> + } + break; + case mp_pair_type: + if (number_zero(vv) && v == NULL) { + mp_print_type(mp, t); + } else { + @<Display a pair node@> + } + break; + case mp_cmykcolor_type: + if (number_zero(vv) && v == NULL) { + mp_print_type(mp, t); + } else { + @<Display a cmykcolor node@> + } + break; + case mp_known_type: + print_number(vv); + break; + case mp_dependent_type: + case mp_proto_dependent_type: + mp_print_dp(mp, t, (mp_value_node) v, verbosity); + break; + case mp_independent_type: + mp_print_variable_name(mp, p); + break; + default: + mp_confusion(mp, "expression"); + break; + @:this can't happen exp}{\quad exp@> +} + +@ In these cases, |v| starts as the big node. + +@<Display a pair node@>= +mp_print_chr(mp, '('); +mp_print_big_node(mp, mp_x_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_y_part(v), verbosity); +mp_print_chr(mp, ')'); + +@ @<Display a transform node@>= +mp_print_chr(mp, '('); +mp_print_big_node(mp, mp_tx_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_ty_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_xx_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_xy_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_yx_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_yy_part(v), verbosity); +mp_print_chr(mp, ')'); + +@ @<Display a color node@>= +mp_print_chr(mp, '('); +mp_print_big_node(mp, mp_red_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_green_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_blue_part(v), verbosity); +mp_print_chr(mp, ')'); + +@ @<Display a cmykcolor node@>= +mp_print_chr(mp, '('); +mp_print_big_node(mp, mp_cyan_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_magenta_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_yellow_part(v), verbosity); +mp_print_chr(mp, ','); +mp_print_big_node(mp, mp_black_part(v), verbosity); +mp_print_chr(mp, ')'); + +@ Values of type |picture|, |path|, and |pen| are displayed verbosely in +the log file only, unless the user has given a positive value to +|tracingonline|. + +@<Display a complex type@>= +if (verbosity <= 1) { + mp_print_type(mp, t); +} else { + if (mp->selector == mp_term_and_log_selector) + if (number_nonpositive(internal_value(mp_tracing_online_internal))) { + mp->selector = mp_term_only_selector; + mp_print_type(mp, t); + mp_print_str(mp, " (see the transcript file)"); + mp->selector = mp_term_and_log_selector; + }; + switch (t) { + case mp_pen_type: + case mp_nep_type: + mp_print_pen(mp, mp_get_value_knot(p), "", 0); + break; + case mp_path_type: + mp_print_path(mp, mp_get_value_knot(p), "", 0); + break; + case mp_picture_type: + mp_print_edges(mp, v, "", 0); + break; + default: + break; + } +} + +@ @c +static void mp_print_dp (MP mp, int t, mp_value_node p, int verbosity) +{ + mp_value_node q = (mp_value_node) mp_link(p); /* the node following |p| */ + if ((mp_get_dep_info(q) == NULL) || (verbosity > 0)) { + mp_print_dependency(mp, p, t); + } else { + mp_print_str(mp, "linearform"); + } +} + +@ The displayed name of a variable in a ring will not be a capsule unless +the ring consists entirely of capsules. + +@<Display a variable that's been declared but not defined@>= +{ + mp_print_type(mp, t); + if (v != NULL) { + mp_print_chr(mp, ' '); + while ((mp_name_type(v) == mp_capsule_operation) && (v != p)) { + v = mp_get_value_node(v); + } + mp_print_variable_name(mp, v); + }; +} + +@ When errors are detected during parsing, it is often helpful to display an +expression just above the error message, using |disp_err| just before |mp_error|. + +@<Declarations@>= +static void mp_disp_err (MP mp, mp_node p); + +@ @c +void mp_disp_err (MP mp, mp_node p) +{ + if (mp->interaction >= mp_error_stop_mode) { + wake_up_terminal(); + } + /* mp_print_nl(mp, ">> "); */ + mp_print_nl(mp, "<error> "); + @.>>@> + mp_print_exp(mp, p, 1); +} + +@ If |cur_type| and |cur_exp| contain relevant information that should be +recycled, we will use the following procedure, which changes |cur_type| to +|known| and stores a given value in |cur_exp|. We can think of |cur_type| and +|cur_exp| as either alive or dormant after this has been done, because |cur_exp| +will not contain a pointer value. + +@ @c +void mp_flush_cur_exp (MP mp, mp_value v) +{ + if (is_number(mp->cur_exp.data.n)) { + free_number(mp->cur_exp.data.n); + } + switch (mp->cur_exp.type) { + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + case mp_transform_type: + case mp_color_type: + case mp_pair_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + case mp_cmykcolor_type: + mp_recycle_value(mp, cur_exp_node); + mp_free_value_node(mp, cur_exp_node); + break; + case mp_string_type: + delete_str_ref(cur_exp_str); + break; + case mp_pen_type: + case mp_nep_type: + case mp_path_type: + mp_toss_knot_list(mp, cur_exp_knot); + break; + case mp_picture_type: + mp_delete_edge_ref(mp, cur_exp_node); + break; + default: + break; + } + mp->cur_exp = v; + mp->cur_exp.type = mp_known_type; +} + +@ There's a much more general procedure that is capable of releasing the storage +associated with any non-symbolic value packet. + +@<Declarations@>= +static void mp_recycle_value (MP mp, mp_node p); + +@ @c +static void mp_recycle_value (MP mp, mp_node p) +{ + if (p != NULL && p != MP_VOID) { + mp_variable_type t = mp_type(p); + switch (t) { + case mp_vacuous_type: + case mp_boolean_type: + case mp_known_type: + case mp_numeric_type: + break; + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + mp_ring_delete (mp, p); + break; + case mp_string_type: + delete_str_ref(mp_get_value_str(p)); + break; + case mp_path_type: + case mp_pen_type: + case mp_nep_type: + mp_toss_knot_list(mp, mp_get_value_knot(p)); + break; + case mp_picture_type: + mp_delete_edge_ref(mp, mp_get_value_node(p)); + break; + case mp_cmykcolor_type: + if (mp_get_value_node(p) != NULL) { + mp_recycle_value(mp, mp_cyan_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_magenta_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_yellow_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_black_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_cyan_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_magenta_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_black_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_yellow_part(mp_get_value_node(p))); + mp_free_node(mp, mp_get_value_node(p), sizeof(mp_color_node_data)); + } + break; + case mp_pair_type: + if (mp_get_value_node(p) != NULL) { + mp_recycle_value(mp, mp_x_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_y_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_x_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_y_part(mp_get_value_node(p))); + mp_free_pair_node(mp, mp_get_value_node(p)); + } + break; + case mp_color_type: + if (mp_get_value_node(p) != NULL) { + mp_recycle_value(mp, mp_red_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_green_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_blue_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_red_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_green_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_blue_part(mp_get_value_node(p))); + mp_free_node(mp, mp_get_value_node(p), sizeof(mp_color_node_data)); + } + break; + case mp_transform_type: + if (mp_get_value_node(p) != NULL) { + mp_recycle_value(mp, mp_tx_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_ty_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_xx_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_xy_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_yx_part(mp_get_value_node(p))); + mp_recycle_value(mp, mp_yy_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_tx_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_ty_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_xx_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_xy_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_yx_part(mp_get_value_node(p))); + mp_free_value_node(mp, mp_yy_part(mp_get_value_node(p))); + mp_free_node(mp, mp_get_value_node(p), sizeof(mp_transform_node_data)); + } + break; + case mp_dependent_type: + case mp_proto_dependent_type: + /* Recycle a dependency list */ + { + mp_value_node qq = (mp_value_node) mp_get_dep_list((mp_value_node) p); + while (mp_get_dep_info(qq) != NULL) { + qq = (mp_value_node) mp_link(qq); + } + mp_set_link(mp_get_prev_dep((mp_value_node) p), mp_link(qq)); + mp_set_prev_dep(mp_link(qq), mp_get_prev_dep((mp_value_node) p)); + mp_set_link(qq, NULL); + mp_flush_node_list(mp, (mp_node) mp_get_dep_list((mp_value_node) p)); + } + break; + case mp_independent_type: + mp_recycle_independent_value(mp, p); + break; + case mp_token_list_type: + case mp_structured_type: + mp_confusion(mp, "recycle"); + break; + case mp_unsuffixed_macro_type: + case mp_suffixed_macro_type: + mp_delete_mac_ref(mp, mp_get_value_node(p)); + break; + default: + break; + } + mp_type(p) = mp_undefined_type; + } +} + +@ When an independent variable disappears, it simply fades away, unless something +depends on it. In the latter case, a dependent variable whose coefficient of +dependence is maximal will take its place. The relevant algorithm is due to +Ignacio~A. Zabala, who implemented it as part of his Ph.n->data. thesis (Stanford +University, December 1982). @^Zabala Salelles, Ignacio Andr\'es@> + +For example, suppose that variable $x$ is being recycled, and that the only +variables depending on~$x$ are $y=2x+a$ and $z=x+b$. In this case we want to make +$y$ independent and $z=.5y-.5a+b$; no other variables will depend on~$y$. If +$|tracingequations|>0$ in this situation, we will print |\#\#\# -2x=-y+a|. + +There's a slight complication, however: An independent variable $x$ can occur +both in dependency lists and in proto-dependency lists. This makes it necessary +to be careful when deciding which coefficient is maximal. + +Furthermore, this complication is not so slight when a proto-dependent variable +is chosen to become independent. For example, suppose that $y=2x+100a$ is +proto-dependent while $z=x+b$ is dependent; then we must change $z=.5y-50a+b$ to +a proto-dependency, because of the large coefficient `50'. + +In order to deal with these complications without wasting too much time, we shall +link together the occurrences of~$x$ among all the linear dependencies, +maintaining separate lists for the dependent and proto-dependent cases. + +@<Declarations@>= +static void mp_recycle_independent_value (MP mp, mp_node p); + +@ @c +static void mp_recycle_independent_value (MP mp, mp_node p) +{ + mp_value_node q, r, s; + mp_node pp; /* link manipulation register */ + mp_number v ; /* a value */ + mp_number test; /* a temporary value */ + mp_variable_type t = mp_type(p); + new_number(test); + new_number(v); + if (t < mp_dependent_type) { + number_clone(v, mp_get_value_number(p)); + } + set_number_to_zero(mp->max_c[mp_dependent_type]); + set_number_to_zero(mp->max_c[mp_proto_dependent_type]); + mp->max_link[mp_dependent_type] = NULL; + mp->max_link[mp_proto_dependent_type] = NULL; + q = (mp_value_node) mp_link(mp->dep_head); + while (q != mp->dep_head) { + s = (mp_value_node) mp->temp_head; + mp_set_link(s, mp_get_dep_list(q)); + while (1) { + r = (mp_value_node) mp_link(s); + if (mp_get_dep_info(r) == NULL) { + break; + } else if (mp_get_dep_info(r) != p) { + s = r; + } else { + t = mp_type(q); + if (mp_link(s) == mp_get_dep_list(q)) { + /* reset the |dep_list| */ + mp_set_dep_list(q, mp_link(r)); + } + mp_set_link(s, mp_link(r)); + mp_set_dep_info(r, (mp_node) q); + number_abs_clone(test, mp_get_dep_value(r)); + if (number_greater(test, mp->max_c[t])) { + /* Record a new maximum coefficient of type |t| */ + if (number_positive(mp->max_c[t])) { + mp_set_link(mp->max_ptr[t], (mp_node) mp->max_link[t]); + mp->max_link[t] = mp->max_ptr[t]; + } + number_clone(mp->max_c[t], test); + mp->max_ptr[t] = r; + } else { + mp_set_link(r, mp->max_link[t]); + mp->max_link[t] = r; + } + } + } + q = (mp_value_node) mp_link(r); + } + if (number_positive(mp->max_c[mp_dependent_type]) || number_positive(mp->max_c[mp_proto_dependent_type])) { + /* + Choose a dependent variable to take the place of the disappearing + independent variable, and change all remaining dependencies + accordingly + */ + mp_number test, ret; /* temporary use */ + new_number(ret); + new_number_clone(test, mp->max_c[mp_dependent_type]); + number_divide_int(test, 4096); + if (number_greaterequal(test, mp->max_c[mp_proto_dependent_type])) { + t = mp_dependent_type; + } else { + t = mp_proto_dependent_type; + } + /* + Let |s=max_ptr[t]|. At this point we have + $|value|(s)=\pm|max_c|[t]$, and |mp_get_dep_info(s)| points to the + dependent variable~|pp| of type~|t| from whose dependency list we + have removed node~|s|. We must reinsert node~|s| into the dependency + list, with coefficient $-1.0$, and with |pp| as the new independent + variable. Since |pp| will have a larger serial number than any other + variable, we can put node |s| at the head of the list. + + Determine the dependency list |s| to substitute for the independent + variable~|p| + */ + s = mp->max_ptr[t]; + pp = (mp_node) mp_get_dep_info(s); + number_clone(v, mp_get_dep_value(s)); + if (t == mp_dependent_type) { + mp_set_dep_value(s, fraction_one_t); + } else { + mp_set_dep_value(s, unity_t); + } + number_negate(mp_get_dep_value(s)); + r = (mp_value_node) mp_get_dep_list((mp_value_node) pp); + mp_set_link(s, r); + while (mp_get_dep_info(r) != NULL) { + r = (mp_value_node) mp_link(r); + } + q = (mp_value_node) mp_link(r); + mp_set_link(r, NULL); + mp_set_prev_dep(q, mp_get_prev_dep((mp_value_node) pp)); + mp_set_link(mp_get_prev_dep((mp_value_node) pp), (mp_node) q); + mp_new_indep(mp, pp); + if (cur_exp_node == pp && mp->cur_exp.type == t) { + mp->cur_exp.type = mp_independent_type; + } + if (number_positive(internal_value(mp_tracing_equations_internal)) && mp_interesting(mp, p)) { + mp_begin_diagnostic(mp); + mp_show_transformed_dependency(mp, &v, t, p); + mp_print_dependency(mp, s, t); + mp_end_diagnostic(mp, 0); + } + /* complement |t| */ + t = mp_dependent_type + mp_proto_dependent_type - t; + if (number_positive(mp->max_c[t])) { + /* we need to pick up an unchosen dependency */ + mp_set_link(mp->max_ptr[t], (mp_node) mp->max_link[t]); + mp->max_link[t] = mp->max_ptr[t]; + } + /* + Finally, there are dependent and proto-dependent variables whose + dependency lists must be brought up to date. + */ + if (t != mp_dependent_type) { + /* Substitute new dependencies in place of |p| */ + for (t = mp_dependent_type; t <= mp_proto_dependent_type; t=t+1) { + r = mp->max_link[t]; + while (r != NULL) { + q = (mp_value_node) mp_get_dep_info(r); + number_negated_clone(test, v); + make_fraction(ret, mp_get_dep_value(r), test); + mp_set_dep_list(q, mp_p_plus_fq(mp, (mp_value_node) mp_get_dep_list(q), &ret, s, t, mp_dependent_type)); + if (mp_get_dep_list(q) == (mp_node) mp->dep_final) { + mp_make_known(mp, q, mp->dep_final); + } + q = r; + r = (mp_value_node) mp_link(r); + mp_free_dep_node(mp, q); + } + } + } else { + /* Substitute new proto-dependencies in place of |p| */ + for (t = mp_dependent_type; t <= mp_proto_dependent_type; t++) { + r = mp->max_link[t]; + while (r != NULL) { + q = (mp_value_node) mp_get_dep_info(r); + if (t == mp_dependent_type) { + /* for safety's sake, we change |q| to |mp_proto_dependent| */ + if (cur_exp_node == (mp_node) q && mp->cur_exp.type == mp_dependent_type) { + mp->cur_exp.type = mp_proto_dependent_type; + } + mp_set_dep_list(q, mp_p_over_v(mp, (mp_value_node) mp_get_dep_list(q), &unity_t, mp_dependent_type, mp_proto_dependent_type)); + mp_type(q) = mp_proto_dependent_type; + fraction_to_round_scaled(mp_get_dep_value(r)); + } + number_negated_clone(test, v); + make_scaled(ret, mp_get_dep_value(r), test); + mp_set_dep_list(q, mp_p_plus_fq(mp, (mp_value_node) mp_get_dep_list(q), &ret, s, mp_proto_dependent_type, mp_proto_dependent_type)); + if (mp_get_dep_list(q) == (mp_node) mp->dep_final) { + mp_make_known(mp, q, mp->dep_final); + } + q = r; + r = (mp_value_node) mp_link(r); + mp_free_dep_node(mp, q); + } + } + } + mp_flush_node_list(mp, (mp_node) s); + if (mp->fix_needed) { + mp_fix_dependencies(mp); + } + check_arith(); + free_number(ret); + } + free_number(v); + free_number(test); +} + +@ @<Declarations@>= +static void mp_show_transformed_dependency (MP mp, mp_number *v, mp_variable_type t, mp_node p); + +@ @c +static void mp_show_transformed_dependency (MP mp, mp_number *v, mp_variable_type t, mp_node p) +{ + mp_number vv; /* for temp use */ + mp_print_nl(mp, "### "); + if (number_positive(*v)) { + mp_print_chr(mp, '-'); + } + if (t == mp_dependent_type) { + new_number_clone(vv, mp->max_c[mp_dependent_type]); + fraction_to_round_scaled(vv); + } else { + new_number_clone(vv, mp->max_c[mp_proto_dependent_type]); + } + if (! number_equal(vv, unity_t)) { + print_number(vv); + } + mp_print_variable_name(mp, p); + while (mp_get_indep_scale(p) > 0) { + mp_print_str(mp, "*4"); + mp_set_indep_scale(p, mp_get_indep_scale(p)-2); + } + if (t == mp_dependent_type) { + mp_print_chr(mp, '='); + } else { + mp_print_str(mp, " = "); + } + free_number(vv); +} + +@ The code for independency removal makes use of three non-symbolic arrays. + +@<Glob...@>= +mp_number max_c[mp_proto_dependent_type + 1]; /* max coefficient magnitude */ +mp_value_node max_ptr[mp_proto_dependent_type + 1]; /* where |p| occurs with |max_c| */ +mp_value_node max_link[mp_proto_dependent_type + 1]; /* other occurrences of |p| */ + + +@ @<Initialize table ... @>= +for (int i = 0; i < mp_proto_dependent_type + 1; i++) { + new_number(mp->max_c[i]); +} + +@ @<Dealloc...@>= +for (int i = 0; i < mp_proto_dependent_type + 1; i++) { + free_number(mp->max_c[i]); +} + +@ A global variable |var_flag| is set to a special command code just before \MP\ +calls |scan_expression|, if the expression should be treated as a variable when +this command code immediately follows. For example, |var_flag| is set to +|assignment| at the beginning of a statement, because we want to know the {\sl +location} of a variable at the left of |:=|, not the {\sl value} of that +variable. + +The |scan_expression| subroutine calls |scan_tertiary|, which calls +|scan_secondary|, which calls |scan_primary|, which sets |var_flag:=0|. In this +way each of the scanning routines \quote {knows} when it has been called with a +special |var_flag|, but |var_flag| is usually zero. + +A variable preceding a command that equals |var_flag| is converted to a token +list rather than a value. Furthermore, an |=| sign following an expression +with |var_flag=assignment| is not considered to be a relation that produces +boolean expressions. + +@<Glob...@>= +int var_flag; /* command that wants a variable */ + +@ @<Set init...@>= +mp->var_flag = 0; + +@* Parsing primary expressions. + +The first parsing routine, |scan_primary|, is also the most complicated one, +since it involves so many different cases. But each case---with one +exception---is fairly simple by itself. + +When |scan_primary| begins, the first token of the primary to be scanned should +already appear in |cur_cmd|, |cur_mod|, and |cur_sym|. The values of |cur_type| +and |cur_exp| should be either dead or dormant, as explained earlier. If +|cur_cmd| is not between |min_primary_command| and |max_primary_command|, +inclusive, a syntax error will be signaled. + +Later we'll come to procedures that perform actual operations like addition, +square root, and so on; our purpose now is to do the parsing. But we might as +well mention those future procedures now, so that the suspense won't be too bad: + +\smallskip |do_nullary(c)| does primitive operations that have no operands (e.g., +|true| or |pencircle|); + +\smallskip |do_unary(c)| applies a primitive operation to the current expression; + +\smallskip |do_binary(p,c)| applies a primitive operation to the capsule~|p| and +the current expression. + +@<Declare the basic parsing subroutines@>= +static void check_for_mediation (MP mp); + +static void mp_primary_error(MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + mp_disp_err(mp, NULL); + new_number(new_expr.data.n); + mp_back_error( + mp, + "Nonnumeric part has been replaced by 0", + "I've started to scan a pair (x,y), color (r,g,b), cmykcolor (c,m,y,k) or\n" + "transform (tx,ty,xx,xy,yx,yy) but ran into a non-numeric type. I'll recover\n" + "as good as possible." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); +} + +void mp_scan_primary (MP mp) +{ + mp_command_code my_var_flag = mp->var_flag; + mp->var_flag = 0; + RESTART: + check_arith(); + /* Supply diagnostic information, if requested */ + switch (cur_cmd) { + case mp_left_delimiter_command: + { + /* Scan a delimited primary */ + mp_sym l_delim = cur_sym; + mp_sym r_delim = equiv_sym(cur_sym); + mp_get_x_next(mp); + mp_scan_expression(mp); + if ((cur_cmd == mp_comma_command) && (mp->cur_exp.type >= mp_known_type)) { + /* Scan the rest of a delimited set of numerics. */ + mp_node q = mp_new_value_node(mp); + mp_node p1 = mp_stash_cur_exp(mp); + mp_node r; /* temporary node */ + mp_name_type(q) = mp_capsule_operation; + mp_get_x_next(mp); + mp_scan_expression(mp); + /* Make sure the second part of a pair or color has a numeric type */ + if (mp->cur_exp.type < mp_known_type) { + mp_primary_error(mp); + } + if (cur_cmd != mp_comma_command) { + /* Package the pair. */ + mp_init_pair_node(mp, q); + r = mp_get_value_node(q); + mp_stash_in(mp, mp_y_part(r)); + mp_unstash_cur_exp(mp, p1); + mp_stash_in(mp, mp_x_part(r)); + } else { + mp_node p2 = mp_stash_cur_exp(mp); + /* Scan the last of a triplet of numerics */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type < mp_known_type) { + mp_primary_error(mp); + } + if (cur_cmd != mp_comma_command) { + /* Package the rgb color. */ + mp_init_color_node(mp, q, mp_color_type); + r = mp_get_value_node(q); + mp_stash_in(mp, mp_blue_part(r)); + mp_unstash_cur_exp(mp, p1); + mp_stash_in(mp, mp_red_part(r)); + mp_unstash_cur_exp(mp, p2); + mp_stash_in(mp, mp_green_part(r)); + } else { + mp_node p3 = mp_stash_cur_exp(mp); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type < mp_known_type) { + mp_primary_error(mp); + } + if (cur_cmd != mp_comma_command) { + /* Package the cmyk color. */ + mp_init_color_node(mp, q, mp_cmykcolor_type); + r = mp_get_value_node(q); + mp_stash_in(mp, mp_black_part(r)); + mp_unstash_cur_exp(mp, p1); + mp_stash_in(mp, mp_cyan_part(r)); + mp_unstash_cur_exp(mp, p2); + mp_stash_in(mp, mp_magenta_part(r)); + mp_unstash_cur_exp(mp, p3); + mp_stash_in(mp, mp_yellow_part(r)); + } else { + mp_node p4 = mp_stash_cur_exp(mp); + mp_node p5; + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type < mp_known_type) { + mp_primary_error(mp); + p5 = mp_stash_cur_exp(mp); + goto HERE; + } + if (cur_cmd != mp_comma_command) { + mp_primary_error(mp); + p5 = mp_stash_cur_exp(mp); + goto HERE; + } + p5 = mp_stash_cur_exp(mp); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type < mp_known_type) { + mp_primary_error(mp); + } + HERE: + mp_init_transform_node(mp, q); + /* Package the transform: xx xy yx yy tx ty */ + r = mp_get_value_node(q); + mp_stash_in(mp, mp_ty_part(r)); + mp_unstash_cur_exp(mp, p5); + mp_stash_in(mp, mp_tx_part(r)); + mp_unstash_cur_exp(mp, p4); + mp_stash_in(mp, mp_yy_part(r)); + mp_unstash_cur_exp(mp, p3); + mp_stash_in(mp, mp_yx_part(r)); + mp_unstash_cur_exp(mp, p2); + mp_stash_in(mp, mp_xy_part(r)); + mp_unstash_cur_exp(mp, p1); + mp_stash_in(mp, mp_xx_part(r)); + } + } + } + mp_check_delimiter(mp, l_delim, r_delim); + mp->cur_exp.type = mp_type(q); + mp_set_cur_exp_node(mp, q); + } else { + mp_check_delimiter(mp, l_delim, r_delim); + } + } + break; + case mp_begin_group_command: + /* Scan a grouped primary. The local variable |group_line| keeps + track of the line where a |begingroup| command occurred; this + will be useful in an error message if the group doesn't actually + end. + */ + { + int group_line = mp_true_line(mp); /* where a group began */ + if (number_positive(internal_value(mp_tracing_commands_internal))) { + mp_show_cmd_mod(mp, cur_cmd, cur_mod); + } + mp_save_boundary(mp); + do { + mp_do_statement(mp); /* ends with |cur_cmd>=semicolon| */ + } while (cur_cmd == mp_semicolon_command); + if (cur_cmd != mp_end_group_command) { + char msg[256]; + mp_snprintf(msg, 256, "A group begun on line %d never ended", (int) group_line); + mp_back_error( + mp, + msg, + "I saw a 'begingroup' back there that hasn't been matched by 'endgroup'. So I've\n" + "inserted 'endgroup' now." + ); + set_cur_cmd(mp_end_group_command); + } + mp_unsave(mp); + /* this might change |cur_type|, if independent variables are recycled */ + if (number_positive(internal_value(mp_tracing_commands_internal))) { + mp_show_cmd_mod(mp, cur_cmd, cur_mod); + } + } + break; + case mp_string_command: + /* Scan a string constant */ + mp->cur_exp.type = mp_string_type; + mp_set_cur_exp_str(mp, cur_mod_str); + break; + case mp_numeric_command: + { + /* + Scan a primary that starts with a numeric token. A numeric token + might be a primary by itself, or it might be the numerator of a + fraction composed solely of numeric tokens, or it might multiply + the primary that follows (provided that the primary doesn't begin + with a plus sign or a minus sign). The code here uses the facts + that |max_primary_command=plus_or_minus| and + |max_primary_command-1=numeric_token|. If a fraction is found + that is less than unity, we try to retain higher precision when + we use it in scalar multiplication. + */ + mp_number num, denom; /* for primaries that are fractions, like `1/2' */ + mp_set_cur_exp_value_number(mp, &cur_mod_number); + mp->cur_exp.type = mp_known_type; + mp_get_x_next(mp); +//new_number(num); +//new_number(denom); + if (cur_cmd != mp_slash_command) { + new_number(num); + new_number(denom); + } else { + mp_get_x_next(mp); + if (cur_cmd != mp_numeric_command) { + mp_back_input(mp); + set_cur_cmd(mp_slash_command); + set_cur_mod(mp_over_operation); + set_cur_sym(mp->frozen_slash); +// goto DONOTHING; + goto DONE; + } else { + new_number_clone(num, cur_exp_value_number); + new_number_clone(denom, cur_mod_number); +//number_clone(num, cur_exp_value_number); +//number_clone(denom, cur_mod_number); + if (number_zero(denom)) { + mp_error(mp, "Division by zero", "I'll pretend that you meant to divide by 1."); + } else { + mp_number ret; + new_number(ret); + make_scaled(ret, num, denom); + mp_set_cur_exp_value_number(mp, &ret); + free_number(ret); + } + check_arith(); + mp_get_x_next(mp); + } + } + if (cur_cmd >= mp_min_primary_command && cur_cmd < mp_numeric_command) { + /* in particular, |cur_cmd<>plus_or_minus| */ + mp_number absnum, absdenom; + mp_node p = mp_stash_cur_exp(mp); + mp_scan_primary(mp); + new_number_abs(absnum, num); + new_number_abs(absdenom, denom); + if (number_greaterequal(absnum, absdenom) || (mp->cur_exp.type < mp_color_type)) { + mp_do_binary(mp, p, mp_times_operation); + } else { + mp_frac_mult(mp, &num, &denom); + mp_free_value_node(mp, p); + } + free_number(absnum); + free_number(absdenom); + } +// DONOTHING: + free_number(num); + free_number(denom); + goto DONE; + } + case mp_nullary_command: + /* Scan a nullary operation */ + mp_do_nullary(mp, (int) cur_mod); + break; + case mp_unary_command: + case mp_type_name_command: + case mp_cycle_command: + case mp_plus_or_minus_command: + { + /* Scan a unary operation */ + int c = (int) cur_mod; /* a primitive operation code */ + mp_get_x_next(mp); + mp_scan_primary(mp); + mp_do_unary(mp, c); + goto DONE; + } + case mp_of_binary_command: + { + /* Scan a binary operation with |of| between its operands */ + mp_node p; /* for list manipulation */ + int c = (int) cur_mod; /* a primitive operation code */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if (cur_cmd != mp_of_command) { + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_cmd_mod(mp, mp_of_binary_command, c); + mp->selector = selector; + sname = mp_make_string(mp); + mp_snprintf(msg, 256, "Missing 'of' has been inserted for %s", mp_str(mp, sname)); + delete_str_ref(sname); + mp_back_error(mp, msg, "I've got the first argument; will look now for the other."); + } + p = mp_stash_cur_exp(mp); + mp_get_x_next(mp); + mp_scan_primary(mp); + mp_do_binary(mp, p, c); + goto DONE; + } + case mp_str_command: + { + /* Convert a suffix to a string */ + int selector = mp->selector; + mp_get_x_next(mp); + mp_scan_suffix(mp); + mp->selector = mp_new_string_selector; + /* Here the periods creep in, we could have a simple one. */ + mp_show_token_list(mp, cur_exp_node, NULL); + /* */ + mp_flush_token_list(mp, cur_exp_node); + mp_set_cur_exp_str(mp, mp_make_string(mp)); + mp->selector = selector; + mp->cur_exp.type = mp_string_type; + goto DONE; + } + case mp_void_command: + { + /* Convert a suffix to a boolean */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + mp_scan_suffix(mp); + if (cur_exp_node == NULL) { + set_number_from_boolean(new_expr.data.n, mp_true_operation); + } else { + set_number_from_boolean(new_expr.data.n, mp_false_operation); + } + mp_flush_cur_exp(mp, new_expr); + cur_exp_node = NULL; /* !! do not replace with |mp_set_cur_exp_node(mp, )| !! */ + mp->cur_exp.type = mp_boolean_type; + goto DONE; + } + case mp_internal_command: + /* + Scan an internal numeric quantity. If an internal quantity appears + all by itself on the left of an assignment, we return a token + list of length one, containing the address of the internal + quantity, with |name_type| equal to |mp_internal_operation|. (This + accords with the conventions of the save stack, as described + earlier.) + */ + { + int qq = cur_mod; + if (my_var_flag == mp_assignment_command) { + mp_get_x_next(mp); + if (cur_cmd == mp_assignment_command) { + mp_set_cur_exp_node(mp, mp_new_symbolic_node(mp)); + mp_set_sym_info(cur_exp_node, qq); + mp_name_type(cur_exp_node) = mp_internal_operation; + mp->cur_exp.type = mp_token_list_type; + goto DONE; + } + mp_back_input(mp); + } + if (internal_type(qq) == mp_string_type) { + mp_set_cur_exp_str(mp, internal_string(qq)); + } else { + mp_set_cur_exp_value_number(mp, &(internal_value(qq))); + // if (qq == mp_tracing_online_internal) { + // mp->run_internal(mp, 3, qq, number_to_int(internal_value(qq)), internal_name(qq)); + // } + } + mp->cur_exp.type = internal_type(qq); + } + break; + case mp_capsule_command: + mp_make_exp_copy(mp, cur_mod_node); + break; + case mp_tag_command: + @<Scan a variable primary; |goto restart| if it turns out to be a macro@> + break; + default: + mp_bad_exp(mp, "A primary"); + goto RESTART; + break; + } + mp_get_x_next(mp); /* the routines |goto done| if they don't want this */ + DONE: + check_for_mediation(mp); +} + +@ Expressions of the form |a[b,c]| are converted into |b+a*(c-b)|, +without checking the types of \.b~or~\.c, provided that \.a is numeric. + +@<Declare the basic parsing subroutines@>= +static void check_for_mediation (MP mp) +{ + if (cur_cmd == mp_left_bracket_command && mp->cur_exp.type >= mp_known_type) { + /* Scan a mediation construction */ + mp_node p = mp_stash_cur_exp(mp); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (cur_cmd != mp_comma_command) { + /* + Put the left bracket and the expression back to be rescanned. + The left bracket that we thought was introducing a subscript + might have actually been the left bracket in a mediation + construction like |x[a,b]|. So we don't issue an error + message at this point; but we do want to back up so as to + avoid any embarrassment about our incorrect assumption. + */ + mp_back_input(mp); + /* that was the token following the current expression */ + mp_back_expr(mp); + set_cur_cmd(mp_left_bracket_command); + set_cur_mod_number(zero_t); + set_cur_sym(mp->frozen_left_bracket); + mp_unstash_cur_exp(mp, p); + } else { + mp_node q = mp_stash_cur_exp(mp); + mp_node r; + mp_get_x_next(mp); + mp_scan_expression(mp); + if (cur_cmd != mp_right_bracket_command) { + mp_back_error( + mp, + "Missing ']' has been inserted", + "I've scanned an expression of the form 'a[b,c', so a right bracket should have\n" + "come next. I shall pretend that one was there." + ); + } + r = mp_stash_cur_exp(mp); + mp_make_exp_copy(mp, q); + mp_do_binary(mp, r, mp_minus_operation); + mp_do_binary(mp, p, mp_times_operation); + mp_do_binary(mp, q, mp_plus_operation); + mp_get_x_next(mp); + } + } +} + +@ Errors at the beginning of expressions are flagged by |bad_exp|. + +@c +static void mp_bad_exp (MP mp, const char *s) +{ + char msg[256]; + int save_flag; + @:METAFONTbook}{\sl The {\logos METAFONT}book@> + { + mp_string cm; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_cmd_mod(mp, cur_cmd, cur_mod); + mp->selector = selector; + cm = mp_make_string(mp); + mp_snprintf(msg, 256, "%s expression can't begin with '%s'", s, mp_str(mp, cm)); + delete_str_ref(cm); + } + mp_back_input(mp); + set_cur_sym(NULL); + set_cur_cmd(mp_numeric_command); + set_cur_mod_number(zero_t); + mp_ins_error( + mp, + msg, + "I'm afraid I need some sort of value in order to continue, so I've tentatively\n" + "inserted '0'." + ); + save_flag = mp->var_flag; + mp->var_flag = 0; + mp_get_x_next(mp); + mp->var_flag = save_flag; +} + + +@ The |stash_in| subroutine puts the current (numeric) expression into a field +within a \quote {big node.} + +@c +static void mp_stash_in (MP mp, mp_node p) +{ + mp_type(p) = mp->cur_exp.type; + if (mp->cur_exp.type == mp_known_type) { + mp_set_value_number(p, cur_exp_value_number); + } else if (mp->cur_exp.type == mp_independent_type) { + /* + Stash an independent |cur_exp| into a big node. In rare cases the current + expression can become |independent|. There may be many dependency lists + pointing to such an independent capsule, so we can't simply move it into + place within a big node. Instead, we copy it, then recycle it. + */ + mp_value_node q = mp_single_dependency(mp, cur_exp_node); + if (q == mp->dep_final) { + mp_type(p) = mp_known_type; + mp_set_value_number(p, zero_t); + mp_free_dep_node(mp, q); + } else { + mp_new_dep(mp, p, mp_dependent_type, q); + } + mp_recycle_value(mp, cur_exp_node); + mp_free_value_node(mp, cur_exp_node); + } else { + mp_set_dep_list((mp_value_node) p, mp_get_dep_list((mp_value_node) cur_exp_node)); + mp_set_prev_dep((mp_value_node) p, mp_get_prev_dep((mp_value_node) cur_exp_node)); + mp_set_link(mp_get_prev_dep((mp_value_node) p), p); + mp_free_dep_node(mp, (mp_value_node) cur_exp_node); + } + mp->cur_exp.type = mp_vacuous_type; +} + +@ The most difficult part of |scan_primary| has been saved for last, since it was +necessary to build up some confidence first. We can now face the task of scanning +a variable. + +As we scan a variable, we build a token list containing the relevant names and +subscript values, simultaneously following along in the \quote {collective} structure +to see if we are actually dealing with a macro instead of a value. + +The local variables |pre_head| and |post_head| will point to the beginning of the +prefix and suffix lists; |tail| will point to the end of the list that is +currently growing. + +Another local variable, |tt|, contains partial information about the declared +type of the variable-so-far. If |tt>=mp_unsuffixed_macro|, the relation +|tt=mp_type(q)| will always hold. If |tt=undefined|, the routine doesn't bother +to update its information about type. And if |undefined<tt<mp_unsuffixed_macro|, +the precise value of |tt| isn't critical. + +@ @<Scan a variable primary...@>= +{ + mp_node p = 0; /* for list manipulation */ + mp_node q = 0; /* for list manipulation */ + mp_node t = 0; + mp_node macro_ref = 0; /* reference count for a suffixed macro */ + int tt = mp_vacuous_type; /* approximation to the type of the variable-so-far */ + mp_node pre_head = mp_new_symbolic_node(mp); + mp_node tail = pre_head; + mp_node post_head = NULL; + while (1) { + t = mp_cur_tok(mp); + mp_link(tail) = t; + if (tt != mp_undefined_type) { + /* + Find the approximate type |tt| and corresponding~|q|. Every time we call + |get_x_next|, there's a chance that the variable we've been looking at + will disappear. Thus, we cannot safely keep |q| pointing into the + variable structure; we need to start searching from the root each time. + */ + mp_sym qq; + p = mp_link(pre_head); + qq = mp_get_sym_sym(p); + tt = mp_undefined_type; + // if (eq_type(qq) % mp_outer_tag_command == mp_tag_command) { + if (eq_type(qq) == mp_tag_command) { + q = equiv_node(qq); + if (q == NULL) { + goto DONE2; + } + while (1) { + p = mp_link(p); + if (p == NULL) { + tt = mp_type(q); + goto DONE2; + } + if (mp_type(q) != mp_structured_type) { + goto DONE2; + } + q = mp_link(mp_get_attribute_head(q)); /* the |mp_collective_subscript| attribute */ + if (mp_type(p) == mp_symbol_node_type) { + /* it's not a subscript */ + do { + q = mp_link(q); + } while (! (mp_get_hashloc(q) >= mp_get_sym_sym(p))); + if (mp_get_hashloc(q) > mp_get_sym_sym(p)) { + goto DONE2; + } + } + } + } + DONE2: + if (tt >= mp_unsuffixed_macro_type) { + /* Either begin an unsuffixed macro call or prepare for a suffixed one */ + mp_link(tail) = NULL; + if (tt > mp_unsuffixed_macro_type) { + /* |tt=mp_suffixed_macro| */ + post_head = mp_new_symbolic_node(mp); + tail = post_head; + mp_link(tail) = t; + tt = mp_undefined_type; + macro_ref = mp_get_value_node(q); + mp_add_mac_ref(macro_ref); + } else { + /* + Set up unsuffixed macro call and |goto restart|. The only + complication associated with macro calling is that the + prefix and \quote {at} parameters must be packaged in an + appropriate list of lists. + */ + p = mp_new_symbolic_node(mp); + mp_set_sym_sym(pre_head, mp_link(pre_head)); + mp_link(pre_head) = p; + mp_set_sym_sym(p, t); + mp_macro_call(mp, mp_get_value_node(q), pre_head, NULL); + mp_get_x_next(mp); + goto RESTART; + } + } + } + mp_get_x_next(mp); + tail = t; + if (cur_cmd == mp_left_bracket_command) { + /* Scan for a subscript; replace |cur_cmd| by |numeric_token| if found */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if (cur_cmd != mp_right_bracket_command) { + /* + Put the left bracket and the expression back to be rescanned. + The left bracket that we thought was introducing a subscript + might have actually been the left bracket in a mediation + construction like |x[a,b]|. So we don't issue an error + message at this point; but we do want to back up so as to + avoid any embarrassment about our incorrect assumption. + */ + mp_back_input(mp); /* that was the token following the current expression */ + mp_back_expr(mp); + set_cur_cmd(mp_left_bracket_command); + set_cur_mod_number(zero_t); + set_cur_sym(mp->frozen_left_bracket); + } else { + if (mp->cur_exp.type != mp_known_type) { + mp_bad_subscript(mp); + } + set_cur_cmd(mp_numeric_command); + set_cur_mod_number(cur_exp_value_number); + set_cur_sym(NULL); + } + } + if (cur_cmd > mp_max_suffix_token) { + break; + } else if (cur_cmd < mp_min_suffix_token) { + break; + } + } + /* + Now |cur_cmd| is |internal_quantity|, |tag_token|, or |numeric_token|. + Handle unusual cases that masquerade as variables, and |goto restart| or + |goto done| if appropriate; otherwise make a copy of the variable and + |goto done| If the variable does exist, we also need to check for a few + other special cases before deciding that a plain old ordinary variable + has, indeed, been scanned. + */ + if (post_head != NULL) { + /* + Set up suffixed macro call and |goto restart|. If the \quote {variable} + that turned out to be a suffixed macro no longer exists, we don't + care, because we have reserved a pointer (|macro_ref|) to its token + list. + */ + mp_back_input(mp); + p = mp_new_symbolic_node(mp); + q = mp_link(post_head); + mp_set_sym_sym(pre_head, mp_link(pre_head)); + mp_link(pre_head) = post_head; + mp_set_sym_sym(post_head, q); + mp_link(post_head) = p; + mp_set_sym_sym(p, mp_link(q)); + mp_link(q) = NULL; + mp_macro_call(mp, macro_ref, pre_head, NULL); + mp_decr_mac_ref(macro_ref); + mp_get_x_next(mp); + goto RESTART; + } + q = mp_link(pre_head); + mp_free_symbolic_node(mp, pre_head); + if (cur_cmd == my_var_flag) { + mp->cur_exp.type = mp_token_list_type; + mp_set_cur_exp_node(mp, q); + goto DONE; + } + p = mp_find_variable(mp, q); + if (p != NULL) { + mp_make_exp_copy(mp, p); + } else { + mp_value new_expr; + char *msg = mp_obliterated (mp, q); + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_back_error( + mp, + msg, + "While I was evaluating the suffix of this variable, something was redefined, and\n" + "it's no longer a variable! In order to get back on my feet, I've inserted '0'\n" + "instead." + ); + mp_memory_free(msg); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + mp_flush_node_list(mp, q); + goto DONE; +} + +@ Here's a routine that puts the current expression back to be read again. + +@c +static void mp_back_expr (MP mp) +{ + mp_node p = mp_stash_cur_exp(mp); /* capsule token */ + mp_link(p) = NULL; + mp_begin_token_list(mp, p, mp_backed_up_text); +} + +@ Unknown subscripts lead to the following error message. + +@c +static void mp_bad_subscript (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_error( + mp, + "Improper subscript has been replaced by zero", + "A bracketed subscript must have a known numeric value; unfortunately, what I\n" + "found was the value that appears just above this error message. So I'll try a\n" + "zero subscript." + ); + @.Improper subscript...@> + mp_flush_cur_exp(mp, new_expr); +} + +@ How do things stand now? Well, we have scanned an entire variable name, +including possible subscripts and/or attributes; |cur_cmd|, |cur_mod|, and +|cur_sym| represent the token that follows. If |post_head=NULL|, a token list for +this variable name starts at |mp_link(pre_head)|, with all subscripts evaluated. +But if |post_head<>NULL|, the variable turned out to be a suffixed macro; +|pre_head| is the head of the prefix list, while |post_head| is the head of a +token list containing both |\AT!| and the suffix. + +Our immediate problem is to see if this variable still exists. (Variable +structures can change drastically whenever we call |get_x_next|; users aren't +supposed to do this, but the fact that it is possible means that we must be +cautious.) + +The following procedure creates an error message for when a variable unexpectedly +disappears. + +@c +static char *mp_obliterated (MP mp, mp_node q) +{ + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_show_token_list(mp, q, NULL); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Variable %s has been obliterated", mp_str(mp, sname)); + @.Variable...obliterated@> + delete_str_ref(sname); + return mp_strdup(msg); +} + +@ Our remaining job is simply to make a copy of the value that has been found. +Some cases are harder than others, but complexity arises solely because of the +multiplicity of possible cases. + +@<Declare the procedure called |make_exp_copy|@>= +@<Declare subroutines needed by |make_exp_copy|@> +static void mp_make_exp_copy (MP mp, mp_node p) +{ + RESTART: + mp->cur_exp.type = mp_type(p); + switch (mp->cur_exp.type) { + case mp_vacuous_type: + case mp_boolean_type: + case mp_known_type: + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(p))); + break; + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + { + mp_node t = mp_new_ring_entry(mp, p); + mp_set_cur_exp_node(mp, t); + } + break; + case mp_string_type: + mp_set_cur_exp_str(mp, mp_get_value_str(p)); + break; + case mp_picture_type: + mp_set_cur_exp_node(mp, mp_get_value_node(p)); + mp_add_edge_ref(mp, cur_exp_node); + break; + case mp_pen_type: + case mp_nep_type: + mp_set_cur_exp_knot(mp, mp_copy_pen(mp, mp_get_value_knot(p))); + break; + case mp_path_type: + mp_set_cur_exp_knot(mp, mp_copy_path(mp, mp_get_value_knot(p))); + break; + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + { + /* + Copy the big node |p|. The most tedious case arises when the user + refers to a |pair|, |color|, or |transform| variable; we must + copy several fields, each of which can be |independent|, |dependent|, + |mp_proto_dependent|, or |known|. + */ + mp_node t; + mp_value_node q; + if (mp_get_value_node(p) == NULL) { + switch (mp_type(p)) { + case mp_pair_type: + mp_init_pair_node(mp, p); + break; + case mp_color_type: + mp_init_color_node(mp, p, mp_color_type); + break; + case mp_cmykcolor_type: + mp_init_color_node(mp, p, mp_cmykcolor_type); + break; + case mp_transform_type: + mp_init_transform_node(mp, p); + break; + default: + break; + } + } + t = mp_new_value_node(mp); + mp_name_type(t) = mp_capsule_operation; + q = (mp_value_node) mp_get_value_node(p); + switch (mp->cur_exp.type) { + case mp_pair_type: + mp_init_pair_node(mp, t); + mp_install(mp, mp_y_part(mp_get_value_node(t)), mp_y_part(q)); + mp_install(mp, mp_x_part(mp_get_value_node(t)), mp_x_part(q)); + break; + case mp_color_type: + mp_init_color_node(mp, t, mp_color_type); + mp_install(mp, mp_blue_part(mp_get_value_node(t)), mp_blue_part(q)); + mp_install(mp, mp_green_part(mp_get_value_node(t)), mp_green_part(q)); + mp_install(mp, mp_red_part(mp_get_value_node(t)), mp_red_part(q)); + break; + case mp_cmykcolor_type: + mp_init_color_node(mp, t, mp_cmykcolor_type); + mp_install(mp, mp_black_part(mp_get_value_node(t)), mp_black_part(q)); + mp_install(mp, mp_yellow_part(mp_get_value_node(t)), mp_yellow_part(q)); + mp_install(mp, mp_magenta_part(mp_get_value_node(t)), mp_magenta_part(q)); + mp_install(mp, mp_cyan_part(mp_get_value_node(t)), mp_cyan_part(q)); + break; + case mp_transform_type: + mp_init_transform_node(mp, t); + mp_install(mp, mp_yy_part(mp_get_value_node(t)), mp_yy_part(q)); + mp_install(mp, mp_yx_part(mp_get_value_node(t)), mp_yx_part(q)); + mp_install(mp, mp_xy_part(mp_get_value_node(t)), mp_xy_part(q)); + mp_install(mp, mp_xx_part(mp_get_value_node(t)), mp_xx_part(q)); + mp_install(mp, mp_ty_part(mp_get_value_node(t)), mp_ty_part(q)); + mp_install(mp, mp_tx_part(mp_get_value_node(t)), mp_tx_part(q)); + break; + default: + break; + } + mp_set_cur_exp_node(mp, t); + } + break; + case mp_dependent_type: + case mp_proto_dependent_type: + mp_encapsulate (mp, mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) p))); + break; + case mp_numeric_type: + mp_new_indep(mp, p); + goto RESTART; + case mp_independent_type: + { + mp_value_node q = mp_single_dependency(mp, p); + if (q == mp->dep_final) { + mp->cur_exp.type = mp_known_type; + mp_set_cur_exp_value_number(mp, &zero_t); + mp_free_dep_node(mp, q); + } else { + mp->cur_exp.type = mp_dependent_type; + mp_encapsulate (mp, q); + } + } + break; + case mp_undefined_type: + mp_confusion(mp, "undefined copy"); + break; + default: + mp_confusion(mp, "copy"); + @:this can't happen copy}{\quad copy@> + break; + } +} + +@ The |encapsulate| subroutine assumes that |dep_final| is the tail of dependency +list~|p|. + +@<Declare subroutines needed by |make_exp_copy|@>= +static void mp_encapsulate (MP mp, mp_value_node p) +{ + mp_node q = mp_new_value_node(mp); + mp_name_type(q) = mp_capsule_operation; + mp_new_dep(mp, q, mp->cur_exp.type, p); + mp_set_cur_exp_node(mp, q); +} + +@ The |install| procedure copies a numeric field~|q| into field~|r| of +a big node that will be part of a capsule. + +@<Declare subroutines needed by |make_exp_copy|@>= +static void mp_install (MP mp, mp_node r, mp_node q) +{ + if (mp_type(q) == mp_known_type) { + mp_type(r) = mp_known_type; + mp_set_value_number(r, mp_get_value_number(q)); + } else if (mp_type(q) == mp_independent_type) { + mp_value_node p = mp_single_dependency(mp, q); + if (p == mp->dep_final) { + mp_type(r) = mp_known_type; + mp_set_value_number(r, zero_t); + mp_free_dep_node(mp, p); + } else { + mp_new_dep(mp, r, mp_dependent_type, p); + } + } else { + mp_new_dep(mp, r, mp_type(q), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) q))); + } +} + +@ Here is a comparatively simple routine that is used to scan the |suffix| +parameters of a macro. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_suffix (MP mp) +{ + mp_node h = mp_new_symbolic_node(mp); /* head of the list being built */ + mp_node t = h; /* tail of the list being built */ + while (1) { + mp_node p; + if (cur_cmd == mp_left_bracket_command) { + /* Scan a bracketed subscript and set |cur_cmd:=numeric_token| */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_bad_subscript(mp); + } + if (cur_cmd != mp_right_bracket_command) { + mp_back_error( + mp, + "Missing ']' has been inserted", + "I've seen a '[' and a subscript value, in a suffix, so a right bracket should\n" + "have come next. I shall pretend that one was there." + ); + } + set_cur_cmd(mp_numeric_command); + set_cur_mod_number(cur_exp_value_number); + } + if (cur_cmd == mp_numeric_command) { + mp_number arg1; + new_number_clone(arg1, cur_mod_number); + p = mp_new_num_tok(mp, &arg1); + free_number(arg1); + } else if ((cur_cmd == mp_tag_command) || (cur_cmd == mp_internal_command)) { + p = mp_new_symbolic_node(mp); + mp_set_sym_sym(p, cur_sym); + mp_name_type(p) = cur_sym_mod; + } else { + break; + } + mp_link(t) = p; + t = p; + mp_get_x_next(mp); + } + mp_set_cur_exp_node(mp, mp_link(h)); + mp_free_symbolic_node(mp, h); + mp->cur_exp.type = mp_token_list_type; +} + +@* Parsing secondary and higher expressions. + +After the intricacies of |scan_primary|\kern-1pt, the |scan_secondary| routine is +refreshingly simple. It's not trivial, but the operations are relatively +straightforward; the main difficulty is, again, that expressions and data +structures might change drastically every time we call |get_x_next|, so a +cautious approach is mandatory. For example, a macro defined by |primarydef| +might have disappeared by the time its second argument has been scanned; we solve +this by increasing the reference count of its token list, so that the macro can +be called even after it has been clobbered. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_secondary (MP mp) +{ + mp_node cc = NULL; + mp_sym mac_name = NULL; /* token defined with |primarydef| */ + RESTART: + if ((cur_cmd < mp_min_primary_command) || (cur_cmd > mp_max_primary_command)) { + mp_bad_exp(mp, "A secondary"); + } + @.A secondary expression...@> + mp_scan_primary(mp); + CONTINUE: + if (cur_cmd <= mp_max_secondary_command && cur_cmd >= mp_min_secondary_command) { + mp_node p = mp_stash_cur_exp(mp); + int d = cur_cmd; + int c = cur_mod; + if (d == mp_primary_def_command) { + cc = cur_mod_node; + mac_name = cur_sym; + mp_add_mac_ref(cc); + } + mp_get_x_next(mp); + mp_scan_primary(mp); + if (d != mp_primary_def_command) { + mp_do_binary(mp, p, c); + } else { + mp_back_input(mp); + mp_binary_mac(mp, p, cc, mac_name); + mp_decr_mac_ref(cc); + mp_get_x_next(mp); + goto RESTART; + } + goto CONTINUE; + } +} + +@ The following procedure calls a macro that has two parameters, |p| and +|cur_exp|. + +@c +static void mp_binary_mac (MP mp, mp_node p, mp_node c, mp_sym n) +{ + mp_node q = mp_new_symbolic_node(mp); + mp_node r = mp_new_symbolic_node(mp); + mp_link(q) = r; + mp_set_sym_sym(q, p); + mp_set_sym_sym(r, mp_stash_cur_exp(mp)); + mp_macro_call(mp, c, q, n); +} + +@ The next procedure, |scan_tertiary|, is pretty much the same deal. + +@<Declare the basic parsing subroutines@>= +static void mp_scan_tertiary (MP mp) +{ + mp_node cc = NULL; + mp_sym mac_name = NULL; /* token defined with |secondarydef| */ + RESTART: + if ((cur_cmd < mp_min_primary_command) || (cur_cmd > mp_max_primary_command)) { + mp_bad_exp(mp, "A tertiary"); + } + @.A tertiary expression...@> + mp_scan_secondary(mp); + CONTINUE: + if (cur_cmd <= mp_max_tertiary_command && cur_cmd >= mp_min_tertiary_command) { + mp_node p = mp_stash_cur_exp(mp); + int c = cur_mod; + int d = cur_cmd; + if (d == mp_secondary_def_command) { + cc = cur_mod_node; + mac_name = cur_sym; + mp_add_mac_ref(cc); + } + mp_get_x_next(mp); + mp_scan_secondary(mp); + if (d != mp_secondary_def_command) { + mp_do_binary(mp, p, c); + } else { + mp_back_input(mp); + mp_binary_mac(mp, p, cc, mac_name); + mp_decr_mac_ref(cc); + mp_get_x_next(mp); + goto RESTART; + } + goto CONTINUE; + } +} + +@ Finally we reach the deepest level in our quartet of parsing routines. +This one is much like the others; but it has an extra complication from +paths, which materialize here. + +@<Declare the basic parsing subroutines@>= + +static int mp_scan_path (MP mp); + +static void mp_scan_expression (MP mp) +{ + int my_var_flag = mp->var_flag; + mp_check_expansion_depth(mp); + RESTART: + if ((cur_cmd < mp_min_primary_command) || (cur_cmd > mp_max_primary_command)) { + mp_bad_exp(mp, "An"); + } + @.An expression...@> + mp_scan_tertiary(mp); + CONTINUE: + if (cur_cmd <= mp_max_expression_command) { + if (cur_cmd >= mp_min_expression_command) { + if ((cur_cmd != mp_equals_command) || (my_var_flag != mp_assignment_command)) { + mp_node cc = NULL; + mp_sym mac_name; /* token defined with |tertiarydef| */ + mac_name = NULL; + mp_node p = mp_stash_cur_exp(mp); + int d = cur_cmd; + int c = cur_mod; + if (d == mp_tertiary_def_command) { + cc = cur_mod_node; + mac_name = cur_sym; + mp_add_mac_ref(cc); + } + if ((d < mp_ampersand_command) || ((d == mp_ampersand_command) && ((mp_type(p) == mp_pair_type) || (mp_type(p) == mp_path_type)))) { + /* Scan a path construction operation; but |return| if |p| has the wrong type */ + mp_unstash_cur_exp(mp, p); + if (! mp_scan_path(mp)) { + mp->expand_depth_count--; + return; + } + } else { + mp_get_x_next(mp); + mp_scan_tertiary(mp); + if (d != mp_tertiary_def_command) { + mp_do_binary(mp, p, c); + } else { + mp_back_input(mp); + mp_binary_mac(mp, p, cc, mac_name); + mp_decr_mac_ref(cc); + mp_get_x_next(mp); + goto RESTART; + } + } + goto CONTINUE; + } + } + } + mp->expand_depth_count--; +} + +@ The reader should review the data structure conventions for paths before hoping +to understand the next part of this code. + +@d min_tension three_quarter_unit_t + +@<Declare the basic parsing subroutines@>= +static void force_valid_tension_setting (MP mp) +{ + if ((mp->cur_exp.type != mp_known_type) || number_less(cur_exp_value_number, min_tension)) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + number_clone(new_expr.data.n, unity_t); + mp_back_error( + mp, + "Improper tension has been set to 1", + "The expression above should have been a number >= 3/4." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } +} + +static int mp_scan_path (MP mp) +{ + mp_knot path_p, path_q, r; + mp_knot pp = NULL; + mp_knot qq = NULL; + int d, dd; /* operation code or modifier */ + int cycle_hit = 0; /* did a path expression just end with |cycle|? */ + mp_number x, y; /* explicit coordinates or tension at a path join */ + int t = mp_endpoint_knot; /* knot type following a path join */ + /* + Convert the left operand, |p|, into a partial path ending at~|q|; but + |return| if |p| doesn't have a suitable type + */ + if (mp->cur_exp.type == mp_pair_type) { + path_p = mp_pair_to_knot(mp); + } else if (mp->cur_exp.type == mp_path_type) { + path_p = cur_exp_knot; + } else { + return 0; + } + path_q = path_p; + while (mp_next_knot(path_q) != path_p) { + path_q = mp_next_knot(path_q); + } + if (mp_left_type(path_p) != mp_endpoint_knot) { + /* open up a cycle */ + r = mp_copy_knot(mp, path_p); + mp_prev_knot(r) = path_q; + mp_next_knot(path_q) = r; + path_q = r; + } + mp_left_type(path_p) = mp_open_knot; + mp_right_type(path_q) = mp_open_knot; + new_number(y); + new_number(x); + CONTINUE_PATH: + /* + Determine the path join parameters; but |goto finish_path| if there's only a + direction specifier At this point |cur_cmd| is either |ampersand|, + |left_brace|, or |path_join|. + */ + if (cur_cmd == mp_left_brace_command) { + /* + Put the pre-join direction information into node |q|. At this point + |mp_right_type(q)| is usually |open|, but it may have been set to some + other value by a previous operation. We must maintain the value of + |mp_right_type(q)| in cases such as `|..\{curl2\|z\{0,0\}..}'. + */ + t = mp_scan_direction(mp); + if (t != mp_open_knot) { + mp_right_type(path_q) = (unsigned char) t; + number_clone(path_q->right_given, cur_exp_value_number); + if (mp_left_type(path_q) == mp_open_knot) { + mp_left_type(path_q) = (unsigned char) t; + number_clone(path_q->left_given, cur_exp_value_number); + } /* note that |left_given(q)=left_curl(q)| */ + } + } + d = cur_cmd; + dd = cur_mod; + if (d == mp_path_join_command) { + /* Determine the tension and/or control points */ + mp_get_x_next(mp); + switch (cur_cmd) { + case mp_tension_command: + /* Set explicit tensions */ + mp_get_x_next(mp); + set_number_from_scaled(y, cur_cmd); + if (cur_cmd == mp_at_least_command) { + mp_get_x_next(mp); + } + mp_scan_primary(mp); + force_valid_tension_setting(mp); + if (number_to_scaled(y) == mp_at_least_command && is_number(cur_exp_value_number)) { + number_negate(cur_exp_value_number); + } + number_clone(path_q->right_tension, cur_exp_value_number); + if (cur_cmd == mp_and_command) { + mp_get_x_next(mp); + set_number_from_scaled(y, cur_cmd); + if (cur_cmd == mp_at_least_command) { + mp_get_x_next(mp); + } + mp_scan_primary(mp); + force_valid_tension_setting(mp); + if (number_to_scaled(y) == mp_at_least_command && is_number(cur_exp_value_number)) { + number_negate(cur_exp_value_number); + } + } + number_clone(y, cur_exp_value_number); + break; + case mp_controls_command: + /* Set explicit control points */ + mp_right_type(path_q) = mp_explicit_knot; + t = mp_explicit_knot; + mp_get_x_next(mp); + mp_scan_primary(mp); + mp_known_pair(mp); + number_clone(path_q->right_x, mp->cur_x); + number_clone(path_q->right_y, mp->cur_y); + if (cur_cmd != mp_and_command) { + number_clone(x, path_q->right_x); + number_clone(y, path_q->right_y); + } else { + mp_get_x_next(mp); + mp_scan_primary(mp); + mp_known_pair(mp); + number_clone(x, mp->cur_x); + number_clone(y, mp->cur_y); + } + break; + default: + set_number_to_unity(path_q->right_tension); + set_number_to_unity(y); + /* default tension */ + mp_back_input(mp); + goto DONE; + break; + } + if (cur_cmd != mp_path_join_command) { + mp_back_error( + mp, + "Missing '..' has been inserted", + "A path join command should end with two dots." + ); + } + DONE: + ; /* needed */ + } else if (d != mp_ampersand_command) { + goto FINISH_PATH; + } + mp_get_x_next(mp); + if (cur_cmd == mp_left_brace_command) { + /* + Put the post-join direction information into |x| and |t|. Since + |left_tension| and |mp_left_y| share the same position in knot nodes, + and since |left_given| is similarly equivalent to |left_x|, we use + |x| and |y| to hold the given direction and tension information when + there are no explicit control points. + */ + t = mp_scan_direction(mp); + if (mp_right_type(path_q) != mp_explicit_knot) { + number_clone(x, cur_exp_value_number); + } else { + /* the direction information is superfluous */ + t = mp_explicit_knot; + } + } else if (mp_right_type(path_q) != mp_explicit_knot) { + t = mp_open_knot; + set_number_to_zero(x); + } + if (cur_cmd == mp_cycle_command) { + /* + Get ready to close a cycle. If a person tries to define an entire + path by saying |(x,y)\&cycle|, we silently change the + specification to |(x,y)..cycle|, since a cycle shouldn't have + length zero. + */ + if (cur_mod == mp_cycle_operation) { + cycle_hit = 1; + mp_get_x_next(mp); + pp = path_p; + qq = path_p; + if (d == mp_ampersand_command && path_p == path_q) { + d = mp_path_join_command; + set_number_to_unity(path_q->right_tension); + set_number_to_unity(y); + } + } else { + mp_get_x_next(mp); + qq = pp; + goto FINISH_PATH; + } + } else { + mp_scan_tertiary(mp); + /* + Convert the right operand, |cur_exp|, into a partial path from |pp| + to~|qq| + */ + if (mp->cur_exp.type != mp_path_type) { + pp = mp_pair_to_knot(mp); + } else { + pp = cur_exp_knot; + } + qq = pp; + while (mp_next_knot(qq) != pp) { + qq = mp_next_knot(qq); + } + if (mp_left_type(pp) != mp_endpoint_knot) { /* open up a cycle */ + r = mp_copy_knot(mp, pp); + mp_prev_knot(r) = qq; + mp_next_knot(qq) = r; + qq = r; + } + mp_left_type(pp) = mp_open_knot; + mp_right_type(qq) = mp_open_knot; + } + /* + Join the partial paths and reset |p| and |q| to the head and tail of the + result + */ + if (d == mp_ampersand_command && dd != mp_just_append_operation) { + if (! (number_equal(path_q->x_coord, pp->x_coord)) || ! (number_equal(path_q->y_coord, pp->y_coord))) { + mp_back_error( + mp, + "Paths don't touch; '&' will be changed to '..'", + "When you join paths 'p & q', the ending point of p must be exactly equal to the\n" + "starting point of q. So I'm going to pretend that you said 'p .. q' instead." + ); + @.Paths don't touch@> + mp_get_x_next(mp); + d = mp_path_join_command; + set_number_to_unity(path_q->right_tension); + set_number_to_unity(y); + } + } + /* Plug an opening in |mp_right_type(pp)|, if possible */ + if (mp_right_type(pp) == mp_open_knot && ((t == mp_curl_knot) || (t == mp_given_knot))) { + mp_right_type(pp) = (unsigned char) t; + number_clone(pp->right_given, x); + } + if (d == mp_ampersand_command) { + /* Splice independent paths together */ + if (dd == mp_just_append_operation) { + mp_left_type(pp) = mp_explicit_knot; + mp_right_type(path_q) = mp_explicit_knot; + mp_prev_knot(pp) = path_q; + mp_next_knot(path_q) = pp; + number_clone(pp->left_x, path_q->x_coord); + number_clone(pp->left_y, path_q->y_coord); + number_clone(path_q->right_x, pp->x_coord); + number_clone(path_q->right_y, pp->y_coord); + mp_knotstate(pp) = mp_begin_knot; + mp_knotstate(path_q) = mp_end_knot; + path_q = pp; + } else { + if (mp_left_type(path_q) == mp_open_knot && mp_right_type(path_q) == mp_open_knot) { + mp_left_type(path_q) = mp_curl_knot; + set_number_to_unity(path_q->left_curl); + } + if (mp_right_type(pp) == mp_open_knot && t == mp_open_knot) { + mp_right_type(pp) = mp_curl_knot; + set_number_to_unity(pp->right_curl); + } + mp_right_type(path_q) = mp_right_type(pp); + mp_prev_knot(pp) = mp_next_knot(path_q); + mp_next_knot(path_q) = mp_next_knot(pp); + number_clone(path_q->right_x, pp->right_x); + number_clone(path_q->right_y, pp->right_y); + mp_memory_free(pp); + } + if (qq == pp) { + qq = path_q; + } + } else { + /* Plug an opening in |mp_right_type(q)|, if possible */ + if (mp_right_type(path_q) == mp_open_knot && ((mp_left_type(path_q) == mp_curl_knot) || (mp_left_type(path_q) == mp_given_knot))) { + mp_right_type(path_q) = mp_left_type(path_q); + number_clone(path_q->right_given, path_q->left_given); + } + mp_prev_knot(pp) = path_q; + mp_next_knot(path_q) = pp; + number_clone(pp->left_y, y); + if (t != mp_open_knot) { + number_clone(pp->left_x, x); + mp_left_type(pp) = (unsigned char) t; + }; + } + path_q = qq; + if (cur_cmd >= mp_min_expression_command && cur_cmd <= mp_ampersand_command && ! cycle_hit) { + goto CONTINUE_PATH; + } + FINISH_PATH: + /* + Choose control points for the path and put the result into |cur_exp| + */ + if (cycle_hit) { + if (d == mp_ampersand_command) { + path_p = path_q; + } + } else { + mp_left_type(path_p) = mp_endpoint_knot; + if (mp_right_type(path_p) == mp_open_knot) { + mp_right_type(path_p) = mp_curl_knot; + set_number_to_unity(path_p->right_curl); + } + mp_right_type(path_q) = mp_endpoint_knot; + if (mp_left_type(path_q) == mp_open_knot) { + mp_left_type(path_q) = mp_curl_knot; + set_number_to_unity(path_q->left_curl); + } + mp_prev_knot(path_p) = path_q; + mp_next_knot(path_q) = path_p; + } + mp_make_choices(mp, path_p); + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, path_p); + free_number(x); + free_number(y); + return 1; +} + +@ A pair of numeric values is changed into a knot node for a one-point path when +\MP\ discovers that the pair is part of a path. + +@c +static mp_knot mp_pair_to_knot (MP mp) +{ + /* convert a pair to a knot with two endpoints */ + mp_knot q = mp_new_knot(mp); + mp_left_type(q) = mp_endpoint_knot; + mp_right_type(q) = mp_endpoint_knot; + mp_originator(q) = mp_metapost_user; + mp_knotstate(q) = mp_regular_knot; + mp_prev_knot(q) = q; + mp_next_knot(q) = q; + mp_known_pair(mp); + number_clone(q->x_coord, mp->cur_x); + number_clone(q->y_coord, mp->cur_y); + return q; +} + +@ The |known_pair| subroutine sets |cur_x| and |cur_y| to the components of the +current expression, assuming that the current expression is a pair of known +numerics. Unknown components are zeroed, and the current expression is flushed. + +@<Declarations@>= +static void mp_known_pair (MP mp); + +@ @c +void mp_known_pair (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (mp->cur_exp.type != mp_pair_type) { + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Undefined coordinates have been replaced by (0,0)", + "I need x and y numbers for this part of the path. The value I found (see above)\n" + "was no good; so I'll try to keep going by using zero instead." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + set_number_to_zero(mp->cur_x); + set_number_to_zero(mp->cur_y); + } else { + mp_node p = mp_get_value_node(cur_exp_node); + /* + Make sure that both |x| and |y| parts of |p| are known; copy them into + |cur_x| and |cur_y| + */ + if (mp_type(mp_x_part(p)) == mp_known_type) { + number_clone(mp->cur_x, mp_get_value_number(mp_x_part(p))); + } else { + mp_disp_err(mp, mp_x_part(p)); + mp_back_error( + mp, + "Undefined x coordinate has been replaced by 0", + "I need a 'known' x value for this part of the path. The value I found (see above)\n" + "was no good; so I'll try to keep going by using zero instead." + ); + mp_get_x_next(mp); + mp_recycle_value(mp, mp_x_part(p)); + set_number_to_zero(mp->cur_x); + } + if (mp_type(mp_y_part(p)) == mp_known_type) { + number_clone(mp->cur_y, mp_get_value_number(mp_y_part(p))); + } else { + mp_disp_err(mp, mp_y_part(p)); + mp_back_error( + mp, + "Undefined y coordinate has been replaced by 0", + "I need a 'known' y value for this part of the path. The value I found (see above)\n" + "was no good; so I'll try to keep going by using zero instead." + ); + mp_get_x_next(mp); + mp_recycle_value(mp, mp_y_part(p)); + set_number_to_zero(mp->cur_y); + } + mp_flush_cur_exp(mp, new_expr); + } +} + +@ The |scan_direction| subroutine looks at the directional information that is +enclosed in braces, and also scans ahead to the following character. A type code +is returned, either |open| (if the direction was $(0,0)$), or |curl| (if the +direction was a curl of known value |cur_exp|), or |given| (if the direction is +given by the |angle| value that now appears in |cur_exp|). + +There's nothing difficult about this subroutine, but the program is rather +lengthy because a variety of potential errors need to be nipped in the bud. + +@c +static int mp_scan_direction (MP mp) +{ + int t; /* the type of information found */ + mp_get_x_next(mp); + if (cur_cmd == mp_curl_command) { + /* Scan a curl specification */ + mp_get_x_next(mp); + mp_scan_expression(mp); + if ((mp->cur_exp.type != mp_known_type) || (number_negative(cur_exp_value_number))) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + set_number_to_unity(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Improper curl has been replaced by 1", + "A curl must be a known, nonnegative number." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + t = mp_curl_knot; + } else { + /* Scan a given direction */ + mp_scan_expression(mp); + if (mp->cur_exp.type > mp_pair_type) { + /* Get given directions separated by commas */ + mp_number xx; + new_number(xx); + if (mp->cur_exp.type != mp_known_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Undefined x coordinate has been replaced by 0", + "I need a 'known' x value for this part of the path. The value I found (see above)\n" + "was no good; so I'll try to keep going by using zero instead." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + number_clone(xx, cur_exp_value_number); + if (cur_cmd != mp_comma_command) { + mp_back_error( + mp, + "Missing ',' has been inserted", + "I've got the x coordinate of a path direction; will look for the y coordinate\n" + "next." + ); + } + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Undefined y coordinate has been replaced by 0", + "I need a 'known' y value for this part of the path. The value I found (see above)\n" + "was no good; so I'll try to keep going by using zero instead." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } + number_clone(mp->cur_y, cur_exp_value_number); + number_clone(mp->cur_x, xx); + free_number(xx); + } else { + mp_known_pair(mp); + } + if (number_zero(mp->cur_x) && number_zero(mp->cur_y)) { + t = mp_open_knot; + } else { + mp_number narg; + new_angle(narg); + n_arg(narg, mp->cur_x, mp->cur_y); + t = mp_given_knot; + mp_set_cur_exp_value_number(mp, &narg); + free_number(narg); + } + } + if (cur_cmd != mp_right_brace_command) { + mp_back_error( + mp, + "Missing '}' has been inserted", + "I've scanned a direction spec for part of a path, so a right brace should have\n" + "come next. I shall pretend that one was there." + ); + } + mp_get_x_next(mp); + return t; +} + +@<Declare the basic parsing subroutines@>= +static void do_boolean_error (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + set_number_from_boolean(new_expr.data.n, mp_false_operation); + mp_back_error( + mp, + "Undefined condition will be treated as 'false'", + "The expression shown above should have had a definite true-or-false value. I'm\n" + "changing it to 'false'." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_boolean_type; +} + +@ @<Declarations@>= +static void do_boolean_error (MP mp); + +@* Doing the operations. + +The purpose of parsing is primarily to permit people to avoid piles of +parentheses. But the real work is done after the structure of an expression has +been recognized; that's when new expressions are generated. We turn now to the +guts of \MP, which handles individual operators that have come through the +parsing mechanism. + +We'll start with the easy ones that take no operands, then work our way up to +operators with one and ultimately two arguments. In other words, we will write +the three procedures |do_nullary|, |do_unary|, and |do_binary| that are invoked +periodically by the expression scanners. + +First let's make sure that all of the primitive operators are in the hash table. +Although |scan_primary| and its relatives made use of the |cmd| code for these +operators, the |do| routines base everything on the |mod| code. For example, +|do_binary| doesn't care whether the operation it performs is a |primary_binary| +or |secondary_binary|, etc. + +@<Put each...@>= +mp_primitive(mp, "true", mp_nullary_command, mp_true_operation); +@:true_}{|true| primitive@> +mp_primitive(mp, "false", mp_nullary_command, mp_false_operation); +@:false_}{|false| primitive@> +mp_primitive(mp, "nullpicture", mp_nullary_command, mp_null_picture_operation); +@:null_picture_}{|nullpicture| primitive@> +mp_primitive(mp, "nullpen", mp_nullary_command, mp_null_pen_operation); +@:null_pen_}{|nullpen| primitive@> +mp_primitive(mp, "readstring", mp_nullary_command, mp_read_string_operation); +@:read_string_}{|readstring| primitive@> +mp_primitive(mp, "pencircle", mp_nullary_command, mp_pen_circle_operation); +@:pen_circle_}{|pencircle| primitive@> +mp_primitive(mp, "normaldeviate", mp_nullary_command, mp_normal_deviate_operation); +@:normal_deviate_}{|normaldeviate| primitive@> +mp_primitive(mp, "readfrom", mp_unary_command, mp_read_from_operation); +@:read_from_}{|readfrom| primitive@> +mp_primitive(mp, "closefrom", mp_unary_command, mp_close_from_operation); +@:close_from_}{|closefrom| primitive@> +mp_primitive(mp, "odd", mp_unary_command, mp_odd_operation); +@:odd_}{|odd| primitive@> +mp_primitive(mp, "known", mp_unary_command, mp_known_operation); +@:known_}{|known| primitive@> +mp_primitive(mp, "unknown", mp_unary_command, mp_unknown_operation); +@:unknown_}{|unknown| primitive@> +mp_primitive(mp, "not", mp_unary_command, mp_not_operation); +@:not_}{|not| primitive@> +mp_primitive(mp, "decimal", mp_unary_command, mp_decimal_operation); +@:decimal_}{|decimal| primitive@> +mp_primitive(mp, "reverse", mp_unary_command, mp_reverse_operation); +@:reverse_}{|reverse| primitive@> +mp_primitive(mp, "uncycle", mp_unary_command, mp_uncycle_operation); +@:uncycle_}{|uncycle| primitive@> +mp_primitive(mp, "makepath", mp_unary_command, mp_make_path_operation); +@:make_path_}{|makepath| primitive@> +mp_primitive(mp, "makepen", mp_unary_command, mp_make_pen_operation); +@:make_pen_}{|makepen| primitive@> +mp_primitive(mp, "makenep", mp_unary_command, mp_make_nep_operation); +@:make_nep_}{|makenep| primitive@> +mp_primitive(mp, "convexed", mp_unary_command, mp_convexed_operation); +@:convexed_}{|convexed| primitive@> +mp_primitive(mp, "uncontrolled", mp_unary_command, mp_uncontrolled_operation); +@:convexed_}{|uncontrolled| primitive@> +mp_primitive(mp, "oct", mp_unary_command, mp_oct_operation); +@:oct_}{|oct| primitive@> +mp_primitive(mp, "hex", mp_unary_command, mp_hex_operation); +@:hex_}{|hex| primitive@> +mp_primitive(mp, "ASCII", mp_unary_command, mp_ASCII_operation); +@:ASCII_}{|ASCII| primitive@> +mp_primitive(mp, "char", mp_unary_command, mp_char_operation); +@:char_}{|char| primitive@> +mp_primitive(mp, "length", mp_unary_command, mp_length_operation); +@:length_}{|length| primitive@> +mp_primitive(mp, "turningnumber", mp_unary_command, mp_turning_operation); +@:turning_number_}{|turningnumber| primitive@> +mp_primitive(mp, "xpart", mp_unary_command, mp_x_part_operation); +@:x_part_}{|xpart| primitive@> +mp_primitive(mp, "ypart", mp_unary_command, mp_y_part_operation); +@:y_part_}{|ypart| primitive@> +mp_primitive(mp, "xxpart", mp_unary_command, mp_xx_part_operation); +@:xx_part_}{|xxpart| primitive@> +mp_primitive(mp, "xypart", mp_unary_command, mp_xy_part_operation); +@:xy_part_}{|xypart| primitive@> +mp_primitive(mp, "yxpart", mp_unary_command, mp_yx_part_operation); +@:yx_part_}{|yxpart| primitive@> +mp_primitive(mp, "yypart", mp_unary_command, mp_yy_part_operation); +@:yy_part_}{|yypart| primitive@> +mp_primitive(mp, "redpart", mp_unary_command, mp_red_part_operation); +@:red_part_}{|redpart| primitive@> +mp_primitive(mp, "greenpart", mp_unary_command, mp_green_part_operation); +@:green_part_}{|greenpart| primitive@> +mp_primitive(mp, "bluepart", mp_unary_command, mp_blue_part_operation); +@:blue_part_}{|bluepart| primitive@> +mp_primitive(mp, "cyanpart", mp_unary_command, mp_cyan_part_operation); +@:cyan_part_}{|cyanpart| primitive@> +mp_primitive(mp, "magentapart", mp_unary_command, mp_magenta_part_operation); +@:magenta_part_}{|magentapart| primitive@> +mp_primitive(mp, "yellowpart", mp_unary_command, mp_yellow_part_operation); +@:yellow_part_}{|yellowpart| primitive@> +mp_primitive(mp, "blackpart", mp_unary_command, mp_black_part_operation); +@:black_part_}{|blackpart| primitive@> +mp_primitive(mp, "greypart", mp_unary_command, mp_grey_part_operation); +@:grey_part_}{|greypart| primitive@> +mp_primitive(mp, "colormodel", mp_unary_command, mp_color_model_operation); +@:color_model_part_}{|colormodel| primitive@> +mp_primitive(mp, "prescriptpart", mp_unary_command, mp_prescript_part_operation); +@:prescript_part_}{|prescriptpart| primitive@> +mp_primitive(mp, "postscriptpart", mp_unary_command, mp_postscript_part_operation); +@:postscript_part_}{|postscriptpart| primitive@> +mp_primitive(mp, "stackingpart", mp_unary_command, mp_stacking_part_operation); +@:stacking_part_}{|stackingpart| primitive@> +mp_primitive(mp, "pathpart", mp_unary_command, mp_path_part_operation); +@:path_part_}{|pathpart| primitive@> +mp_primitive(mp, "penpart", mp_unary_command, mp_pen_part_operation); +@:pen_part_}{|penpart| primitive@> +mp_primitive(mp, "dashpart", mp_unary_command, mp_dash_part_operation); +@:dash_part_}{|dashpart| primitive@> +mp_primitive(mp, "sqrt", mp_unary_command, mp_sqrt_operation); +@:sqrt_}{|sqrt| primitive@> +mp_primitive(mp, "mexp", mp_unary_command, mp_m_exp_operation); +@:m_exp_}{|mexp| primitive@> +mp_primitive(mp, "mlog", mp_unary_command, mp_m_log_operation); +@:m_log_}{|mlog| primitive@> +mp_primitive(mp, "sind", mp_unary_command, mp_sin_d_operation); +@:sin_d_}{|sind| primitive@> +mp_primitive(mp, "cosd", mp_unary_command, mp_cos_d_operation); +@:cos_d_}{|cosd| primitive@> +mp_primitive(mp, "floor", mp_unary_command, mp_floor_operation); +@:floor_}{|floor| primitive@> +mp_primitive(mp, "uniformdeviate", mp_unary_command, mp_uniform_deviate_operation); +@:uniform_deviate_}{|uniformdeviate| primitive@> +mp_primitive(mp, "llcorner", mp_unary_command, mp_ll_corner_operation); +@:ll_corner_}{|llcorner| primitive@> +mp_primitive(mp, "lrcorner", mp_unary_command, mp_lr_corner_operation); +@:lr_corner_}{|lrcorner| primitive@> +mp_primitive(mp, "ulcorner", mp_unary_command, mp_ul_corner_operation); +@:ul_corner_}{|ulcorner| primitive@> +mp_primitive(mp, "urcorner", mp_unary_command, mp_ur_corner_operation); +@:ur_corner_}{|urcorner| primitive@> +mp_primitive(mp, "centerof", mp_unary_command, mp_center_of_operation); +@:center_}{|center| primitive@> +mp_primitive(mp, "centerofmass", mp_unary_command, mp_center_of_mass_operation); +@:center_}{|centerofmass| primitive@> +mp_primitive(mp, "corners", mp_unary_command, mp_corners_operation); +@:corners_}{|corners| primitive@> +mp_primitive(mp, "xrange", mp_unary_command, mp_x_range_operation); +@:xrange_}{|xrange| primitive@> +mp_primitive(mp, "yrange", mp_unary_command, mp_y_range_operation); +@:yrange_}{|xrange| primitive@> +mp_primitive(mp, "deltapoint", mp_unary_command, mp_delta_point_operation); +@:deltapoint_}{|deltapoint| primitive@> +mp_primitive(mp, "deltaprecontrol", mp_unary_command, mp_delta_precontrol_operation); +@:deltaprecontrol_}{|deltaprecontrol| primitive@> +mp_primitive(mp, "deltapostcontrol", mp_unary_command, mp_delta_postcontrol_operation); +@:deltapostcontrol_}{|deltapostcontrol| primitive@> +mp_primitive(mp, "deltadirection", mp_unary_command, mp_delta_direction_operation); +@:deltadirection_}{|deltadirection| primitive@> +mp_primitive(mp, "arclength", mp_unary_command, mp_arc_length_operation); +@:arc_length_}{|arclength| primitive@> +mp_primitive(mp, "angle", mp_unary_command, mp_angle_operation); +@:angle_}{|angle| primitive@> +mp_primitive(mp, "cycle", mp_cycle_command, mp_cycle_operation); +@:cycle_}{|cycle| primitive@> +mp_primitive(mp, "nocycle", mp_cycle_command, mp_no_cycle_operation); +@:nocycle_}{|nocycle| primitive@> +mp_primitive(mp, "stroked", mp_unary_command, mp_stroked_operation); +@:stroked_}{|stroked| primitive@> +mp_primitive(mp, "filled", mp_unary_command, mp_filled_operation); +@:filled_}{|filled| primitive@> +mp_primitive(mp, "clipped", mp_unary_command, mp_clipped_operation); +@:clipped_}{|clipped| primitive@> +mp_primitive(mp, "grouped", mp_unary_command, mp_grouped_operation); +@:clipped_}{|grouped| primitive@> +mp_primitive(mp, "bounded", mp_unary_command, mp_bounded_operation); +@:bounded_}{|bounded| primitive@> +mp_primitive(mp, "+", mp_plus_or_minus_command, mp_plus_operation); +@:+ }{|+| primitive@> +mp_primitive(mp, "-", mp_plus_or_minus_command, mp_minus_operation); +@:- }{|-| primitive@> +mp_primitive(mp, "*", mp_secondary_binary_command, mp_times_operation); +@:* }{|*| primitive@> +mp_primitive(mp, "/", mp_slash_command, mp_over_operation); +mp->frozen_slash = mp_frozen_primitive (mp, "/", mp_slash_command, mp_over_operation); +@:/ }{|/| primitive@> +mp_primitive(mp, "^", mp_secondary_binary_command, mp_power_operation); +@:^ }{|^| primitive@> +mp_primitive(mp, "++", mp_tertiary_binary_command, mp_pythag_add_operation); +@:++_}{|++| primitive@> +mp_primitive(mp, "+-+", mp_tertiary_binary_command, mp_pythag_sub_operation); +@:+-+_}{|+-+| primitive@> +mp_primitive(mp, "or", mp_tertiary_binary_command, mp_or_operation); +@:or_}{|or| primitive@> +mp_primitive(mp, "and", mp_and_command, mp_and_operation); +@:and_}{|and| primitive@> +mp_primitive(mp, "<", mp_primary_binary_command, mp_less_than_operation); +@:< }{|<| primitive@> +mp_primitive(mp, "<=", mp_primary_binary_command, mp_less_or_equal_operation); +@:<=_}{|<=| primitive@> +mp_primitive(mp, ">", mp_primary_binary_command, mp_greater_than_operation); +@:> }{|>| primitive@> +mp_primitive(mp, ">=", mp_primary_binary_command, mp_greater_or_equal_operation); +@:>=_}{|>=| primitive@> +mp_primitive(mp, "=", mp_equals_command, mp_equal_operation); +@:= }{|=| primitive@> +mp_primitive(mp, "<>", mp_primary_binary_command, mp_unequal_operation); +@:<>_}{|<>| primitive@> +mp_primitive(mp, "substring", mp_of_binary_command, mp_substring_operation); +@:substring_}{|substring| primitive@> +mp_primitive(mp, "subpath", mp_of_binary_command, mp_subpath_operation); +@:subpath_}{|subpath| primitive@> +mp_primitive(mp, "directiontime", mp_of_binary_command, mp_direction_time_operation); +@:direction_time_}{|directiontime| primitive@> +mp_primitive(mp, "point", mp_of_binary_command, mp_point_operation); +@:point_}{|point| primitive@> +mp_primitive(mp, "precontrol", mp_of_binary_command, mp_precontrol_operation); +@:precontrol_}{|precontrol| primitive@> +mp_primitive(mp, "postcontrol", mp_of_binary_command, mp_postcontrol_operation); +@:direction_}{|direction| primitive@> +mp_primitive(mp, "direction", mp_of_binary_command, mp_direction_operation); +@:postcontrol_}{|postcontrol| primitive@> +mp_primitive(mp, "pathpoint", mp_nullary_command, mp_path_point_operation); +@:pathpoint_}{|pathpoint| primitive@> +mp_primitive(mp, "pathprecontrol", mp_nullary_command, mp_path_precontrol_operation); +@:pathprecontrol_}{|pathprecontrol| primitive@> +mp_primitive(mp, "pathpostcontrol", mp_nullary_command, mp_path_postcontrol_operation); +@:pathpostcontrol_}{|pathpostcontrol| primitive@> +mp_primitive(mp, "pathdirection", mp_nullary_command, mp_path_direction_operation); +@:pathdirection_}{|pathdirection| primitive@> +mp_primitive(mp, "penoffset", mp_of_binary_command, mp_pen_offset_operation); +@:pen_offset_}{|penoffset| primitive@> +mp_primitive(mp, "arctime", mp_of_binary_command, mp_arc_time_operation); +@:arc_time_of_}{|arctime| primitive@> +mp_primitive(mp, "arcpoint", mp_of_binary_command, mp_arc_point_operation); +@:arc_point_of_}{|arcpoint| primitive@> +mp_primitive(mp, "arcpointlist", mp_of_binary_command, mp_arc_point_list_operation); +@:arc_point_list_of_}{|arcpointlist| primitive@> +mp_primitive(mp, "subarclength", mp_of_binary_command, mp_subarc_length_operation); +@:subarc_length_of_}{|subarclength| primitive@> +mp_primitive(mp, "mpversion", mp_nullary_command, mp_version_operation); +@:mp_version_}{|mpversion| primitive@> +mp_primitive(mp, "&", mp_ampersand_command, mp_concatenate_operation); +@:!!!}{|\&| primitive@> +mp_primitive(mp, "&&", mp_ampersand_command, mp_just_append_operation); +@:!!!!!!}{|\&\&| primitive@> +mp_primitive(mp, "rotated", mp_secondary_binary_command, mp_rotated_operation); +@:rotated_}{|rotated| primitive@> +mp_primitive(mp, "slanted", mp_secondary_binary_command, mp_slanted_operation); +@:slanted_}{|slanted| primitive@> +mp_primitive(mp, "scaled", mp_secondary_binary_command, mp_scaled_operation); +@:scaled_}{|scaled| primitive@> +mp_primitive(mp, "shifted", mp_secondary_binary_command, mp_shifted_operation); +@:shifted_}{|shifted| primitive@> +mp_primitive(mp, "transformed", mp_secondary_binary_command, mp_transformed_operation); +@:transformed_}{|transformed| primitive@> +mp_primitive(mp, "xscaled", mp_secondary_binary_command, mp_x_scaled_operation); +@:x_scaled_}{|xscaled| primitive@> +mp_primitive(mp, "yscaled", mp_secondary_binary_command, mp_y_scaled_operation); +@:y_scaled_}{|yscaled| primitive@> +mp_primitive(mp, "zscaled", mp_secondary_binary_command, mp_z_scaled_operation); +@:z_scaled_}{|zscaled| primitive@> +mp_primitive(mp, "intersectiontimes", mp_tertiary_binary_command, mp_intertimes_operation); +@:intersection_times_}{|intersectiontimes| primitive@> +mp_primitive(mp, "intersectiontimeslist", mp_tertiary_binary_command, mp_intertimes_list_operation); +@:intersection_times_list_}{|intersectiontimeslist| primitive@> +mp_primitive(mp, "envelope", mp_of_binary_command, mp_envelope_operation); +@:envelope_}{|envelope| primitive@> +mp_primitive(mp, "boundingpath", mp_of_binary_command, mp_boundingpath_operation); +@:boundingpath_}{|boundingpath| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_nullary_command: +case mp_unary_command: +case mp_of_binary_command: +case mp_secondary_binary_command: +case mp_tertiary_binary_command: +case mp_primary_binary_command: +case mp_cycle_command: +case mp_plus_or_minus_command: +case mp_slash_command: +case mp_ampersand_command: +case mp_equals_command: +case mp_and_command: + return mp_op_string((int) m); + +@ @<Declarations@>= +static void push_of_path_result (MP mp, int what, mp_knot p); + +@ @c +static void push_of_path_result (MP mp, int what, mp_knot p) +{ + switch (what) { + case 0: + mp_pair_value(mp, &(p->x_coord), &(p->y_coord)); + break; + case 1: + if (mp_left_type(p) == mp_endpoint_knot) { + mp_pair_value(mp, &(p->x_coord), &(p->y_coord)); + } else { + mp_pair_value(mp, &(p->left_x), &(p->left_y)); + } + break; + case 2: + if (mp_right_type(p) == mp_endpoint_knot) { + mp_pair_value(mp, &(p->x_coord), &(p->y_coord)); + } else { + mp_pair_value(mp, &(p->right_x), &(p->right_y)); + } + break; + case 3: + { + mp_number x, y; + if (mp_right_type(p) == mp_endpoint_knot) { + new_number_clone(x, p->x_coord); + new_number_clone(y, p->y_coord); + } else { + new_number_clone(x, p->right_x); + new_number_clone(y, p->right_y); + } + if (mp_left_type(p) == mp_endpoint_knot) { + number_subtract(x, p->x_coord); + number_subtract(y, p->y_coord); + } else { + number_subtract(x, p->left_x); + number_subtract(y, p->left_y); + } + mp_pair_value(mp, &x, &y); + free_number(x); + free_number(y); + } + break; + } +} + +@ OK, let's look at the simplest |do| procedure first. + +@c +@<Declare nullary action procedure@> +static void mp_do_nullary (MP mp, int c) +{ + check_arith(); + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + mp_show_cmd_mod(mp, mp_nullary_command, c); + } + switch (c) { + case mp_true_operation: + case mp_false_operation: + mp->cur_exp.type = mp_boolean_type; + mp_set_cur_exp_value_boolean(mp, c); + break; + case mp_null_picture_operation: + mp->cur_exp.type = mp_picture_type; + mp_set_cur_exp_node(mp, (mp_node) mp_get_edge_header_node(mp)); + mp_init_edges(mp, (mp_edge_header_node) cur_exp_node); + break; + case mp_null_pen_operation: + mp->cur_exp.type = mp_pen_type; + mp_set_cur_exp_knot(mp, mp_get_pen_circle(mp, &zero_t)); + break; + case mp_normal_deviate_operation: + { + mp_number r; + new_number(r); + /*|mp_norm_rand (mp, &r)|;*/ + m_norm_rand(r); + mp->cur_exp.type = mp_known_type; + mp_set_cur_exp_value_number(mp, &r); + free_number(r); + } + break; + case mp_pen_circle_operation: + mp->cur_exp.type = mp_pen_type; + mp_set_cur_exp_knot(mp, mp_get_pen_circle(mp, &unity_t)); + break; + case mp_version_operation: + mp->cur_exp.type = mp_string_type; + mp_set_cur_exp_str(mp, mp_intern(mp, metapost_version)); + break; + /* these are new */ + case mp_path_point_operation: + case mp_path_precontrol_operation: + case mp_path_postcontrol_operation: + case mp_path_direction_operation: + if (mp->loop_ptr && mp->loop_ptr->point != NULL) { + push_of_path_result(mp, c - mp_path_point_operation, mp->loop_ptr->point); + } else { + mp_pair_value(mp, &zero_t, &zero_t); + } + break; + } + check_arith(); +} + +@ @<Declare nullary action procedure@>= +static void mp_finish_read (MP mp) +{ + /* copy |buffer| line to |cur_exp| */ + mp_str_room(mp, (int) mp->last - (int) start); + for (size_t k = (size_t) start; k < mp->last; k++) { + mp_append_char(mp, mp->buffer[k]); + } + mp_end_file_reading(mp); + mp->cur_exp.type = mp_string_type; + mp_set_cur_exp_str(mp, mp_make_string(mp)); + } + +@ Things get a bit more interesting when there's an operand. The operand to +|do_unary| appears in |cur_type| and |cur_exp|. + +This complicated if test makes sure that any |bounds| or |clip| picture objects +that get passed into |within| do not raise an error when queried using the +color part primitives (this is needed for backward compatibility) . + +@c +static int mp_pict_color_type (MP mp, int c) +{ + /* cur_pic_item = mp_link(mp_edge_list(cur_exp_node)) */ + return ( + (mp_link(mp_edge_list(cur_exp_node)) != NULL) + && + ( + (! mp_has_color(mp_link(mp_edge_list(cur_exp_node)))) + || + (( + (mp_color_model(mp_link(mp_edge_list(cur_exp_node))) == c) + || + ( + (mp_color_model(mp_link(mp_edge_list(cur_exp_node))) == mp_uninitialized_model) + && + (number_to_scaled(internal_value(mp_default_color_model_internal))/number_to_scaled(unity_t)) == c + ) + )) + ) + ); +} + +@<Declarations@>= +static mp_knot mp_simple_knot(MP mp, mp_number *x, mp_number *y); +static mp_knot mp_complex_knot(MP mp, mp_knot o); + +@ @c +static mp_knot mp_simple_knot(MP mp, mp_number *x, mp_number *y) +{ + mp_knot k = mp_new_knot(mp); + mp_left_type(k) = mp_explicit_knot; + mp_right_type(k) = mp_explicit_knot; + mp_originator(k) = mp_program_code; + mp_knotstate(k) = mp_regular_knot; + number_clone(k->x_coord, *x); + number_clone(k->y_coord, *y); + number_clone(k->left_x, *x); + number_clone(k->left_y, *y); + number_clone(k->right_x, *x); + number_clone(k->right_y, *y); + return k; +} + +static mp_knot mp_complex_knot(MP mp, mp_knot o) +{ + mp_knot k = mp_new_knot(mp); + mp_left_type(k) = mp_explicit_knot; + mp_right_type(k) = mp_explicit_knot; + mp_originator(k) = mp_program_code; + mp_knotstate(k) = mp_regular_knot; + number_clone(k->x_coord, o->x_coord); + number_clone(k->y_coord, o->y_coord); + number_clone(k->left_x, o->left_x); + number_clone(k->left_y, o->left_y); + number_clone(k->right_x, o->right_x); + number_clone(k->right_y, o->right_y); + return k; +} + +@<Declarations@>= +static int mp_pict_color_type (MP mp, int c); + +@c +@<Declare unary action procedures@> + +static void mp_do_unary (MP mp, int c) +{ + check_arith(); + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + /* Trace the current unary operation */ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{"); + mp_print_op(mp, c); + mp_print_chr(mp, '('); + mp_print_exp(mp, NULL, 0); /* show the operand, but not verbosely */ + mp_print_str(mp, ")}"); + mp_end_diagnostic(mp, 0); + } + /* + This is a mix of combined and not combined. We could combine more or less + and let the compiler deal with it. + */ + switch (c) { + case mp_plus_operation: + if (mp->cur_exp.type < mp_color_type) { + mp_bad_unary(mp, mp_plus_operation); + } + break; + case mp_minus_operation: + negate_cur_expr(mp); + break; + case mp_not_operation: + if (mp->cur_exp.type != mp_boolean_type) { + mp_bad_unary(mp, mp_not_operation); + } else { + mp_set_cur_exp_value_boolean(mp, (cur_exp_value_boolean == mp_true_operation) ? mp_false_operation : mp_true_operation); + } + break; + /* We could use something function[mp_sqrt_operation] here: */ + case mp_sqrt_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n; + new_number(n); + square_rt(n, cur_exp_value_number); + mp_set_cur_exp_value_number(mp, &n); + free_number(n); + } + break; + case mp_m_exp_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n; + new_number(n); + m_exp(n, cur_exp_value_number); + mp_set_cur_exp_value_number(mp, &n); + free_number(n); + } + break; + case mp_m_log_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n; + new_number(n); + m_log(n, cur_exp_value_number); + mp_set_cur_exp_value_number(mp, &n); + free_number(n); + } + break; + case mp_sin_d_operation: + case mp_cos_d_operation: + /* + This is rather inefficient, esp decimal, to calculate both each time. We could + pass NULL as signal to do only one. + */ + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n_sin, n_cos, arg1, arg2; + new_number(arg1); + new_number(arg2); + new_fraction(n_sin); + new_fraction(n_cos); + number_clone(arg1, cur_exp_value_number); + number_clone(arg2, unity_t); + number_multiply_int(arg2, 360); + number_modulo(arg1, arg2); + convert_scaled_to_angle(arg1); + n_sin_cos(arg1, n_cos, n_sin); + if (c == mp_sin_d_operation) { + fraction_to_round_scaled(n_sin); + mp_set_cur_exp_value_number(mp, &n_sin); + } else { + fraction_to_round_scaled(n_cos); + mp_set_cur_exp_value_number(mp, &n_cos); + } + free_number(arg1); + free_number(arg2); + free_number(n_sin); + free_number(n_cos); + } + break; + case mp_floor_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n; + new_number(n); + number_clone(n, cur_exp_value_number); + floor_scaled(n); + mp_set_cur_exp_value_number(mp, &n); + free_number(n); + } + break; + case mp_uniform_deviate_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_number n; + new_number(n); + m_unif_rand(n, cur_exp_value_number); + mp_set_cur_exp_value_number(mp, &n); + free_number(n); + } + break; + case mp_odd_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, c); + } else { + mp_set_cur_exp_value_boolean(mp, number_odd(cur_exp_value_number) ? mp_true_operation : mp_false_operation); + mp->cur_exp.type = mp_boolean_type; + } + break; + case mp_angle_operation: + if (mp_nice_pair (mp, cur_exp_node, mp->cur_exp.type)) { + mp_value expr; + mp_node p; /* for list manipulation */ + mp_number narg; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + new_angle(narg); + p = mp_get_value_node(cur_exp_node); + n_arg(narg, mp_get_value_number(mp_x_part(p)), mp_get_value_number(mp_y_part(p))); + number_clone(expr.data.n, narg); + convert_angle_to_scaled(expr.data.n); + free_number(narg); + mp_flush_cur_exp(mp, expr); + } else { + mp_bad_unary(mp, mp_angle_operation); + } + break; + case mp_x_part_operation: + case mp_y_part_operation: + switch (mp->cur_exp.type) { + case mp_pair_type: + case mp_transform_type: + mp_take_part(mp, c); + break; + case mp_picture_type: + mp_take_pict_part(mp, c); + break; + default: + mp_bad_unary(mp, c); + break; + } + break; + case mp_xx_part_operation: + case mp_xy_part_operation: + case mp_yx_part_operation: + case mp_yy_part_operation: + switch (mp->cur_exp.type) { + case mp_transform_type: + mp_take_part(mp, c); + break; + case mp_picture_type: + mp_take_pict_part(mp, c); + break; + default: + mp_bad_unary(mp, c); + break; + } + break; + case mp_red_part_operation: + case mp_green_part_operation: + case mp_blue_part_operation: + switch (mp->cur_exp.type) { + case mp_color_type: + mp_take_part(mp, c); + break; + case mp_picture_type: + if (mp_pict_color_type(mp, mp_rgb_model)) { + mp_take_pict_part(mp, c); + } else { + mp_bad_color_part(mp, c); + } + break; + default: + mp_bad_unary(mp, c); + break; + } + break; + case mp_cyan_part_operation: + case mp_magenta_part_operation: + case mp_yellow_part_operation: + case mp_black_part_operation: + switch (mp->cur_exp.type) { + case mp_cmykcolor_type: + mp_take_part(mp, c); + break; + case mp_picture_type: + if (mp_pict_color_type(mp, mp_cmyk_model)) { + mp_take_pict_part(mp, c); + } else { + mp_bad_color_part(mp, c); + } + break; + default: + mp_bad_unary(mp, c); + break; + } + break; + case mp_grey_part_operation: + switch (mp->cur_exp.type) { + case mp_known_type: + break; + case mp_picture_type: + if (mp_pict_color_type(mp, mp_grey_model)) { + mp_take_pict_part(mp, c); + } else { + mp_bad_color_part(mp, c); + } + break; + default: + mp_bad_unary(mp, c); + break; + } + break; + case mp_color_model_operation: + case mp_path_part_operation: + case mp_pen_part_operation: + case mp_dash_part_operation: + case mp_prescript_part_operation: + case mp_postscript_part_operation: + case mp_stacking_part_operation: + if (mp->cur_exp.type == mp_picture_type) { + mp_take_pict_part(mp, c); + } else { + mp_bad_unary(mp, c); + } + break; + case mp_char_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, mp_char_operation); + } else { + int n = round_unscaled(cur_exp_value_number) % 256; + unsigned char s[2]; + mp_set_cur_exp_value_scaled(mp, n); + mp->cur_exp.type = mp_string_type; + if (number_negative(cur_exp_value_number)) { + n = number_to_scaled(cur_exp_value_number) + 256; + mp_set_cur_exp_value_scaled(mp, n); + } + s[0] = (unsigned char) number_to_scaled(cur_exp_value_number); + s[1] = '\0'; + mp_set_cur_exp_str(mp, mp_rtsl (mp, (char *) s, 1)); + } + break; + case mp_decimal_operation: + if (mp->cur_exp.type != mp_known_type) { + mp_bad_unary(mp, mp_decimal_operation); + } else { + int selector = mp->selector; + mp->selector = mp_new_string_selector; + print_number(cur_exp_value_number); + mp_set_cur_exp_str(mp, mp_make_string(mp)); + mp->selector = selector; + mp->cur_exp.type = mp_string_type; + } + break; + case mp_oct_operation: + case mp_hex_operation: + case mp_ASCII_operation: + if (mp->cur_exp.type != mp_string_type) { + mp_bad_unary(mp, c); + } else { + mp_str_to_num(mp); + } + break; + case mp_length_operation: + /* + The length operation is somewhat unusual in that it applies to a variety of + different types of operands. * + */ + switch (mp->cur_exp.type) { + case mp_string_type: + { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + number_clone(expr.data.n, unity_t); + number_multiply_int(expr.data.n, (int) cur_exp_str->len); + mp_flush_cur_exp(mp, expr); + break; + } + case mp_path_type: + { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + mp_path_length(mp, &expr.data.n); + mp_flush_cur_exp(mp, expr); + break; + } + case mp_known_type: + { + mp_set_cur_exp_value_number(mp, &cur_exp_value_number); + number_abs(cur_exp_value_number); + break; + } + case mp_picture_type: + { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + mp_picture_length(mp, &expr.data.n); + mp_flush_cur_exp(mp, expr); + break; + } + default: + if (mp_nice_pair (mp, cur_exp_node, mp->cur_exp.type)) { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + pyth_add(expr.data.n, + mp_get_value_number(mp_x_part(mp_get_value_node(cur_exp_node))), + mp_get_value_number(mp_y_part(mp_get_value_node(cur_exp_node))) + ); + mp_flush_cur_exp(mp, expr); + } else { + mp_bad_unary(mp, c); + } + break; + } + break; + case mp_turning_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + mp_flush_cur_exp(mp, expr); + } else if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, mp_turning_operation); + } else if (mp_left_type(cur_exp_knot) == mp_endpoint_knot) { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + expr.data.p = NULL; + mp_flush_cur_exp(mp, expr); /* not a cyclic path */ + } else { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + mp_turn_cycles_wrapper(mp, &expr.data.n, cur_exp_knot); + mp_flush_cur_exp(mp, expr); + } + break; + /* Here we could do some delta(operation,type) trickery as with filled. */ + + case mp_boolean_type_operation: + case mp_string_type_operation: + case mp_pen_type_operation: + case mp_nep_type_operation: + case mp_path_type_operation: + case mp_picture_type_operation: + { + mp_value expr; + /*they are parallel but with 2 increments (known and unknown): */ + int type = (c - mp_boolean_type_operation) * 2 + mp_boolean_type ; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + set_number_from_boolean(expr.data.n, (mp->cur_exp.type == type || mp->cur_exp.type == (type + 1)) ? mp_true_operation : mp_false_operation); + mp_flush_cur_exp(mp, expr); + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_transform_type_operation: + case mp_color_type_operation: + case mp_cmykcolor_type_operation: + case mp_pair_type_operation: + { + mp_value expr; + /* they are parallel: */ + int type = (c - mp_transform_type_operation) + mp_transform_type; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + set_number_from_boolean(expr.data.n, mp->cur_exp.type == type ? mp_true_operation : mp_false_operation); + mp_flush_cur_exp(mp, expr); + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_numeric_type_operation: + { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + set_number_from_boolean(expr.data.n, (mp->cur_exp.type >= mp_known_type && mp->cur_exp.type <= mp_independent_type) ? mp_true_operation : mp_false_operation); + mp_flush_cur_exp(mp, expr); + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_known_operation: + case mp_unknown_operation: + { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + set_number_from_boolean(expr.data.n, mp_test_known(mp, c)); + mp_flush_cur_exp(mp, expr); + /* !! do not replace with |mp_set_cur_exp_node(mp, )| !! */ + cur_exp_node = NULL; + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_cycle_operation: + case mp_no_cycle_operation: + { + mp_value expr; + int b = 0; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + if (mp->cur_exp.type != mp_path_type) { + b = (c == mp_cycle_operation) ? mp_false_operation : mp_true_operation; + } else if (mp_left_type(cur_exp_knot) != mp_endpoint_knot) { + b = (c == mp_cycle_operation) ? mp_true_operation : mp_false_operation; + } else { + b = (c == mp_cycle_operation) ? mp_false_operation : mp_true_operation; + } + set_number_from_boolean(expr.data.n, b); + mp_flush_cur_exp(mp, expr); + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_arc_length_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, mp_arc_length_operation); + } else { + mp_value expr; + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + mp_get_arc_length(mp, &expr.data.n, cur_exp_knot); + mp_flush_cur_exp(mp, expr); + } + break; + case mp_filled_operation: + case mp_stroked_operation: + case mp_clipped_operation: + case mp_grouped_operation: + case mp_bounded_operation: + { + mp_value expr; + @^data structure assumptions@> + memset(&expr, 0, sizeof(mp_value)); + new_number(expr.data.n); + if (mp->cur_exp.type != mp_picture_type) { + set_number_from_boolean(expr.data.n, mp_false_operation); + } else if (mp_link(mp_edge_list(cur_exp_node)) == NULL) { + set_number_from_boolean(expr.data.n, mp_false_operation); + } else { + /* they are parallel: */ + int type = c - mp_filled_operation + mp_fill_node_type; + set_number_from_boolean(expr.data.n, mp_type(mp_link(mp_edge_list(cur_exp_node))) == type ? mp_true_operation: mp_false_operation); + } + mp_flush_cur_exp(mp, expr); + mp->cur_exp.type = mp_boolean_type; + break; + } + case mp_make_pen_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, mp_make_pen_operation); + } else { + mp->cur_exp.type = mp_pen_type; + mp_set_cur_exp_knot(mp, mp_make_pen(mp, cur_exp_knot, 1)); + } + break; + case mp_make_nep_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, c); + } else { + mp->cur_exp.type = mp_nep_type; + mp_set_cur_exp_knot(mp, cur_exp_knot); + } + break; + case mp_convexed_operation: + if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, mp_convexed_operation); + } else { + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, mp_convex_hull(mp, cur_exp_knot)); + mp_simplify_path(mp, cur_exp_knot); + } + break; + case mp_uncontrolled_operation: + if (mp->cur_exp.type != mp_path_type) { + mp_bad_unary(mp, mp_uncontrolled_operation); + } else { + mp->cur_exp.type = mp_path_type; + mp_simplify_path(mp, cur_exp_knot); + } + break; + case mp_make_path_operation: + if (mp->cur_exp.type != mp_pen_type && mp->cur_exp.type != mp_nep_type) { + mp_bad_unary(mp, mp_make_path_operation); + } else { + mp->cur_exp.type = mp_path_type; + mp_make_path(mp, cur_exp_knot); + } + break; + case mp_reverse_operation: + switch (mp->cur_exp.type) { + case mp_path_type: + { + mp_knot pk = mp_htap_ypoc(mp, cur_exp_knot); + if (mp_right_type(pk) == mp_endpoint_knot) { + pk = mp_next_knot(pk); + } + mp_toss_knot_list(mp, cur_exp_knot); + mp_set_cur_exp_knot(mp, pk); + } + break; + case mp_pair_type: + mp_pair_to_path(mp); + break; + default: + mp_bad_unary(mp, mp_reverse_operation); + break; + } + break; + case mp_uncycle_operation: + switch (mp->cur_exp.type) { + case mp_path_type: + mp_right_type(mp_prev_knot(cur_exp_knot)) = mp_endpoint_knot; + mp_left_type(cur_exp_knot) = mp_endpoint_knot; + break; + case mp_pair_type: + mp_pair_to_path(mp); + break; + default: + mp_bad_unary(mp, mp_uncycle_operation); + break; + } + break; + case mp_ll_corner_operation: + if (mp_get_cur_bbox(mp)) { + mp_pair_value(mp, &mp_minx, &mp_miny); + } else { + mp_bad_unary(mp, mp_ll_corner_operation); + } + break; + case mp_lr_corner_operation: + if (mp_get_cur_bbox(mp)) { + mp_pair_value(mp, &mp_maxx, &mp_miny); + } else { + mp_bad_unary(mp, mp_lr_corner_operation); + } + break; + case mp_ul_corner_operation: + if (mp_get_cur_bbox(mp)) { + mp_pair_value(mp, &mp_minx, &mp_maxy); + } else { + mp_bad_unary(mp, mp_ul_corner_operation); + } + break; + case mp_ur_corner_operation: + if (! mp_get_cur_bbox(mp)) { + mp_bad_unary(mp, mp_ur_corner_operation); + } else { + mp_pair_value(mp, &mp_maxx, &mp_maxy); + } + break; + case mp_center_of_operation: + if (mp->cur_exp.type == mp_pair_type) { + /* keep the pair */ + } else if (mp_get_cur_bbox(mp)) { + /* todo: make this a function call */ + mp_number x, y; + new_number(x); + new_number(y); + set_number_half_from_subtraction(x, mp_maxx, mp_minx); + set_number_half_from_subtraction(y, mp_maxy, mp_miny); + number_add(x, mp_minx); + number_add(y, mp_miny); + mp_pair_value(mp, &x, &y); + } else { + mp_bad_unary(mp, mp_center_of_operation); + } + break; + case mp_center_of_mass_operation: + if (mp->cur_exp.type == mp_pair_type) { + /* keep the pair */ + } else if (mp->cur_exp.type == mp_path_type) { + /* no overflow detection here .. todo: make this a function call */ + mp_knot p = cur_exp_knot; + int l = 0; + mp_number x, y; + new_number(x); + new_number(y); + do { + ++l; + p = mp_next_knot(p); + number_add(x, p->x_coord); + number_add(y, p->y_coord); + } while (p != cur_exp_knot); + number_divide_int(x, l); + number_divide_int(y, l); + mp_pair_value(mp, &x, &y); + free_number(x); + free_number(y); + } else { + mp_bad_unary(mp, mp_center_of_mass_operation); + } + break; + case mp_corners_operation: + if (! mp_get_cur_bbox(mp)) { + mp_bad_unary(mp, mp_corners_operation); + } else { + mp_knot ll = mp_simple_knot(mp, &mp_minx, &mp_miny); + mp_knot lr = mp_simple_knot(mp, &mp_maxx, &mp_miny); + mp_knot ur = mp_simple_knot(mp, &mp_maxx, &mp_maxy); + mp_knot ul = mp_simple_knot(mp, &mp_minx, &mp_maxy); + mp_prev_knot(lr) = ll; + mp_next_knot(ll) = lr; + mp_prev_knot(ur) = lr; + mp_next_knot(lr) = ur; + mp_prev_knot(ul) = ur; + mp_next_knot(ur) = ul; + mp_prev_knot(ll) = ul; + mp_next_knot(ul) = ll; + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, ll); + } + break; + case mp_x_range_operation: + if (mp_get_cur_xbox(mp)) { + mp_pair_value(mp, &mp_minx, &mp_maxx); + } else { + mp_bad_unary(mp, mp_x_range_operation); + } + break; + case mp_y_range_operation: + if (mp_get_cur_ybox(mp)) { + mp_pair_value(mp, &mp_miny, &mp_maxy); + } else { + mp_bad_unary(mp, mp_y_range_operation); + } + break; + case mp_delta_point_operation: + case mp_delta_precontrol_operation: + case mp_delta_postcontrol_operation: + case mp_delta_direction_operation: + if (mp->cur_exp.type == mp_known_type) { + mp_set_cur_exp_value_number(mp, &cur_exp_value_number); + if (mp->loop_ptr && mp->loop_ptr->point != NULL) { + mp_knot p = mp->loop_ptr->point; + int n = round_unscaled(cur_exp_value_number); + if (n > 0) { + while (n--) { + p = mp_next_knot(p); + } + } else if (n < 0) { + while (n++) { + p = mp_prev_knot(p); + } + } + push_of_path_result(mp, c - mp_delta_point_operation, p); + } + } else { + mp_bad_unary(mp, c); + } + break; + case mp_read_from_operation: + case mp_close_from_operation: + if (mp->cur_exp.type != mp_string_type) { + mp_bad_unary(mp, c); + } else { + mp_do_read_or_close(mp, c); + } + break; + } + check_arith(); +} + +@ The |nice_pair| function returns |true| if both components of a pair are known. + +@<Declare unary action procedures@>= +static int mp_nice_pair (MP mp, mp_node p, int t) +{ + (void) mp; + if (t == mp_pair_type) { + p = mp_get_value_node(p); + if (mp_type(mp_x_part(p)) == mp_known_type && mp_type(mp_y_part(p)) == mp_known_type) + return 1; + } + return 0; +} + +@ The |nice_color_or_pair| function is analogous except that it also accepts +fully known colors. + +@<Declare unary action procedures@>= +static int mp_nice_color_or_pair (MP mp, mp_node p, int t) +{ + mp_node q; + (void) mp; + switch (t) { + case mp_pair_type: + q = mp_get_value_node(p); + if (mp_type(mp_x_part(q)) == mp_known_type + && mp_type(mp_y_part(q)) == mp_known_type) + return 1; + break; + case mp_color_type: + q = mp_get_value_node(p); + if (mp_type(mp_red_part (q)) == mp_known_type + && mp_type(mp_green_part(q)) == mp_known_type + && mp_type(mp_blue_part (q)) == mp_known_type) + return 1; + break; + case mp_cmykcolor_type: + q = mp_get_value_node(p); + if (mp_type(mp_cyan_part (q)) == mp_known_type + && mp_type(mp_magenta_part(q)) == mp_known_type + && mp_type(mp_yellow_part (q)) == mp_known_type + && mp_type(mp_black_part (q)) == mp_known_type) + return 1; + break; + } + return 0; +} + +@ @<Declare unary action...@>= +static void mp_print_known_or_unknown_type (MP mp, int t, mp_node v) +{ + mp_print_chr(mp, '('); + if (t > mp_known_type) { + mp_print_str(mp, "unknown numeric"); + } else { + switch (t) { + case mp_pair_type: + case mp_color_type: + case mp_cmykcolor_type: + if (! mp_nice_color_or_pair (mp, v, t)) { + mp_print_str(mp, "unknown "); + } + break; + } + mp_print_type(mp, t); + } + mp_print_chr(mp, ')'); +} + +@ @<Declare unary action...@>= +static void mp_bad_unary (MP mp, int c) +{ + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_op(mp, c); + mp_print_known_or_unknown_type(mp, mp->cur_exp.type, cur_exp_node); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Not implemented: %s", mp_str(mp, sname)); + delete_str_ref(sname); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + msg, + "I'm afraid I don't know how to apply that operation to that particular type.\n" + "Continue, and I'll simply return the argument (shown above) as the result of the\n" + "operation." + ); + @.Not implemented...@> + mp_get_x_next(mp); +} + +@ Negation is easy except when the current expression is of type |independent|, +or when it is a pair with one or more |independent| components. + +@<Declare unary action...@>= +static void mp_negate_dep_list (MP mp, mp_value_node p) +{ + (void) mp; + while (1) { + number_negate(mp_get_dep_value(p)); + if (mp_get_dep_info(p) == NULL) + return; + p = (mp_value_node) mp_link(p); + } +} + +@ It is tempting to argue that the negative of an independent variable is an +independent variable, hence we don't have to do anything when negating it. The +fallacy is that other dependent variables pointing to the current expression must +change the sign of their coefficients if we make no change to the current +expression. + +Instead, we work around the problem by copying the current expression and +recycling it afterwards (cf.~the |stash_in| routine). + +@<Declare unary action...@>= + +static void mp_negate_value(MP mp, mp_node r) +{ + if (mp_type(r) == mp_known_type) { + mp_set_value_number(r, mp_get_value_number(r)); /* to clear the rest */ + number_negate(mp_get_value_number(r)); + } else { + mp_negate_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) r)); + } +} + +static void negate_cur_expr (MP mp) +{ + switch (mp->cur_exp.type) { + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + case mp_independent_type: + { + mp_node q = cur_exp_node; + mp_make_exp_copy(mp, q); + if (mp->cur_exp.type == mp_dependent_type) { + mp_negate_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) cur_exp_node)); + } else if (mp->cur_exp.type <= mp_pair_type) { + /* |mp_color_type| |mp_cmykcolor_type|, or |mp_pair_type| */ + mp_node p = mp_get_value_node(cur_exp_node); + // mp_node r; /* for list manipulation */ + switch (mp->cur_exp.type) { + case mp_pair_type: + mp_negate_value(mp, mp_x_part(p)); + mp_negate_value(mp, mp_y_part(p)); + break; + case mp_color_type: + mp_negate_value(mp, mp_red_part(p)); + mp_negate_value(mp, mp_green_part(p)); + mp_negate_value(mp, mp_blue_part(p)); + break; + case mp_cmykcolor_type: + mp_negate_value(mp, mp_cyan_part(p)); + mp_negate_value(mp, mp_magenta_part(p)); + mp_negate_value(mp, mp_yellow_part(p)); + mp_negate_value(mp, mp_black_part(p)); + break; + default: + break; + } + } + /* if |cur_type=mp_known| then |cur_exp=0| */ + mp_recycle_value(mp, q); + mp_free_value_node(mp, q); + } + break; + case mp_dependent_type: + case mp_proto_dependent_type: + mp_negate_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) cur_exp_node)); + break; + case mp_known_type: + if (is_number(cur_exp_value_number)) { + number_negate(cur_exp_value_number); + } + break; + default: + mp_bad_unary(mp, mp_minus_operation); + break; + } +} + +@ If the current expression is a pair, but the context wants it to be a path, we +call |pair_to_path|. + +@<Declare unary action...@>= +static void mp_pair_to_path (MP mp) { + mp_set_cur_exp_knot(mp, mp_pair_to_knot(mp)); + mp->cur_exp.type = mp_path_type; +} + +@ @<Declarations@>= +static void mp_bad_color_part (MP mp, int c); + +@ @c +static void mp_bad_color_part (MP mp, int c) +{ + mp_node p; /* the big node */ + mp_value new_expr; + char msg[256]; + int selector; + mp_string sname; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + p = mp_link(mp_edge_list(cur_exp_node)); + mp_disp_err(mp, NULL); + selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_op(mp, c); + sname = mp_make_string(mp); + mp->selector = selector; + @.Wrong picture color model...@> + switch (mp_color_model(p)) { + case mp_grey_model: mp_snprintf(msg, 256, "Wrong picture color model: %s of grey object", mp_str(mp, sname)); break; + case mp_cmyk_model: mp_snprintf(msg, 256, "Wrong picture color model: %s of cmyk object", mp_str(mp, sname)); break; + case mp_rgb_model: mp_snprintf(msg, 256, "Wrong picture color model: %s of rgb object", mp_str(mp, sname)); break; + case mp_no_model: mp_snprintf(msg, 256, "Wrong picture color model: %s of marking object", mp_str(mp, sname)); break; + default: mp_snprintf(msg, 256, "Wrong picture color model: %s of defaulted object", mp_str(mp, sname)); break; + } + delete_str_ref(sname); + mp_error( + mp, + msg, + "You can only ask for the redpart, greenpart, bluepart of a rgb object, the\n" + "cyanpart, magentapart, yellowpart or blackpart of a cmyk object, or the greypart\n" + "of a grey object. No mixing and matching, please." + ); + if (c == mp_black_part_operation) { + number_clone(new_expr.data.n, unity_t); + } else { + set_number_to_zero(new_expr.data.n); + } + mp_flush_cur_exp(mp, new_expr); +} + +@ In the following procedure, |cur_exp| points to a capsule, which points to a +big node. We want to delete all but one part of the big node. + +@<Declare unary action...@>= +static void mp_take_part (MP mp, int c) +{ + mp_node p = mp_get_value_node(cur_exp_node); /* the big node */ + mp_set_value_node(mp->temp_val, p); + mp_type(mp->temp_val) = mp->cur_exp.type; + mp_link(p) = mp->temp_val; + mp_free_value_node(mp, cur_exp_node); + switch (c) { + case mp_x_part_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_make_exp_copy(mp, mp_x_part(p)); + } else { + mp_make_exp_copy(mp, mp_tx_part(p)); + } + break; + case mp_y_part_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_make_exp_copy(mp, mp_y_part(p)); + } else { + mp_make_exp_copy(mp, mp_ty_part(p)); + } + break; + case mp_xx_part_operation: + mp_make_exp_copy(mp, mp_xx_part(p)); + break; + case mp_xy_part_operation: + mp_make_exp_copy(mp, mp_xy_part(p)); + break; + case mp_yx_part_operation: + mp_make_exp_copy(mp, mp_yx_part(p)); + break; + case mp_yy_part_operation: + mp_make_exp_copy(mp, mp_yy_part(p)); + break; + case mp_red_part_operation: + mp_make_exp_copy(mp, mp_red_part(p)); + break; + case mp_green_part_operation: + mp_make_exp_copy(mp, mp_green_part(p)); + break; + case mp_blue_part_operation: + mp_make_exp_copy(mp, mp_blue_part(p)); + break; + case mp_cyan_part_operation: + mp_make_exp_copy(mp, mp_cyan_part(p)); + break; + case mp_magenta_part_operation: + mp_make_exp_copy(mp, mp_magenta_part(p)); + break; + case mp_yellow_part_operation: + mp_make_exp_copy(mp, mp_yellow_part(p)); + break; + case mp_black_part_operation: + mp_make_exp_copy(mp, mp_black_part(p)); + break; + case mp_grey_part_operation: + mp_make_exp_copy(mp, mp_grey_part(p)); + break; + } + mp_recycle_value(mp, mp->temp_val); +} + +@ @<Initialize table entries@>= +mp->temp_val = mp_new_value_node(mp); +mp_name_type(mp->temp_val) = mp_capsule_operation; + +@ @<Free table entries@>= +mp_free_value_node(mp, mp->temp_val); + +@ @<Declarations@>= +static mp_edge_header_node mp_scale_edges (MP mp, mp_number *se_sf, mp_edge_header_node se_pic); + +@ @<Declare unary action...@>= +static void mp_take_pict_part (MP mp, int c) +{ + mp_node p; /* first graphical object in |cur_exp| */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + p = mp_link(mp_edge_list(cur_exp_node)); + if (p != NULL) { + switch (c) { + case mp_x_part_operation: + case mp_y_part_operation: + case mp_xx_part_operation: + case mp_xy_part_operation: + case mp_yx_part_operation: + case mp_yy_part_operation: + goto NOT_FOUND; + case mp_red_part_operation: + case mp_green_part_operation: + case mp_blue_part_operation: + if (mp_has_color(p)) { + switch (c) { + case mp_red_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->red); + break; + case mp_green_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->green); + break; + case mp_blue_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->blue); + break; + } + mp_flush_cur_exp(mp, new_expr); + } else + goto NOT_FOUND; + break; + case mp_cyan_part_operation: + case mp_magenta_part_operation: + case mp_yellow_part_operation: + case mp_black_part_operation: + if (mp_has_color(p)) { + if (mp_color_model(p) == mp_uninitialized_model && c == mp_black_part_operation) { + set_number_to_unity(new_expr.data.n); + } else { + switch (c) { + case mp_cyan_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->cyan); + break; + case mp_magenta_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->magenta); + break; + case mp_yellow_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->yellow); + break; + case mp_black_part_operation: + number_clone(new_expr.data.n, ((mp_shape_node) p)->black); + break; + } + } + mp_flush_cur_exp(mp, new_expr); + } else + goto NOT_FOUND; + break; + case mp_grey_part_operation: + if (mp_has_color(p)) { + number_clone(new_expr.data.n, ((mp_shape_node) p)->grey); + mp_flush_cur_exp(mp, new_expr); + } else + goto NOT_FOUND; + break; + case mp_color_model_operation: + if (mp_has_color(p)) { + if (mp_color_model(p) == mp_uninitialized_model) { + /* could use the else branch with int variant */ + number_clone(new_expr.data.n, internal_value(mp_default_color_model_internal)); + } else { + number_clone(new_expr.data.n, unity_t); + number_multiply_int(new_expr.data.n, mp_color_model(p)); + } + mp_flush_cur_exp(mp, new_expr); + } else + goto NOT_FOUND; + break; + case mp_prescript_part_operation: + if (! mp_has_script(p)) { + goto NOT_FOUND; + } else { + if (mp_pre_script(p)) { + new_expr.data.str = mp_pre_script(p); + add_str_ref(new_expr.data.str); + } else { + new_expr.data.str = mp_rts(mp,""); + } + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_string_type; + }; + break; + case mp_postscript_part_operation: + if (! mp_has_script(p)) { + goto NOT_FOUND; + } else { + if (mp_post_script(p)) { + new_expr.data.str = mp_post_script(p); + add_str_ref(new_expr.data.str); + } else { + new_expr.data.str = mp_rts(mp,""); + } + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_string_type; + }; + break; + case mp_stacking_part_operation: + number_clone(new_expr.data.n, unity_t); + number_multiply_int(new_expr.data.n, mp_stacking(p)); + mp_flush_cur_exp(mp, new_expr); + break; + case mp_path_part_operation: + if (mp_is_stop(p)) { + mp_confusion(mp, "picture"); + } else { + new_expr.data.node = NULL; + switch (mp_type(p)) { + case mp_fill_node_type: + case mp_stroked_node_type: + new_expr.data.p = mp_copy_path(mp, mp_path_ptr((mp_shape_node) p)); + break; + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + new_expr.data.p = mp_copy_path(mp, mp_path_ptr((mp_start_node) p)); + break; + default: + break; + } + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_path_type; + } + break; + case mp_pen_part_operation: + if (! mp_has_pen(p)) { + goto NOT_FOUND; + } else { + switch (mp_type(p)) { + case mp_fill_node_type: + case mp_stroked_node_type: + if (mp_pen_ptr((mp_shape_node) p) == NULL) { + goto NOT_FOUND; + } else { + new_expr.data.p = mp_copy_pen(mp, mp_pen_ptr((mp_shape_node) p)); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_pen_type((mp_shape_node) p) ? mp_nep_type : mp_pen_type ; + } + break; + default: + break; + } + } + break; + case mp_dash_part_operation: + if (mp_type(p) != mp_stroked_node_type) { + goto NOT_FOUND; + } else if (mp_dash_ptr(p) == NULL) { + goto NOT_FOUND; + } else { + mp_add_edge_ref(mp, mp_dash_ptr(p)); + new_expr.data.node = (mp_node) mp_scale_edges(mp, + &(((mp_shape_node) p)->dashscale), (mp_edge_header_node) mp_dash_ptr(p)); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_picture_type; + } + break; + } + return; + }; + NOT_FOUND: + /* Convert the current expression to a NULL value appropriate for |c| */ + switch (c) { + case mp_prescript_part_operation: + case mp_postscript_part_operation: + new_expr.data.str = mp_rts(mp,""); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_string_type; + break; + case mp_path_part_operation: + new_expr.data.p = mp_new_knot(mp); + mp_flush_cur_exp(mp, new_expr); + mp_left_type(cur_exp_knot) = mp_endpoint_knot; + mp_right_type(cur_exp_knot) = mp_endpoint_knot; + mp_prev_knot(cur_exp_knot) = cur_exp_knot; + mp_next_knot(cur_exp_knot) = cur_exp_knot; + set_number_to_zero(cur_exp_knot->x_coord); + set_number_to_zero(cur_exp_knot->y_coord); + mp_originator(cur_exp_knot) = mp_metapost_user; + mp_knotstate(cur_exp_knot) = mp_regular_knot; + mp->cur_exp.type = mp_path_type; + break; + case mp_pen_part_operation: + new_expr.data.p = mp_get_pen_circle(mp, &zero_t); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_pen_type; /* todo: mp_nep_type */ + break; + case mp_dash_part_operation: + new_expr.data.node = (mp_node) mp_get_edge_header_node(mp); + mp_flush_cur_exp(mp, new_expr); + mp_init_edges(mp, (mp_edge_header_node) cur_exp_node); + mp->cur_exp.type = mp_picture_type; + break; + default: + set_number_to_zero(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); + break; + } +} + +@ This one is stripped because it only handles |ASCII|. Watch out, the |ASCII| +operator only looks at the first character and then just interprets the character +as byte. One can implement a \UTF\ interpreter in \LUA. + +@<Declare unary action...@>= +static void mp_str_to_num (MP mp) +{ + /* converts a string to a number */ + int n; /* accumulator */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (cur_exp_str->len == 0) { + n = -1; + } else { + n = cur_exp_str->str[0]; + } + number_clone(new_expr.data.n, unity_t); + number_multiply_int(new_expr.data.n, n); + mp_flush_cur_exp(mp, new_expr); +} + +@ This computes the length of the current path or picture. The only benefit from +not using the numbers but a temporary |int| instead is .5K smaller which is due +to less interfacing. But it also demonstrates that on the one hand the number +system indirectness adds quite some bytes but on the other hand todays compilers +do a pretty good job at optimizing (for performance). Which of course doesn't +mean that scaled outperforms double manyfold while decimal is always way slower. + +@<Declarations@>= +static void mp_path_length (MP mp, mp_number *n); + +@ @<Declare unary action...@>= +static void mp_path_length (MP mp, mp_number *n) +{ + mp_knot p = cur_exp_knot; + int l = mp_left_type(p) == mp_endpoint_knot ? -1 : 0; + do { + p = mp_next_knot(p); + ++l; + } while (p != cur_exp_knot); + set_number_from_int(*n, l); +} + +static void mp_picture_length (MP mp, mp_number *n) +{ + /* counts interior components in picture |cur_exp| */ + mp_node p = mp_link(mp_edge_list(cur_exp_node)); + int l = 0; + if (p != NULL) { + if (mp_is_start_or_stop(p) && mp_skip_1component(mp, p) == NULL) { + p = mp_link(p); + } + while (p != NULL) { + if (! mp_is_start_or_stop(p)) { + p = mp_link(p); + } else if (! mp_is_stop(p)) { + p = mp_skip_1component(mp, p); + } else { + break; + } + ++l; + } + } + set_number_from_int(*n, l); +} + +@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if +the argument is |origin|. + +@<Declare unary action...@>= +static void mp_an_angle (MP mp, mp_number *ret, mp_number *xpar, mp_number *ypar) +{ + set_number_to_zero(*ret); + if (! (number_zero(*xpar) && number_zero(*ypar))) { + n_arg(*ret, *xpar, *ypar); + } +} + +@ The actual turning number is (for the moment) computed in a C function that +receives eight integers corresponding to the four controlling points, and returns +a single angle. Besides those, we have to account for discrete moves at the +actual points. + +@d mp_floor(a) ((a) >= 0 ? (int) (a) : -(int) (-(a))) +@d bezier_error (720*(256*256*16))+1 +@d mp_sign(v) ((v) > 0 ? 1 : ((v)<0 ? -1 : 0 )) +@d mp_out(A) (double)((A)/16) + +@<Declare unary action...@>= +static void mp_bezier_slope (MP mp, + mp_number *ret, mp_number *AX, mp_number *AY, mp_number *BX, + mp_number *BY, mp_number *CX, mp_number *CY, mp_number *DX, + mp_number *DY +); + +@ @c +static void mp_bezier_slope (MP mp, + mp_number *ret, mp_number *AX, mp_number *AY, mp_number *BX, + mp_number *BY, mp_number *CX, mp_number *CY, mp_number *DX, + mp_number *DY +) +{ + double a, b, c; + mp_number deltax, deltay; + mp_number xi, xo, xm; + double res = 0.0; + double ax = number_to_double(*AX); + double ay = number_to_double(*AY); + double bx = number_to_double(*BX); + double by = number_to_double(*BY); + double cx = number_to_double(*CX); + double cy = number_to_double(*CY); + double dx = number_to_double(*DX); + double dy = number_to_double(*DY); + new_number(deltax); + new_number(deltay); + set_number_from_subtraction(deltax, *BX, *AX); + set_number_from_subtraction(deltay, *BY, *AY); + if (number_zero(deltax) && number_zero(deltay)) { + set_number_from_subtraction(deltax, *CX, *AX); + set_number_from_subtraction(deltay, *CY, *AY); + } + if (number_zero(deltax) && number_zero(deltay)) { + set_number_from_subtraction(deltax, *DX, *AX); + set_number_from_subtraction(deltay, *DY, *AY); + } + new_number(xi); + new_number(xm); + new_number(xo); + mp_an_angle(mp, &xi, &deltax, &deltay); + set_number_from_subtraction(deltax, *CX, *BX); + set_number_from_subtraction(deltay, *CY, *BY); + mp_an_angle(mp, &xm, &deltax, &deltay); /* !!! never used? */ + set_number_from_subtraction(deltax, *DX, *CX); + set_number_from_subtraction(deltay, *DY, *CY); + if (number_zero(deltax) && number_zero(deltay)) { + set_number_from_subtraction(deltax, *DX, *BX); + set_number_from_subtraction(deltay, *DY, *BY); + } + if (number_zero(deltax) && number_zero(deltay)) { + set_number_from_subtraction(deltax, *DX, *AX); + set_number_from_subtraction(deltay, *DY, *AY); + } + mp_an_angle(mp, &xo, &deltax, &deltay); + a = (bx - ax) * (cy - by) - (cx - bx) * (by - ay); /* a = (bp-ap)x(cp-bp); */ + b = (bx - ax) * (dy - cy) - (by - ay) * (dx - cx); /* b = (bp-ap)x(dp-cp); */ + c = (cx - bx) * (dy - cy) - (dx - cx) * (cy - by); /* c = (cp-bp)x(dp-cp); */ + if ((a == 0.0) && (c == 0.0)) { + res = (b == 0.0 ? 0.0 : (mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)))); + } else if ((a == 0.0) || (c == 0.0)) { + if ((mp_sign (b) == mp_sign (a)) || (mp_sign (b) == mp_sign (c))) { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); /* ? */ + if (res < -180.0) { + res += 360.0; + } else if (res > 180.0) { + res -= 360.0; + } + } else { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); /* ? */ + } + } else if ((mp_sign (a) * mp_sign (c)) < 0.0) { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); + if (res < -180.0) { + res += 360.0; + } else if (res > 180.0) { + res -= 360.0; + } + } else if (mp_sign (a) == mp_sign (b)) { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); + if (res < -180.0) { + res += 360.0; + } else if (res > 180.0) { + res -= 360.0; + } + } else if ((b * b) == (4.0 * a * c)) { + res = (double) bezier_error; + } else if ((b * b) < (4.0 * a * c)) { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); + if (res <= 0.0 && res > -180.0) { + res += 360.0; + } else if (res >= 0.0 && res < 180.0) { + res -= 360.0; + } + } else { + res = mp_out(number_to_double(xo)) - mp_out(number_to_double(xi)); + if (res < -180.0) { + res += 360.0; + } else if (res > 180.0) { + res -= 360.0; + } + } + free_number(deltax); + free_number(deltay); + free_number(xi); + free_number(xo); + free_number(xm); + set_number_from_double(*ret, res); + convert_scaled_to_angle(*ret); +} + +@d p_nextnext mp_next_knot(mp_next_knot(p)) +@d p_next mp_next_knot(p) + +@<Declare unary action...@>= +static void mp_turn_cycles (MP mp, mp_number *turns, mp_knot c) +{ + int selector; /* saved |selector| setting */ + mp_angle res, ang; /* the angles of intermediate results */ + mp_knot p; /* for running around the path */ + mp_number xp, yp; /* coordinates of next point */ + mp_number x, y; /* helper coordinates */ + mp_number arg1, arg2; + mp_angle in_angle, out_angle; /* helper angles */ + mp_angle seven_twenty_deg_t; + set_number_to_zero(*turns); + new_number(arg1); + new_number(arg2); + new_number(xp); + new_number(yp); + new_number(x); + new_number(y); + new_angle(in_angle); + new_angle(out_angle); + new_angle(ang); + new_angle(res); + new_angle(seven_twenty_deg_t); + number_clone(seven_twenty_deg_t, three_sixty_deg_t); + number_double(seven_twenty_deg_t); + p = c; + selector = mp->selector; + mp->selector = mp_term_only_selector; + if (number_greater(internal_value(mp_tracing_commands_internal), unity_t)) { + mp_begin_diagnostic(mp); + mp_print_nl(mp, ""); + mp_end_diagnostic(mp, 0); + } + do { + number_clone(xp, p_next->x_coord); + number_clone(yp, p_next->y_coord); + mp_bezier_slope(mp, &ang, &(p->x_coord), &(p->y_coord), &(p->right_x), &(p->right_y), &(p_next->left_x), &(p_next->left_y), &xp, &yp); + if (number_greater(ang, seven_twenty_deg_t)) { + mp_error(mp, "Strange path", NULL); + mp->selector = selector; + set_number_to_zero(*turns); + goto DONE; + } + number_add(res, ang); + if (number_greater(res, one_eighty_deg_t)) { + number_subtract(res, three_sixty_deg_t); + number_add(*turns, unity_t); + } + if (number_lessequal(res, negative_one_eighty_deg_t)) { + number_add(res, three_sixty_deg_t); + number_subtract(*turns, unity_t); + } + /* incoming angle at next point */ + number_clone(x, p_next->left_x); + number_clone(y, p_next->left_y); + if (number_equal(xp, x) && number_equal(yp, y)) { + number_clone(x, p->right_x); + number_clone(y, p->right_y); + } + if (number_equal(xp, x) && number_equal(yp, y)) { + number_clone(x, p->x_coord); + number_clone(y, p->y_coord); + } + set_number_from_subtraction(arg1, xp, x); + set_number_from_subtraction(arg2, yp, y); + mp_an_angle(mp, &in_angle, &arg1, &arg2); + /* outgoing angle at next point */ + number_clone(x, p_next->right_x); + number_clone(y, p_next->right_y); + if (number_equal(xp, x) && number_equal(yp, y)) { + number_clone(x, p_nextnext->left_x); + number_clone(y, p_nextnext->left_y); + } + if (number_equal(xp, x) && number_equal(yp, y)) { + number_clone(x, p_nextnext->x_coord); + number_clone(y, p_nextnext->y_coord); + } + set_number_from_subtraction(arg1, x, xp); + set_number_from_subtraction(arg2, y, yp); + mp_an_angle(mp, &out_angle, &arg1, &arg2); + set_number_from_subtraction(ang, out_angle, in_angle); + mp_reduce_angle(mp, &ang); + if (number_nonzero(ang)) { + number_add(res, ang); + if (number_greaterequal(res, one_eighty_deg_t)) { + number_subtract(res, three_sixty_deg_t); + number_add(*turns, unity_t); + } + if (number_lessequal(res, negative_one_eighty_deg_t)) { + number_add(res, three_sixty_deg_t); + number_subtract(*turns, unity_t); + } + } + p = mp_next_knot(p); + } while (p != c); + mp->selector = selector; + DONE: + free_number(xp); + free_number(yp); + free_number(x); + free_number(y); + free_number(seven_twenty_deg_t); + free_number(in_angle); + free_number(out_angle); + free_number(ang); + free_number(res); + free_number(arg1); + free_number(arg2); +} + +@ @<Declare unary action...@>= +static void mp_turn_cycles_wrapper (MP mp, mp_number *ret, mp_knot c) +{ + if (mp_next_knot(c) == c) { + /* one-knot paths always have a turning number of 1 */ + set_number_to_unity(*ret); + } else { + mp_turn_cycles (mp, ret, c); + } +} + +@ @<Declare unary action procedures@>= +static int mp_test_known (MP mp, int c) +{ + int b = mp_false_operation; /* is the current expression known? */ + switch (mp->cur_exp.type) { + case mp_vacuous_type: + case mp_boolean_type: + case mp_string_type: + case mp_pen_type: + case mp_nep_type: + case mp_path_type: + case mp_picture_type: + case mp_known_type: + b = mp_true_operation; + break; + case mp_transform_type: + { + mp_node p = mp_get_value_node(cur_exp_node); + if ( (mp_type(mp_tx_part(p)) == mp_known_type) && + (mp_type(mp_ty_part(p)) == mp_known_type) && + (mp_type(mp_xx_part(p)) == mp_known_type) && + (mp_type(mp_xy_part(p)) == mp_known_type) && + (mp_type(mp_yx_part(p)) == mp_known_type) && + (mp_type(mp_yy_part(p)) == mp_known_type) ) { + b = mp_true_operation; + } + } + break; + case mp_color_type: + { + mp_node p = mp_get_value_node(cur_exp_node); + if ( (mp_type(mp_red_part(p)) == mp_known_type) && + (mp_type(mp_green_part(p)) == mp_known_type) && + (mp_type(mp_blue_part(p)) == mp_known_type) ) { + b = mp_true_operation; + } + } + break; + case mp_cmykcolor_type: + { + mp_node p = mp_get_value_node(cur_exp_node); + if ( (mp_type(mp_cyan_part(p)) == mp_known_type) && + (mp_type(mp_magenta_part(p)) == mp_known_type) && + (mp_type(mp_yellow_part(p)) == mp_known_type) && + (mp_type(mp_black_part(p)) == mp_known_type) ) { + b = mp_true_operation; + } + } + break; + case mp_pair_type: + { + mp_node p = mp_get_value_node(cur_exp_node); + if ( (mp_type(mp_x_part(p)) == mp_known_type) && + (mp_type(mp_y_part(p)) == mp_known_type) ) { + b = mp_true_operation; + } + } + break; + default: + break; + } + if (c == mp_known_operation) { + return b; + } else { + return b == mp_true_operation ? mp_false_operation : mp_true_operation; + } +} + +@ The |pair_value| routine changes the current expression to a given ordered pair +of values. + +@<Declarations@>= +static void mp_pair_value (MP mp, mp_number *x, mp_number *y); + +@ @<Declare unary action procedures@>= +static void mp_pair_value (MP mp, mp_number *x, mp_number *y) +{ + mp_node p; /* a pair node */ + mp_value new_expr; + mp_number x1, y1; + new_number_clone(x1, *x); + new_number_clone(y1, *y); + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + p = mp_new_value_node(mp); + new_expr.type = mp_type(p); + new_expr.data.node = p; + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_pair_type; + mp_name_type(p) = mp_capsule_operation; + mp_init_pair_node(mp, p); + p = mp_get_value_node(p); + mp_type(mp_x_part(p)) = mp_known_type; + mp_set_value_number(mp_x_part(p), x1); + mp_type(mp_y_part(p)) = mp_known_type; + mp_set_value_number(mp_y_part(p), y1); + free_number(x1); + free_number(y1); +} + +@ Here is a function that sets |minx|, |maxx|, |miny|, |maxy| to the bounding +box of the current expression. The boolean result is |false| if the expression +has the wrong type. + +@<Declare unary action procedures@>= +static int mp_get_cur_bbox (MP mp) +{ + switch (mp->cur_exp.type) { + case mp_picture_type: + { + mp_edge_header_node p = (mp_edge_header_node) cur_exp_node; + mp_set_bbox(mp, p, 1); + if (number_greater(p->minx, p->maxx)) { + set_number_to_zero(mp_minx); + set_number_to_zero(mp_maxx); + set_number_to_zero(mp_miny); + set_number_to_zero(mp_maxy); + } else { + number_clone(mp_minx, p->minx); + number_clone(mp_maxx, p->maxx); + number_clone(mp_miny, p->miny); + number_clone(mp_maxy, p->maxy); + } + } + break; + case mp_path_type: + mp_path_bbox(mp, cur_exp_knot); + break; + case mp_pen_type: + case mp_nep_type: + mp_pen_bbox(mp, cur_exp_knot); + break; + default: + return 0; + } + return 1; +} + +static int mp_get_cur_xbox (MP mp) +{ + if (mp->cur_exp.type == mp_path_type) { + mp_path_xbox(mp, cur_exp_knot); + return 1; + } else { + return mp_get_cur_bbox(mp); + } +} + +static int mp_get_cur_ybox (MP mp) +{ + if (mp->cur_exp.type == mp_path_type) { + mp_path_ybox(mp, cur_exp_knot); + return 1; + } else { + return mp_get_cur_bbox(mp); + } +} + +@ Here is a routine that interprets |cur_exp| as a file name and tries to read a +line from the file or to close the file. + +@<Declare unary action procedures@>= +static void mp_do_read_or_close (MP mp, int c) +{ + int n = mp->read_files; + int n0 = mp->read_files; + char *fn = mp_strdup(mp_str(mp, cur_exp_str)); + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + /* + Find the |n| where |rd_fname[n]=cur_exp|; if |cur_exp| must be inserted, + call |start_read_input| and |goto found| or |not_found|. Free slots in + the |rd_file| and |rd_fname| arrays are marked with NULL's in |rd_fname|. + */ + while (mp_strcmp(fn, mp->rd_fname[n]) != 0) { + if (n > 0) { + --n; + } else if (c == mp_close_from_operation) { + goto CLOSE_FILE; + } else { + if (n0 == mp->read_files) { + if (mp->read_files < mp->max_read_files) { + ++mp->read_files; + } else { + void **rd_file; + char **rd_fname; + int l; + l = mp->max_read_files + (mp->max_read_files / 4); + rd_file = mp_memory_allocate((size_t) (l + 1) * sizeof(void *)); + rd_fname = mp_memory_allocate((size_t) (l + 1) * sizeof(char *)); + for (int k = 0; k <= l; k++) { + if (k <= mp->max_read_files) { + rd_file[k] = mp->rd_file[k]; + rd_fname[k] = mp->rd_fname[k]; + } else { + rd_file[k] = 0; + rd_fname[k] = NULL; + } + } + mp_memory_free(mp->rd_file); + mp_memory_free(mp->rd_fname); + mp->max_read_files = l; + mp->rd_file = rd_file; + mp->rd_fname = rd_fname; + } + } + n = n0; + if (mp_start_read_input(mp, fn, n)) { + goto FOUND; + } else { + goto NOT_FOUND; + } + } + if (mp->rd_fname[n] == NULL) { + n0 = n; + } + } + if (c == mp_close_from_operation) { + (mp->close_file) (mp, mp->rd_file[n]); + goto NOT_FOUND; + } + mp_begin_file_reading(mp); + name = is_read; + if (mp_input_ln(mp, mp->rd_file[n])) { + goto FOUND; + } + mp_end_file_reading(mp); + NOT_FOUND: + /* Record the end of file and set |cur_exp| to a dummy value */ + mp_memory_free(mp->rd_fname[n]); + mp->rd_fname[n] = NULL; + if (n == mp->read_files - 1) { + mp->read_files = n; + } + if (c == mp_close_from_operation) { + goto CLOSE_FILE; + } + // new_expr.data.str = mp->eof_line; + new_expr.data.str = mp->eof_file; + add_str_ref(new_expr.data.str); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_string_type; + return; + CLOSE_FILE: + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_vacuous_type; + return; + FOUND: + mp_flush_cur_exp(mp, new_expr); + mp_finish_read(mp); +} + +@ The string denoting end-of-file is a one-byte string at position zero, by +definition. I have to cheat a little here because + +@<Glob...@>= +mp_string eof_line; +mp_string eof_file; + +@ @<Set init...@>= +mp->eof_line = mp_rtsl (mp, "\0", 1); +mp->eof_line->refs = MAX_STR_REF; +mp->eof_file = mp_rtsl (mp, "%", 1); +mp->eof_file->refs = MAX_STR_REF; + +@ Finally, we have the operations that combine a capsule~|p| with the current +expression. + +Several of the binary operations are potentially complicated by the fact that +|independent| values can sneak into capsules. For example, we've seen an instance +of this difficulty in the unary operation of negation. In order to reduce the +number of cases that need to be handled, we first change the two operands (if +necessary) to rid them of |independent| components. The original operands are put +into capsules called |old_p| and |old_exp|, which will be recycled after the +binary operation has been safely carried out. + +@c +@<Declare binary action procedures@> +static void mp_finish_binary (MP mp, mp_node old_p, mp_node old_exp) +{ + check_arith(); + /* Recycle any sidestepped |independent| capsules */ + if (old_p != NULL) { + mp_recycle_value(mp, old_p); + mp_free_value_node(mp, old_p); + } + if (old_exp != NULL) { + mp_recycle_value(mp, old_exp); + mp_free_value_node(mp, old_exp); + } +} + +static void mp_do_binary (MP mp, mp_node p, int c) +{ + mp_node old_p, old_exp; /* capsules to recycle */ + mp_value new_expr; + check_arith(); + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + /* Trace the current binary operation */ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{("); + /* show the operand, but not verbosely */ + mp_print_exp(mp, p, 0); + mp_print_chr(mp, ')'); + mp_print_op(mp, (int) c); + mp_print_chr(mp, '('); + mp_print_exp(mp, NULL, 0); + mp_print_str(mp, ")}"); + mp_end_diagnostic(mp, 0); + } + /* + Sidestep |independent| cases in capsule |p|. A big node is considered to be + \quote {tarnished} if it contains at least one independent component. We will + define a simple function called |tarnished| that returns |NULL| if and only + if its argument is not tarnished. + */ + switch (mp_type(p)) { + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + old_p = mp_tarnished(mp, p); + break; + case mp_independent_type: + old_p = MP_VOID; + break; + default: + old_p = NULL; + break; + } + if (old_p != NULL) { + mp_node q = mp_stash_cur_exp(mp); + old_p = p; + mp_make_exp_copy(mp, old_p); + p = mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, q); + } + /* Sidestep |independent| cases in the current expression */ + switch (mp->cur_exp.type) { + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + old_exp = mp_tarnished(mp, cur_exp_node); + break; + case mp_independent_type: + old_exp = MP_VOID; + break; + default: + old_exp = NULL; + break; + } + if (old_exp != NULL) { + old_exp = cur_exp_node; + mp_make_exp_copy(mp, old_exp); + } + switch (c) { + case mp_plus_operation: + case mp_minus_operation: + /* Add or subtract the current expression from |p| */ + if ((mp->cur_exp.type < mp_color_type) || (mp_type(p) < mp_color_type)) { + mp_bad_binary(mp, p, c); + } else { + if ((mp->cur_exp.type > mp_pair_type) && (mp_type(p) > mp_pair_type)) { + mp_add_or_subtract(mp, p, NULL, c); + } else if (mp->cur_exp.type != mp_type(p)) { + /* + We catch a mismatch, so we can handle intermediates (assuming a flexible withcolor); + if we would go double only live would be easier ... I might eventually make a more + generic color type. + */ + /* + if (mp->cur_exp.type == mp_color_type && mp_type(p) == mp_cmykcolor_type) { + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + number_negate((mp_cyan_part(q))->data.n); + number_negate((mp_magenta_part(q))->data.n); + number_negate((mp_yellow_part(q))->data.n); + number_add((mp_cyan_part(q))->data.n, unity_t); + number_add((mp_magenta_part(q))->data.n, unity_t); + number_add((mp_yellow_part(q))->data.n, unity_t); + mp_add_or_subtract(mp, mp_cyan_part(q), mp_red_part(r), c); + mp_add_or_subtract(mp, mp_magenta_part(q), mp_green_part(r), c); + mp_add_or_subtract(mp, mp_yellow_part(q), mp_blue_part(r), c); + } else if (mp->cur_exp.type == mp_cmykcolor_type && mp_type(p) == mp_color_type) { + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + number_negate((mp_red_part(q))->data.n); + number_negate((mp_green_part(q))->data.n); + number_negate((mp_blue_part(q))->data.n); + number_add((mp_red_part(q))->data.n, unity_t); + number_add((mp_green_part(q))->data.n, unity_t); + number_add((mp_blue_part(q))->data.n, unity_t); + mp_add_or_subtract(mp, mp_red_part(q), mp_cyan_part(r), c); + mp_add_or_subtract(mp, mp_green_part(q), mp_magenta_part(r), c); + mp_add_or_subtract(mp, mp_blue_part(q), mp_yellow_part(r), c); + } else { + */ + mp_bad_binary(mp, p, c); + /* } */ + } else { + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + switch (mp->cur_exp.type) { + case mp_pair_type: + mp_add_or_subtract(mp, mp_x_part(q), mp_x_part(r), c); + mp_add_or_subtract(mp, mp_y_part(q), mp_y_part(r), c); + break; + case mp_color_type: + mp_add_or_subtract(mp, mp_red_part(q), mp_red_part(r), c); + mp_add_or_subtract(mp, mp_green_part(q), mp_green_part(r), c); + mp_add_or_subtract(mp, mp_blue_part(q), mp_blue_part(r), c); + break; + case mp_cmykcolor_type: + mp_add_or_subtract(mp, mp_cyan_part(q), mp_cyan_part(r), c); + mp_add_or_subtract(mp, mp_magenta_part(q), mp_magenta_part(r), c); + mp_add_or_subtract(mp, mp_yellow_part(q), mp_yellow_part(r), c); + mp_add_or_subtract(mp, mp_black_part(q), mp_black_part(r), c); + break; + case mp_transform_type: + mp_add_or_subtract(mp, mp_tx_part(q), mp_tx_part(r), c); + mp_add_or_subtract(mp, mp_ty_part(q), mp_ty_part(r), c); + mp_add_or_subtract(mp, mp_xx_part(q), mp_xx_part(r), c); + mp_add_or_subtract(mp, mp_xy_part(q), mp_xy_part(r), c); + mp_add_or_subtract(mp, mp_yx_part(q), mp_yx_part(r), c); + mp_add_or_subtract(mp, mp_yy_part(q), mp_yy_part(r), c); + break; + default: + break; + } + } + } + break; + case mp_less_than_operation: + case mp_less_or_equal_operation: + case mp_greater_than_operation: + case mp_greater_or_equal_operation: + case mp_equal_operation: + case mp_unequal_operation: + check_arith(); + /* at this point |arith_error| should be |false|? */ + if ((mp->cur_exp.type > mp_pair_type) && (mp_type(p) > mp_pair_type)) { + /* |cur_exp:=(p)-cur_exp| */ + mp_add_or_subtract(mp, p, NULL, mp_minus_operation); + } else if (mp->cur_exp.type != mp_type(p)) { + mp_bad_binary(mp, p, (int) c); + goto DONE; + } else { + /* + Reduce comparison of big nodes to comparison of scalars. In the + following, the |while| loops exist just so that |break| can be + used, each loop runs exactly once. + */ + switch (mp->cur_exp.type) { + case mp_string_type: + { + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + set_number_from_scaled(new_expr.data.n, mp_str_vs_str(mp, mp_get_value_str(p), cur_exp_str)); + mp_flush_cur_exp(mp, new_expr); + } + break; + case mp_unknown_string_type: + case mp_unknown_boolean_type: + { + /* + Check if unknowns have been equated. When two unknown strings are + in the same ring, we know that they are equal. Otherwise, we + don't know whether they are equal or not, so we make no change. + */ + mp_node q = mp_get_value_node(cur_exp_node); + while ((q != cur_exp_node) && (q != p)) { + q = mp_get_value_node(q); + } + if (q == p) { + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_set_cur_exp_node(mp, NULL); + mp_flush_cur_exp(mp, new_expr); + } + } + break; + case mp_pair_type: + { + int part_type = 0; + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + while (part_type == 0) { + mp_node rr = mp_x_part(r); + part_type = mp_x_part_operation; + mp_add_or_subtract(mp, mp_x_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_y_part(r); + part_type = mp_y_part_operation; + mp_add_or_subtract(mp, mp_y_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + } + mp_take_part(mp, part_type); + } + break; + case mp_color_type: + { + int part_type = 0; + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + while (part_type == 0) { + mp_node rr = mp_red_part(r); + part_type = mp_red_part_operation; + mp_add_or_subtract(mp, mp_red_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_green_part(r); + part_type = mp_green_part_operation; + mp_add_or_subtract(mp, mp_green_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_blue_part(r); + part_type = mp_blue_part_operation; + mp_add_or_subtract(mp, mp_blue_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + } + mp_take_part(mp, part_type); + } + break; + case mp_cmykcolor_type: + { + int part_type = 0; + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + while (part_type == 0) { + mp_node rr = mp_cyan_part(r); + part_type = mp_cyan_part_operation; + mp_add_or_subtract(mp, mp_cyan_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_magenta_part(r); + part_type = mp_magenta_part_operation; + mp_add_or_subtract(mp, mp_magenta_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_yellow_part(r); + part_type = mp_yellow_part_operation; + mp_add_or_subtract(mp, mp_yellow_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_black_part(r); + part_type = mp_black_part_operation; + mp_add_or_subtract(mp, mp_black_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + } + mp_take_part(mp, part_type); + } + break; + case mp_transform_type: + { + int part_type = 0; + mp_node q = mp_get_value_node(p); + mp_node r = mp_get_value_node(cur_exp_node); + while (part_type == 0) { + mp_node rr = mp_tx_part(r); + part_type = mp_x_part_operation; + mp_add_or_subtract(mp, mp_tx_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_ty_part(r); + part_type = mp_y_part_operation; + mp_add_or_subtract(mp, mp_ty_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_xx_part(r); + part_type = mp_xx_part_operation; + mp_add_or_subtract(mp, mp_xx_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_xy_part(r); + part_type = mp_xy_part_operation; + mp_add_or_subtract(mp, mp_xy_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_yx_part(r); + part_type = mp_yx_part_operation; + mp_add_or_subtract(mp, mp_yx_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + rr = mp_yy_part(r); + part_type = mp_yy_part_operation; + mp_add_or_subtract(mp, mp_yy_part(q), rr, mp_minus_operation); + if (mp_type(rr) != mp_known_type || ! number_zero(mp_get_value_number(rr))) { + break; + } + } + mp_take_part(mp, part_type); + } + break; + case mp_boolean_type: + { + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + set_number_from_boolean(new_expr.data.n, number_to_scaled(cur_exp_value_number) - number_to_scaled(mp_get_value_number(p))); + mp_flush_cur_exp(mp, new_expr); + } + break; + default: + mp_bad_binary(mp, p, (int) c); + goto DONE; + break; + } + } + /* Compare the current expression with zero */ + if (mp->cur_exp.type != mp_known_type) { + const char *hlp = NULL; + if (mp->cur_exp.type < mp_known_type) { + mp_disp_err(mp, p); + hlp = "The quantities shown above have not been equated."; + } else { + hlp = + "Oh dear. I can't decide if the expression above is positive, negative, or zero.\n" + "So this comparison test won't be 'true'."; + } + mp_disp_err(mp, NULL); + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + set_number_from_boolean(new_expr.data.n, mp_false_operation); + mp_back_error(mp, "Unknown relation will be considered false", hlp); + @.Unknown relation...@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + int b = 0; + switch (c) { + case mp_less_than_operation: + b = number_negative(cur_exp_value_number); + break; + case mp_less_or_equal_operation: + b = number_nonpositive(cur_exp_value_number); + break; + case mp_greater_than_operation: + b = number_positive(cur_exp_value_number); + break; + case mp_greater_or_equal_operation: + b = number_nonnegative(cur_exp_value_number); + break; + case mp_equal_operation: + b = number_zero(cur_exp_value_number); + break; + case mp_unequal_operation: + b = number_nonzero(cur_exp_value_number); + break; + }; + mp_set_cur_exp_value_boolean(mp, b ? mp_true_operation : mp_false_operation); + } + mp->cur_exp.type = mp_boolean_type; + DONE: + /* ignore overflow in comparisons */ + mp->arith_error = 0; + break; + case mp_and_operation: + case mp_or_operation: + /* Here we use the sneaky fact that |and_op-false_code=or_op-true_code| */ + if ((mp_type(p) != mp_boolean_type) || (mp->cur_exp.type != mp_boolean_type)) { + mp_bad_binary(mp, p, (int) c); + } else if (number_to_boolean(p->data.n) == c + mp_false_operation - mp_and_operation) { + mp_set_cur_exp_value_boolean(mp, number_to_boolean(p->data.n)); + } + break; + case mp_times_operation: + if ((mp->cur_exp.type < mp_color_type) || (mp_type(p) < mp_color_type)) { + mp_bad_binary(mp, p, mp_times_operation); + } else if ((mp->cur_exp.type == mp_known_type) || (mp_type(p) == mp_known_type)) { + /* Multiply when at least one operand is known */ + mp_number vv; + new_fraction(vv); + if (mp_type(p) == mp_known_type) { + number_clone(vv, mp_get_value_number(p)); + mp_free_value_node(mp, p); + } else { + number_clone(vv, cur_exp_value_number); + mp_unstash_cur_exp(mp, p); + } + switch (mp->cur_exp.type) { + case mp_known_type: + { + mp_number ret; + new_number(ret); + take_scaled(ret, cur_exp_value_number, vv); + mp_set_cur_exp_value_number(mp, &ret); + free_number(ret); + } + break; + case mp_pair_type: + { + mp_dep_mult(mp, (mp_value_node) mp_x_part(mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_y_part(mp_get_value_node(cur_exp_node)), &vv, 1); + } + break; + case mp_color_type: + { + mp_dep_mult(mp, (mp_value_node) mp_red_part (mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_green_part(mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_blue_part (mp_get_value_node(cur_exp_node)), &vv, 1); + } + break; + case mp_cmykcolor_type: + { + mp_dep_mult(mp, (mp_value_node) mp_cyan_part (mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_magenta_part(mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_yellow_part (mp_get_value_node(cur_exp_node)), &vv, 1); + mp_dep_mult(mp, (mp_value_node) mp_black_part (mp_get_value_node(cur_exp_node)), &vv, 1); + } + break; + default: + { + mp_dep_mult(mp, NULL, &vv, 1); + } + break; + } + free_number(vv); + mp_finish_binary(mp, old_p, old_exp); + return; + } else if ((mp_nice_color_or_pair(mp, p, mp_type(p)) && (mp->cur_exp.type > mp_pair_type)) + || (mp_nice_color_or_pair(mp, cur_exp_node, mp->cur_exp.type) && (mp_type(p) > mp_pair_type))) { + mp_hard_times(mp, p); + mp_finish_binary(mp, old_p, old_exp); + return; + } else { + mp_bad_binary(mp, p, mp_times_operation); + } + break; + case mp_over_operation: + if ((mp->cur_exp.type != mp_known_type) || (mp_type(p) < mp_color_type)) { + mp_bad_binary(mp, p, mp_over_operation); + } else { + mp_number v_n; + new_number_clone(v_n, cur_exp_value_number); + mp_unstash_cur_exp(mp, p); + if (number_zero(v_n)) { + /* Squeal about division by zero */ + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Division by zero", + "You're trying to divide the quantity shown above the error message by zero. I'm\n" + "going to divide it by one instead." + ); + mp_get_x_next(mp); + } else { + switch (mp->cur_exp.type) { + case mp_known_type: + { + mp_number ret; + new_number(ret); + make_scaled(ret, cur_exp_value_number, v_n); + mp_set_cur_exp_value_number(mp, &ret); + free_number(ret); + } + break; + case mp_pair_type: + { + mp_dep_div(mp, (mp_value_node) mp_x_part(mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_y_part(mp_get_value_node(cur_exp_node)), &v_n); + } + break; + case mp_color_type: + { + mp_dep_div(mp, (mp_value_node) mp_red_part (mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_green_part(mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_blue_part (mp_get_value_node(cur_exp_node)), &v_n); + } + break; + case mp_cmykcolor_type: + { + mp_dep_div(mp, (mp_value_node) mp_cyan_part (mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_magenta_part(mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_yellow_part (mp_get_value_node(cur_exp_node)), &v_n); + mp_dep_div(mp, (mp_value_node) mp_black_part (mp_get_value_node(cur_exp_node)), &v_n); + } + break; + default: + { + mp_dep_div(mp, NULL, &v_n); + } + break; + } + } + free_number(v_n); + mp_finish_binary(mp, old_p, old_exp); + return; + } + break; + case mp_power_operation: + if ((mp->cur_exp.type == mp_known_type) && (mp_type(p) == mp_known_type)) { + mp_number r; + new_number(r); + power_of(r, mp_get_value_number(p), cur_exp_value_number); + check_arith(); + mp_set_cur_exp_value_number(mp, &r); + free_number(r); + } else + mp_bad_binary(mp, p, (int) c); + break; + case mp_pythag_add_operation: + case mp_pythag_sub_operation: + if ((mp->cur_exp.type == mp_known_type) && (mp_type(p) == mp_known_type)) { + mp_number r; + new_number(r); + if (c == mp_pythag_add_operation) { + pyth_add(r, mp_get_value_number(p), cur_exp_value_number); + } else { + pyth_sub(r, mp_get_value_number(p), cur_exp_value_number); + } + mp_set_cur_exp_value_number(mp, &r); + free_number(r); + } else + mp_bad_binary(mp, p, (int) c); + break; + case mp_rotated_operation: + case mp_slanted_operation: + case mp_scaled_operation: + case mp_shifted_operation: + case mp_transformed_operation: + case mp_x_scaled_operation: + case mp_y_scaled_operation: + case mp_z_scaled_operation: + /* + The next few sections of the program deal with affine transformations + of coordinate data. + */ + switch (mp_type(p)) { + case mp_path_type: + mp_set_up_known_trans(mp, (int) c); + mp_unstash_cur_exp(mp, p); + mp_do_path_trans(mp, cur_exp_knot); + mp_finish_binary(mp, old_p, old_exp); + return; + case mp_pen_type: + mp_set_up_known_trans(mp, (int) c); + mp_unstash_cur_exp(mp, p); + mp_do_pen_trans(mp, cur_exp_knot); + /* rounding error could destroy convexity */ + mp_set_cur_exp_knot(mp, mp_convex_hull(mp, cur_exp_knot)); + mp_finish_binary(mp, old_p, old_exp); + return; + case mp_nep_type: + mp_set_up_known_trans(mp, (int) c); + mp_unstash_cur_exp(mp, p); + mp_do_pen_trans(mp, cur_exp_knot); + mp_set_cur_exp_knot(mp, cur_exp_knot); + mp_finish_binary(mp, old_p, old_exp); + return; + case mp_pair_type: + case mp_transform_type: + mp_big_trans(mp, p, (int) c); + break; + case mp_picture_type: + mp_do_edges_trans(mp, p, (int) c); + mp_finish_binary(mp, old_p, old_exp); + return; + default: + mp_bad_binary(mp, p, (int) c); + break; + } + break; + case mp_concatenate_operation: + case mp_just_append_operation: + if ((mp->cur_exp.type == mp_string_type) && (mp_type(p) == mp_string_type)) { + mp_string str = mp_cat(mp, mp_get_value_str(p), cur_exp_str); + delete_str_ref(cur_exp_str) ; + mp_set_cur_exp_str(mp, str); + } else { + mp_bad_binary(mp, p, c); + } + break; + case mp_substring_operation: + if (mp_nice_pair(mp, p, mp_type(p)) && (mp->cur_exp.type == mp_string_type)) { + mp_string str = mp_chop_string (mp, + cur_exp_str, + round_unscaled(mp_get_value_number(mp_x_part(mp_get_value_node(p)))), + round_unscaled(mp_get_value_number(mp_y_part(mp_get_value_node(p)))) + ); + delete_str_ref(cur_exp_str) ; + mp_set_cur_exp_str(mp, str); + } else { + mp_bad_binary(mp, p, mp_substring_operation); + } + break; + case mp_subpath_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if (mp_nice_pair(mp, p, mp_type(p)) && (mp->cur_exp.type == mp_path_type)) { + mp_chop_path(mp, mp_get_value_node(p)); + } else { + mp_bad_binary(mp, p, mp_subpath_operation); + } + break; + case mp_point_operation: + case mp_precontrol_operation: + case mp_postcontrol_operation: + case mp_direction_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && (mp_type(p) == mp_known_type)) { + mp_find_point(mp, &(mp_get_value_number(p)), (int) c); + } else { + mp_bad_binary(mp, p, c); + } + break; + case mp_pen_offset_operation: + if ((mp->cur_exp.type == mp_pen_type || mp->cur_exp.type == mp_nep_type) && mp_nice_pair(mp, p, mp_type(p))) { + mp_set_up_offset(mp, mp_get_value_node(p)); + } else { + mp_bad_binary(mp, p, mp_pen_offset_operation); + } + break; + case mp_direction_time_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && mp_nice_pair(mp, p, mp_type(p))) { + mp_set_up_direction_time(mp, mp_get_value_node(p)); + } else { + mp_bad_binary(mp, p, mp_direction_time_operation); + } + break; + case mp_envelope_operation: + if ((mp_type(p) != mp_pen_type && mp_type(p) != mp_nep_type) || (mp->cur_exp.type != mp_path_type)) { + mp_bad_binary(mp, p, mp_envelope_operation); + } else { + mp_set_up_envelope(mp, p); + } + break; + case mp_boundingpath_operation: + if ((mp_type(p) != mp_pen_type && mp_type(p) != mp_nep_type) || (mp->cur_exp.type != mp_path_type)) { + mp_bad_binary(mp, p, mp_boundingpath_operation); + } else { + mp_set_up_boundingpath(mp, p); + } + break; + case mp_arc_time_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && (mp_type(p) == mp_known_type)) { + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_arc_time(mp, &new_expr.data.n, cur_exp_knot, &(mp_get_value_number(p)), 0); + mp_flush_cur_exp(mp, new_expr); + } else { + mp_bad_binary(mp, p, (int) c); + } + break; + case mp_arc_point_operation: + /* todo: make a function */ + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && (mp_type(p) == mp_known_type || mp_type(p) == mp_pair_type)) { + mp_knot k; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (mp_type(p) == mp_pair_type) { + mp_knot f = cur_exp_knot; + mp_node q = mp_get_value_node(p); + mp_number x; + new_number_clone(x, mp_get_value_number(mp_x_part(q))); + if (number_greater(x, zero_t)) { + while (number_greater(x, zero_t)) { + f = mp_next_knot(f); + number_subtract(x, unity_t); + } + } else { + while (number_less(x, zero_t)) { + f = mp_next_knot(f); + number_add(x, unity_t); + } + } + k = mp_get_arc_time(mp, &new_expr.data.n, f, &(mp_get_value_number(mp_y_part(q))), 1); + free_number(x); + } else { + k = mp_get_arc_time(mp, &new_expr.data.n, cur_exp_knot, &(mp_get_value_number(p)), 1); + } + if (k) { + int toss = 0; + if (number_equal(new_expr.data.n, unity_t)) { + k = mp_next_knot(k); + } else if (! number_equal(new_expr.data.n, zero_t)) { + convert_scaled_to_fraction(new_expr.data.n); + k = mp_split_cubic_knot(mp, k, &new_expr.data.n); + toss = 1; + } + mp_pair_value(mp, &(k->x_coord), &(k->y_coord)); + if (toss) { + mp_toss_knot(mp, k); + } + } else { + mp_bad_unary(mp, mp_arc_point_operation); + } + } else { + mp_bad_unary(mp, mp_arc_point_operation); + } + break; + case mp_arc_point_list_operation: + /* todo: make a function */ + /* + vardef arcpoints_a(expr thepath, cnt) = + numeric len ; len := length thepath ; + numeric aln ; aln := arclength thepath ; + numeric seg ; seg := 0 ; + numeric tot ; tot := 0 ; + numeric tim ; tim := 0 ; + numeric stp ; stp := aln / cnt; + numeric acc ; acc := subarclength (0,1) of thepath ; + point 0 of thepath + for tot = stp step stp until aln : + hide( + forever : + exitif tot < acc ; + seg := seg + 1 ; + tim := acc ; + acc := acc + subarclength (seg,seg+1) of thepath ; + endfor ; + ) + -- (arcpoint (seg,tot-tim) of thepath) + endfor if cycle thepath : -- cycle fi + enddef ; + */ + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && mp_type(p) == mp_known_type) { + // we can consider using ints as we have discrete points + mp_knot cur = cur_exp_knot; + mp_number len, aln, seg, tot, tim, stp, acc, tmp; + mp_knot last = NULL; + mp_knot list = NULL; + int iscycle = mp_left_type(cur_exp_knot) == mp_explicit_knot; + new_number(len); + mp_path_length(mp, &len); + new_number(aln); + mp_get_arc_length(mp, &aln, cur_exp_knot); + new_number(seg); + new_number(tot); + new_number(tim); + new_number(stp); + set_number_from_div(stp, aln, mp_get_value_number(p)); + new_number(acc); + mp_get_subarc_length(mp, &acc, cur_exp_knot, &zero_t, &unity_t); + /* */ + new_number(tmp); + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + /* first point */ + list = mp_complex_knot(mp, cur_exp_knot); + mp_prev_knot(list) = list; + mp_next_knot(list) = list; + last = list; + /* second and following points */ + number_clone(tot, stp); + while (number_lessequal(tot, aln)) { + mp_knot k; + while (1) { + if (number_lessequal(tot, acc)) { + break; + } else { + number_add(seg, unity_t); + number_clone(tim, acc); + cur = mp_next_knot(cur); + mp_get_subarc_length(mp, &tmp, cur, &zero_t, &unity_t); + number_add(acc, tmp) ; + } + } + /* still from the start, can be improved with offset */ + number_clone(tmp, tot); + number_subtract(tmp, tim); + k = mp_get_arc_time(mp, &new_expr.data.n, cur, &tmp, 1); + /* */ + if (k) { + int toss = 0; + mp_knot kk; + if (number_equal(new_expr.data.n, unity_t)) { + k = mp_next_knot(k); + } else if (! number_equal(new_expr.data.n, zero_t)) { + convert_scaled_to_fraction(new_expr.data.n); + k = mp_split_cubic_knot(mp, k, &new_expr.data.n); + toss = 1; + } + kk = mp_complex_knot(mp, k); + mp_prev_knot(list) = kk; + mp_next_knot(kk) = list; + mp_prev_knot(kk) = last; + mp_next_knot(last) = kk; + last = kk; + if (toss) { + mp_toss_knot(mp, k); + } + number_add(tot, stp); + } else { + break; + } + } + + free_number(len); + free_number(aln); + free_number(seg); + free_number(tot); + free_number(tim); + free_number(stp); + free_number(acc); + free_number(tmp); + if (list) { + if (iscycle) { + mp_left_type(list) = mp_explicit_knot; + mp_right_type(last) = mp_explicit_knot; + } else { + mp_left_type(list) = mp_endpoint_knot; + mp_right_type(last) = mp_endpoint_knot; + } + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, list); + } else { + mp_bad_unary(mp, mp_arc_point_list_operation); + } + } else { + mp_bad_unary(mp, mp_arc_point_list_operation); + } + break; + case mp_subarc_length_operation: + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && mp_type(p) == mp_pair_type) { + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_node q = mp_get_value_node(p); + mp_get_subarc_length(mp, &new_expr.data.n, cur_exp_knot, &(mp_get_value_number(mp_x_part(q))), &(mp_get_value_number(mp_y_part(q)))); + mp_flush_cur_exp(mp, new_expr); + } else { + mp_bad_unary(mp, mp_subarc_length_operation); + } + break; + case mp_intertimes_operation: + case mp_intertimes_list_operation: + if (mp_type(p) == mp_pair_type) { + mp_node q = mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, p); + mp_pair_to_path(mp); + p = mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, q); + } + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if ((mp->cur_exp.type == mp_path_type) && (mp_type(p) == mp_path_type)) { + if (c == mp_intertimes_operation) { + // mp_number arg1, arg2; + // mp_path_intersection(mp, mp_get_value_knot(p), cur_exp_knot, 0, NULL); + // new_number_clone(arg1, mp->cur_t); + // new_number_clone(arg2, mp->cur_tt); + // mp_pair_value(mp, &arg1, &arg2); + // free_number(arg1); + // free_number(arg2); + mp_path_intersection(mp, mp_get_value_knot(p), cur_exp_knot, 0, NULL); + mp_pair_value(mp, &mp->cur_t, &mp->cur_tt); + } else { + mp_knot last = NULL; + mp_knot list = mp_path_intersection(mp, mp_get_value_knot(p), cur_exp_knot, 1, &last); + mp_left_type(list) = mp_endpoint_knot; + mp_right_type(last) = mp_endpoint_knot; + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, list); + } + } else { + mp_bad_binary(mp, p, c); + } + break; + } + mp_recycle_value(mp, p); + mp_free_value_node(mp, p); /* |return| to avoid this */ + mp_finish_binary(mp, old_p, old_exp); +} + +@ @<Declare binary action...@>= +static void mp_bad_binary (MP mp, mp_node p, int c) +{ + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + if (c >= mp_min_of_operation) { + mp_print_op(mp, c); + } + mp_print_known_or_unknown_type(mp, mp_type(p), p); + if (c >= mp_min_of_operation) { + mp_print_str(mp, "of"); + } else { + mp_print_op(mp, c); + } + mp_print_known_or_unknown_type(mp, mp->cur_exp.type, cur_exp_node); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Not implemented: %s", mp_str(mp, sname)); + @.Not implemented...@> + delete_str_ref(sname); + mp_disp_err(mp, p); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + msg, + "I'm afraid I don't know how to apply that operation to that combination of types.\n" + "Continue, and I'll return the second argument (see above) as the result of the" + "operation." + ); + mp_get_x_next(mp); +} + +static void mp_bad_envelope_pen (MP mp) +{ + mp_disp_err(mp, NULL); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Not implemented: 'envelope(elliptical pen) of (path)'", + "I'm afraid I don't know how to apply that operation to that combination of types.\n" + "Continue, and I'll return the second argument (see above) as the result of the\n" + "operation." + ); + @.Not implemented...@> + mp_get_x_next(mp); +} + +@ @<Declare binary action...@>= +static mp_node mp_tarnished (MP mp, mp_node p) +{ + mp_node q = mp_get_value_node(p); + (void) mp; + switch (mp_type(p)) { + case mp_pair_type: + return ( + (mp_type(mp_x_part(q)) == mp_independent_type) || + (mp_type(mp_y_part(q)) == mp_independent_type) + ) ? MP_VOID : NULL; + case mp_color_type: + return ( + (mp_type(mp_red_part(q)) == mp_independent_type) || + (mp_type(mp_green_part(q)) == mp_independent_type) || + (mp_type(mp_blue_part(q)) == mp_independent_type) + ) ? MP_VOID : NULL; + case mp_cmykcolor_type: + return ( + (mp_type(mp_cyan_part(q)) == mp_independent_type) || + (mp_type(mp_magenta_part(q)) == mp_independent_type) || + (mp_type(mp_yellow_part(q)) == mp_independent_type) || + (mp_type(mp_black_part(q)) == mp_independent_type) + ) ? MP_VOID : NULL; + case mp_transform_type: + return ( + (mp_type(mp_tx_part(q)) == mp_independent_type) || + (mp_type(mp_ty_part(q)) == mp_independent_type) || + (mp_type(mp_xx_part(q)) == mp_independent_type) || + (mp_type(mp_xy_part(q)) == mp_independent_type) || + (mp_type(mp_yx_part(q)) == mp_independent_type) || + (mp_type(mp_yy_part(q)) == mp_independent_type) + ) ? MP_VOID : NULL; + default: + return NULL; + } +} + +@ The first argument to |add_or_subtract| is the location of a value node in a +capsule or pair node that will soon be recycled. The second argument is either a +location within a pair or transform node of |cur_exp|, or it is NULL (which means +that |cur_exp| itself should be the second argument). The third argument is +either |plus| or |minus|. + +The sum or difference of the numeric quantities will replace the second operand. +Arithmetic overflow may go undetected; users aren't supposed to be monkeying +around with really big values. @^overflow in arithmetic@> + +@<Declare binary action...@>= +@<Declare the procedure called |dep_finish|@> +static void mp_add_or_subtract (MP mp, mp_node p, mp_node q, int c) +{ + mp_variable_type s, t; /* operand types */ + mp_value_node r; /* dependency list traverser */ + mp_value_node v = NULL; /* second operand value for dep lists */ + mp_number vv; /* second operand value for known values */ + new_number(vv); + if (q == NULL) { + t = mp->cur_exp.type; + if (t < mp_dependent_type) { + number_clone(vv, cur_exp_value_number); + } else { + v = (mp_value_node) mp_get_dep_list((mp_value_node) cur_exp_node); + } + } else { + t = mp_type(q); + if (t < mp_dependent_type) { + number_clone(vv, mp_get_value_number(q)); + } else { + v = (mp_value_node) mp_get_dep_list((mp_value_node) q); + } + } + if (t == mp_known_type) { + mp_value_node qq = (mp_value_node) q; + if (c == mp_minus_operation) { + number_negate(vv); + } + if (mp_type(p) == mp_known_type) { + slow_add(vv, mp_get_value_number(p), vv); + if (q == NULL) { + mp_set_cur_exp_value_number(mp, &vv); + } else { + mp_set_value_number(q, vv); + } + free_number(vv); + return; + } else { + /* Add a known value to the constant term of |mp_get_dep_list(p)| */ + r = (mp_value_node) mp_get_dep_list((mp_value_node) p); + while (mp_get_dep_info(r) != NULL) { + r = (mp_value_node) mp_link(r); + } + slow_add(vv, mp_get_dep_value(r), vv); + mp_set_dep_value(r, vv); + if (qq == NULL) { + qq = mp_get_dep_node(mp); + mp_set_cur_exp_node(mp, (mp_node) qq); + mp->cur_exp.type = mp_type(p); + mp_name_type(qq) = mp_capsule_operation; + /* clang: never read: |q = (mp_node) qq;| */ + } + mp_set_dep_list(qq, mp_get_dep_list((mp_value_node) p)); + mp_type(qq) = mp_type(p); + mp_set_prev_dep(qq, mp_get_prev_dep((mp_value_node) p)); + mp_link(mp_get_prev_dep((mp_value_node) p)) = (mp_node) qq; + mp_type(p) = mp_known_type; /* this will keep the recycler from collecting non-garbage */ + } + } else { + if (c == mp_minus_operation) { + mp_negate_dep_list(mp, v); + } + /* + Add operand |p| to the dependency list |v|. We prefer |dependent| lists to + |mp_proto_dependent| ones, because it is nice to retain the extra accuracy + of |fraction| coefficients. But we have to handle both kinds, and mixtures + too. + */ + if (mp_type(p) == mp_known_type) { + /* Add the known |value(p)| to the constant term of |v| */ + while (mp_get_dep_info(v) != NULL) { + v = (mp_value_node) mp_link(v); + } + slow_add(vv, mp_get_value_number(p), mp_get_dep_value(v)); + mp_set_dep_value(v, vv); + } else { + s = mp_type(p); + r = (mp_value_node) mp_get_dep_list((mp_value_node) p); + if (t == mp_dependent_type) { + if (s == mp_dependent_type) { + int b; + mp_number ret1, ret2; + new_fraction(ret1); + new_fraction(ret2); + mp_max_coef(mp, &ret1, r); + mp_max_coef(mp, &ret2, v); + number_add(ret1, ret2); + b = number_less(ret1, coef_bound_k); + free_number(ret1); + free_number(ret2); + if (b) { + v = mp_p_plus_q(mp, v, r, mp_dependent_type); + goto DONE; + } + } /* |fix_needed| will necessarily be false */ + t = mp_proto_dependent_type; + v = mp_p_over_v(mp, v, &unity_t, mp_dependent_type, mp_proto_dependent_type); + } + if (s == mp_proto_dependent_type) { + v = mp_p_plus_q(mp, v, r, mp_proto_dependent_type); + } else { + v = mp_p_plus_fq(mp, v, &unity_t, r, mp_proto_dependent_type, mp_dependent_type); + } + DONE: + /* Output the answer, |v| (which might have become |known|) */ + if (q != NULL) { + mp_dep_finish(mp, v, (mp_value_node) q, t); + } else { + mp->cur_exp.type = t; + mp_dep_finish(mp, v, NULL, t); + } + } + } + free_number(vv); +} + +@ Here's the current situation: The dependency list |v| of type |t| should either +be put into the current expression (if |q=NULL|) or into location |q| within a +pair node (otherwise). The destination (|cur_exp| or |q|) formerly held a +dependency list with the same final pointer as the list |v|. + +@<Declare the procedure called |dep_finish|@>= +static void mp_dep_finish (MP mp, mp_value_node v, mp_value_node q, int t) +{ + mp_value_node p = (q == NULL) ? (mp_value_node) cur_exp_node : q; /* the destination */ + mp_set_dep_list(p, v); + mp_type(p) = t; + if (mp_get_dep_info(v) == NULL) { + mp_number vv; /* the value, if it is |known| */ + new_number_clone(vv, mp_get_value_number(v)); + if (q == NULL) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number_clone(new_expr.data.n, vv); + mp_flush_cur_exp(mp, new_expr); + } else { + mp_recycle_value(mp, (mp_node) p); + mp_type(q) = mp_known_type; + mp_set_value_number(q, vv); + } + free_number(vv); + } else if (q == NULL) { + mp->cur_exp.type = t; + } + if (mp->fix_needed) { + mp_fix_dependencies(mp); + } +} + +@ @<Declare binary action...@>= +static void mp_dep_mult (MP mp, mp_value_node p, mp_number *v, int v_is_scaled) +{ + mp_value_node q; /* the dependency list being multiplied by |v| */ + int s, t; /* its type, before and after */ + if (p == NULL) { + q = (mp_value_node) cur_exp_node; + } else if (mp_type(p) != mp_known_type) { + q = p; + } else { + mp_number r1, arg1; + new_number_clone(arg1, mp_get_dep_value(p)); + if (v_is_scaled) { + new_number(r1); + take_scaled(r1, arg1, *v); + } else { + new_fraction(r1); + take_fraction(r1, arg1, *v); + } + mp_set_dep_value(p, r1); + free_number(r1); + free_number(arg1); + return; + } + t = mp_type(q); + q = (mp_value_node) mp_get_dep_list(q); + s = t; + if (t == mp_dependent_type && v_is_scaled) { + mp_number arg1, arg2; + new_fraction(arg1); + mp_max_coef(mp, &arg1, q); + new_number_abs(arg2, *v); + if (ab_vs_cd(arg1, arg2, coef_bound_minus_1, unity_t) >= 0) { + t = mp_proto_dependent_type; + } + free_number(arg1); + free_number(arg2); + } + q = mp_p_times_v(mp, q, v, s, t, v_is_scaled); + mp_dep_finish(mp, q, p, t); +} + +@ Here is a routine that is similar to |times|; but it is invoked only +internally, when |v| is a |fraction| whose magnitude is at most~1, and when +|cur_type >= mp_color_type|. + +@c +static void mp_frac_mult (MP mp, mp_number *n, mp_number *d) +{ + /* multiplies |cur_exp| by |n/d| */ + mp_node old_exp; /* a capsule to recycle */ + mp_number v; /* |n/d| */ + new_fraction(v); + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + @<Trace the fraction multiplication@> + } + switch (mp->cur_exp.type) { + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + old_exp = mp_tarnished(mp, cur_exp_node); + break; + case mp_independent_type: + old_exp = MP_VOID; + break; + default: + old_exp = NULL; + break; + } + if (old_exp != NULL) { + old_exp = cur_exp_node; + mp_make_exp_copy(mp, old_exp); + } + make_fraction(v, *n, *d); + switch (mp->cur_exp.type) { + case mp_known_type: + { + mp_number r1, arg1; + new_fraction(r1); + new_number_clone(arg1, cur_exp_value_number); + take_fraction(r1, arg1, v); + mp_set_cur_exp_value_number(mp, &r1); + free_number(r1); + free_number(arg1); + } + break; + case mp_pair_type: + { + mp_dep_mult(mp, (mp_value_node) mp_x_part(mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_y_part(mp_get_value_node(cur_exp_node)), &v, 0); + } + break; + case mp_color_type: + { + mp_dep_mult(mp, (mp_value_node) mp_red_part (mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_green_part(mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_blue_part (mp_get_value_node(cur_exp_node)), &v, 0); + } + break; + case mp_cmykcolor_type: + { + mp_dep_mult(mp, (mp_value_node) mp_cyan_part (mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_magenta_part(mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_yellow_part (mp_get_value_node(cur_exp_node)), &v, 0); + mp_dep_mult(mp, (mp_value_node) mp_black_part (mp_get_value_node(cur_exp_node)), &v, 0); + } + break; + default: + { + mp_dep_mult(mp, NULL, &v, 0); + } + break; + } + if (old_exp != NULL) { + mp_recycle_value(mp, old_exp); + mp_free_value_node(mp, old_exp); + } + free_number(v); +} + +@ @<Trace the fraction multiplication@>= +mp_begin_diagnostic(mp); +mp_print_nl(mp, "{("); +print_number(*n); +mp_print_chr(mp, '/'); +print_number(*d); +mp_print_str(mp, ")*("); +mp_print_exp(mp, NULL, 0); +mp_print_str(mp, ")}"); +mp_end_diagnostic(mp, 0); + +@ The |hard_times| routine multiplies a nice color or pair by a dependency list. + +@<Declare binary action procedures@>= +static void mp_hard_times (MP mp, mp_node p) +{ + mp_value_node q; /* a copy of the dependent variable |p| */ + mp_value_node pp; /* for typecasting p */ + mp_number v; /* the known value for |r| */ + new_number(v); + if (mp_type(p) <= mp_pair_type) { + q = (mp_value_node) mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, p); + p = (mp_node) q; + } + /* now |cur_type=mp_pair_type| or |cur_type=mp_color_type| or |cur_type=mp_cmykcolor_type| */ + pp = (mp_value_node) p; + switch (mp->cur_exp.type) { + case mp_pair_type: + { + mp_node r = mp_x_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_y_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + } + break; + case mp_color_type: + { + mp_node r = mp_red_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_green_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_blue_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + } + break; + case mp_cmykcolor_type: + { + mp_node r = mp_cyan_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_yellow_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_magenta_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + r = mp_black_part(mp_get_value_node(cur_exp_node)); + number_clone(v, mp_get_value_number(r)); + mp_new_dep(mp, r, mp_type(pp), mp_copy_dep_list(mp, (mp_value_node) mp_get_dep_list(pp))); + mp_dep_mult(mp, (mp_value_node) r, &v, 1); + } + break; + default: + break; + } + free_number(v); +} + +@ @<Declare binary action...@>= +static void mp_dep_div (MP mp, mp_value_node p, mp_number *v) +{ + mp_value_node q; /* the dependency list being divided by |v| */ + int s, t; /* its type, before and after */ + if (p == NULL) { + q = (mp_value_node) cur_exp_node; + } else if (mp_type(p) != mp_known_type) { + q = p; + } else { + mp_number ret; + new_number(ret); + make_scaled(ret, mp_get_value_number(p), *v); + mp_set_value_number(p, ret); + free_number(ret); + return; + } + t = mp_type(q); + q = (mp_value_node) mp_get_dep_list(q); + s = t; + if (t == mp_dependent_type) { + mp_number arg1, arg2; + new_number(arg2); + new_fraction(arg1); + mp_max_coef(mp, &arg1, q); + number_abs_clone(arg2, *v); + if (ab_vs_cd(arg1, unity_t, coef_bound_minus_1, arg2) >= 0) { + t = mp_proto_dependent_type; + } + free_number(arg1); + free_number(arg2); + } + q = mp_p_over_v(mp, q, v, s, t); + mp_dep_finish(mp, q, p, t); +} + +@ Let |c| be one of the eight transform operators. The procedure call +|set_up_trans(c)| first changes |cur_exp| to a transform that corresponds to |c| +and the original value of |cur_exp|. (In particular, |cur_exp| doesn't change at +all if |c=transformed_by|.) + +Then, if all components of the resulting transform are |known|, they are moved to +the global variables |txx|, |txy|, |tyx|, |tyy|, |tx|, |ty|; and |cur_exp| is +changed to the known value zero. + +@<Declare binary action...@>= +static void mp_set_up_trans (MP mp, int c) +{ + mp_node p, q, r; /* list manipulation registers */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + if ((c != mp_transformed_operation) || (mp->cur_exp.type != mp_transform_type)) { + /* Put the current transform into |cur_exp| */ + p = mp_stash_cur_exp(mp); + mp_set_cur_exp_node(mp, mp_id_transform(mp)); + mp->cur_exp.type = mp_transform_type; + q = mp_get_value_node(cur_exp_node); + @<For each of the eight cases, change the relevant fields of |cur_exp| and |goto done|; but do nothing if capsule |p| doesn't have the appropriate type@> + mp_disp_err(mp, p); + mp_back_error( + mp, + "Improper transformation argument", + "The expression shown above has the wrong type, so I can't transform anything\n" + "using it. Proceed, and I'll omit the transformation." + ); + mp_get_x_next(mp); + DONE: + mp_recycle_value(mp, p); + mp_free_value_node(mp, p); + } + /* + If the current transform is entirely known, stash it in global variables; + otherwise |return| + */ + q = mp_get_value_node(cur_exp_node); + if ( (mp_type(mp_tx_part(q)) == mp_known_type) && + (mp_type(mp_ty_part(q)) == mp_known_type) && + (mp_type(mp_xx_part(q)) == mp_known_type) && + (mp_type(mp_xy_part(q)) == mp_known_type) && + (mp_type(mp_yx_part(q)) == mp_known_type) && + (mp_type(mp_yy_part(q)) == mp_known_type) ) { + number_clone(mp->txx, mp_get_value_number(mp_xx_part(q))); + number_clone(mp->txy, mp_get_value_number(mp_xy_part(q))); + number_clone(mp->tyx, mp_get_value_number(mp_yx_part(q))); + number_clone(mp->tyy, mp_get_value_number(mp_yy_part(q))); + number_clone(mp->tx, mp_get_value_number(mp_tx_part(q))); + number_clone(mp->ty, mp_get_value_number(mp_ty_part(q))); + new_number(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); + } +} + +@ @<Glob...@>= +mp_number txx; +mp_number txy; +mp_number tyx; +mp_number tyy; +mp_number tx; +mp_number ty; /* current transform coefficients */ + +@ @<Initialize table...@>= +new_number(mp->txx); +new_number(mp->txy); +new_number(mp->tyx); +new_number(mp->tyy); +new_number(mp->tx); +new_number(mp->ty); + +@ @<Free table...@>= +free_number(mp->txx); +free_number(mp->txy); +free_number(mp->tyx); +free_number(mp->tyy); +free_number(mp->tx); +free_number(mp->ty); + +@ @<For each of the eight cases...@>= +switch (c) { + case mp_rotated_operation: + if (mp_type(p) == mp_known_type) { + @<Install sines and cosines, then |goto done|@> + } + break; + case mp_slanted_operation: + if (mp_type(p) > mp_pair_type) { + mp_install(mp, mp_xy_part(q), p); + goto DONE; + } + break; + case mp_scaled_operation: + if (mp_type(p) > mp_pair_type) { + mp_install(mp, mp_xx_part(q), p); + mp_install(mp, mp_yy_part(q), p); + goto DONE; + } + break; + case mp_shifted_operation: + if (mp_type(p) == mp_pair_type) { + r = mp_get_value_node(p); + mp_install(mp, mp_tx_part(q), mp_x_part(r)); + mp_install(mp, mp_ty_part(q), mp_y_part(r)); + goto DONE; + } + break; + case mp_x_scaled_operation: + if (mp_type(p) > mp_pair_type) { + mp_install(mp, mp_xx_part(q), p); + goto DONE; + } + break; + case mp_y_scaled_operation: + if (mp_type(p) > mp_pair_type) { + mp_install(mp, mp_yy_part(q), p); + goto DONE; + } + break; + case mp_z_scaled_operation: + if (mp_type(p) == mp_pair_type) { + @<Install a complex multiplier, then |goto done|@> + } + break; + case mp_transformed_operation: + break; +} + +@ @<Install sines and cosines, then |goto done|@>= +mp_number n_sin, n_cos, arg1, arg2; +new_fraction(n_sin); +new_fraction(n_cos); /* results computed by |n_sin_cos| */ +new_number_clone(arg2, unity_t); +new_number_clone(arg1, mp_get_value_number(p)); +number_multiply_int(arg2, 360); +number_modulo(arg1, arg2); +convert_scaled_to_angle(arg1); +n_sin_cos(arg1, n_cos, n_sin); +fraction_to_round_scaled(n_sin); +fraction_to_round_scaled(n_cos); +mp_set_value_number(mp_xx_part(q), n_cos); +mp_set_value_number(mp_yx_part(q), n_sin); +mp_set_value_number(mp_xy_part(q), mp_get_value_number(mp_yx_part(q))); +number_negate(mp_get_value_number(mp_xy_part(q))); +mp_set_value_number(mp_yy_part(q), mp_get_value_number(mp_xx_part(q))); +free_number(arg1); +free_number(arg2); +free_number(n_sin); +free_number(n_cos); +goto DONE; + +@ @<Install a complex multiplier, then |goto done|@>= +{ + r = mp_get_value_node(p); + mp_install(mp, mp_xx_part(q), mp_x_part(r)); + mp_install(mp, mp_yy_part(q), mp_x_part(r)); + mp_install(mp, mp_yx_part(q), mp_y_part(r)); + if (mp_type(mp_y_part(r)) == mp_known_type) { + mp_set_value_number(mp_y_part(r), mp_get_value_number(mp_y_part(r))); + number_negate(mp_get_value_number(mp_y_part(r))); + } else { + mp_negate_dep_list(mp, (mp_value_node) mp_get_dep_list((mp_value_node) mp_y_part(r))); + } + mp_install(mp, mp_xy_part(q), mp_y_part(r)); + goto DONE; +} + +@ Procedure |set_up_known_trans| is like |set_up_trans|, but it +insists that the transformation be entirely known. + +@<Declare binary action...@>= +static void mp_set_up_known_trans (MP mp, int c) +{ + mp_set_up_trans(mp, c); + if (mp->cur_exp.type != mp_known_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Transform components aren't all known", + "I'm unable to apply a partially specified transformation except to a fully known\n" + "pair or transform. Proceed, and I'll omit the transformation." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + set_number_to_unity(mp->txx); + set_number_to_zero(mp->txy); + set_number_to_zero(mp->tyx); + set_number_to_unity(mp->tyy); + set_number_to_zero(mp->tx); + set_number_to_zero(mp->ty); + } +} + +@ Here's a procedure that applies the transform |txx..ty| to a pair of +coordinates in locations |p| and~|q|. + +@<Declare binary action...@>= +static void mp_number_trans (MP mp, mp_number *p, mp_number *q) +{ + mp_number r1, r2, v; + new_number(r1); + new_number(r2); + new_number(v); + take_scaled(r1, *p, mp->txx); + take_scaled(r2, *q, mp->txy); + number_add(r1, r2); + set_number_from_addition(v, r1, mp->tx); + take_scaled(r1, *p, mp->tyx); + take_scaled(r2, *q, mp->tyy); + number_add(r1, r2); + set_number_from_addition(*q, r1, mp->ty); + number_clone(*p,v); + free_number(r1); + free_number(r2); + free_number(v); +} + +@ The simplest transformation procedure applies a transform to all +coordinates of a path. The |path_trans(c)(p)| macro applies +a transformation defined by |cur_exp| and the transform operator |c| +to the path~|p|. The macro was used only once and has been inlined. + +@<Declare binary action...@>= +static void mp_do_path_trans (MP mp, mp_knot p) +{ + mp_knot q = p; + do { + if (mp_left_type(q) != mp_endpoint_knot) { + mp_number_trans(mp, &q->left_x, &q->left_y); + } + mp_number_trans(mp, &q->x_coord, &q->y_coord); + if (mp_right_type(q) != mp_endpoint_knot) { + mp_number_trans(mp, &q->right_x, &q->right_y); + } + q = mp_next_knot(q); + } while (q != p); +} + +@ Transforming a pen is very similar, except that there are no |mp_left_type| +and |mp_right_type| fields. + +@<Declare binary action...@>= +static void mp_do_pen_trans (MP mp, mp_knot p) +{ + mp_knot q = p; /* list traverser */ + if (mp_pen_is_elliptical(p)) { + mp_number_trans(mp, &p->left_x, &p->left_y); + mp_number_trans(mp, &p->right_x, &p->right_y); + } + do { + mp_number_trans(mp, &q->x_coord, &q->y_coord); + q = mp_next_knot(q); + } while (q != p); +} + +@ Note that the shift parameters |(tx,ty)| apply only to the path being stroked. +The |dashscale| has to be adjusted to scale the dash lengths in |mp_dash_ptr(q)| +since the \ps\ output procedures will try to compensate for the transformation we +are applying to |mp_pen_ptr(q)|. Since this compensation is based on the square +root of the determinant, |sqdet| is the appropriate factor. + +@<Declare binary action...@>= +static void mp_do_path_pen_trans (MP mp, mp_shape_node p, mp_number *sqdet, int sgndet) +{ + mp_number sx, sy; + if (mp_pen_ptr(p) != NULL) { + new_number_clone(sx, mp->tx); + new_number_clone(sy, mp->ty); + set_number_to_zero(mp->tx); + set_number_to_zero(mp->ty); + mp_do_pen_trans(mp, mp_pen_ptr(p)); + if (number_nonzero(*sqdet) && ((mp_type(p) == mp_stroked_node_type) && (mp_dash_ptr(p) != NULL))) { + mp_number ret; + new_number(ret); + take_scaled(ret, ((mp_shape_node) p)->dashscale, *sqdet); + number_clone(((mp_shape_node) p)->dashscale, ret); + free_number(ret); + } + if (! mp_pen_is_elliptical(mp_pen_ptr(p)) && sgndet < 0) { + mp_pen_ptr(p) = mp_make_pen(mp, mp_copy_path(mp, mp_pen_ptr(p)), 1); + } + number_clone(mp->tx, sx); + number_clone(mp->ty, sy); + free_number(sx); + free_number(sy); + } +} + +@ The next transformation procedure applies to edge structures. It will do any +transformation, but the results may be substandard if the picture contains text +that uses downloaded bitmap fonts. The binary action procedure is +|do_edges_trans|, but we also need a function that just scales a picture. That +routine is |scale_edges|. Both it and the underlying routine |edges_trans| should +be thought of as procedures that update an edge structure |h|, except that they +have to return a (possibly new) structure because of the need to call +|private_edges|. + +@<Declare binary action...@>= +static mp_edge_header_node mp_edges_trans (MP mp, mp_edge_header_node h) +{ + mp_node q; /* the object being transformed */ + mp_dash_node r, s; /* for list manipulation */ + mp_number sqdet; /* square root of determinant for |dashscale| */ + int sgndet; /* sign of the determinant */ + h = mp_private_edges(mp, h); + new_number(sqdet); + mp_sqrt_det(mp, &sqdet, &(mp->txx), &(mp->txy), &(mp->tyx), &(mp->tyy)); + sgndet = ab_vs_cd(mp->txx, mp->tyy, mp->txy, mp->tyx); + if (mp_get_dash_list(h) != mp->null_dash) { + @<Try to transform the dash list of |h|@> + } + @<Make the bounding box of |h| unknown if it can't be updated properly without scanning the whole structure@> + q = mp_link(mp_edge_list(h)); + while (q != NULL) { + @<Transform graphical object |q|@> + q = mp_link(q); + } + free_number(sqdet); + return h; +} + +static void mp_do_edges_trans (MP mp, mp_node p, int c) +{ + mp_set_up_known_trans (mp, c); + mp_set_value_node(p, (mp_node) mp_edges_trans(mp, (mp_edge_header_node) mp_get_value_node(p))); + mp_unstash_cur_exp(mp, p); +} + +static mp_edge_header_node mp_scale_edges (MP mp, mp_number *se_sf, mp_edge_header_node se_pic) +{ + number_clone(mp->txx, *se_sf); + number_clone(mp->tyy, *se_sf); + set_number_to_zero(mp->txy); + set_number_to_zero(mp->tyx); + set_number_to_zero(mp->tx); + set_number_to_zero(mp->ty); + return mp_edges_trans(mp, se_pic); +} + +@ @<Try to transform the dash list of |h|@>= +if (number_nonzero(mp->txy) || number_nonzero(mp->tyx) || number_nonzero(mp->ty) || number_nonequalabs(mp->txx, mp->tyy)) { + mp_flush_dash_list(mp, h); +} else { + mp_number abs_tyy, ret; + new_number(abs_tyy); + if (number_negative(mp->txx)) { + @<Reverse the dash list of |h|@> + } + @<Scale the dash list by |txx| and shift it by |tx|@> + number_abs_clone(abs_tyy, mp->tyy); + new_number(ret); + take_scaled(ret, h->dash_y, abs_tyy); + number_clone(h->dash_y, ret); + free_number(ret); + free_number(abs_tyy); +} + +@ @<Reverse the dash list of |h|@>= +{ + r = mp_get_dash_list(h); + mp_set_dash_list(h, mp->null_dash); + while (r != mp->null_dash) { + s = r; + r = (mp_dash_node) mp_link(r); + number_swap(s->start_x, s->stop_x ); + mp_link(s) = (mp_node) mp_get_dash_list(h); + mp_set_dash_list(h, s); + } +} + +@ @<Scale the dash list by |txx| and shift it by |tx|@>= +r = mp_get_dash_list(h); +{ + mp_number arg1; + new_number(arg1); + while (r != mp->null_dash) { + take_scaled(arg1, r->start_x, mp->txx); + set_number_from_addition(r->start_x, arg1, mp->tx); + take_scaled(arg1, r->stop_x, mp->txx); + set_number_from_addition(r->stop_x, arg1, mp->tx); + r = (mp_dash_node) mp_link(r); + } + free_number(arg1); +} + +@ @<Make the bounding box of |h| unknown if it can't be updated properly...@>= +if (number_zero(mp->txx) && number_zero(mp->tyy)) { + @<Swap the $x$ and $y$ parameters in the bounding box of |h|@> +} else if (number_nonzero(mp->txy) || number_nonzero(mp->tyx)) { + mp_init_bbox(mp, h); + goto DONE1; +} +if (number_lessequal(h->minx, h->maxx)) { + @<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift by |(tx,ty)|@> +} +DONE1: + +@ @<Swap the $x$ and $y$ parameters in the bounding box of |h|@>= +number_swap(h->minx, h->miny); +number_swap(h->maxx, h->maxy); + +@ The sum |txx+txy| is whichever of |txx| or |txy| is nonzero. The other sum +is similar. + +@<Scale the bounding box by |txx+txy| and |tyx+tyy|; then shift...@>= +mp_number tot, ret; +new_number(tot); +new_number(ret); +set_number_from_addition(tot,mp->txx,mp->txy); +take_scaled(ret, h->minx, tot); +set_number_from_addition(h->minx,ret, mp->tx); +take_scaled(ret, h->maxx, tot); +set_number_from_addition(h->maxx,ret, mp->tx); + +set_number_from_addition(tot,mp->tyx,mp->tyy); +take_scaled(ret, h->miny, tot); +set_number_from_addition(h->miny, ret, mp->ty); +take_scaled(ret, h->maxy, tot); +set_number_from_addition(h->maxy, ret, mp->ty); +set_number_from_addition(tot, mp->txx, mp->txy); +if (number_negative(tot)) { + number_swap(h->minx, h->maxx); +} +set_number_from_addition(tot, mp->tyx, mp->tyy); +if (number_negative(tot)) { + number_swap(h->miny, h->maxy); +} +free_number(ret); +free_number(tot); + +@ Now we ready for the main task of transforming the graphical objects in edge +structure~|h|. + +@<Transform graphical object |q|@>= +switch (mp_type(q)) { + case mp_fill_node_type: + case mp_stroked_node_type: + mp_do_path_trans(mp, mp_path_ptr((mp_shape_node) q)); + mp_do_path_pen_trans(mp, (mp_shape_node) q, &sqdet, sgndet); + break; + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + mp_do_path_trans(mp, mp_path_ptr((mp_start_node) q)); + break; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + break; + default: + break; +} + +@ The hard cases of transformation occur when big nodes are involved, and when +some of their components are unknown. + +@<Declare binary action...@>= +@<Declare subroutines needed by |big_trans|@> +static void mp_big_trans (MP mp, mp_node p, int c) +{ + mp_node q = mp_get_value_node(p); + if (mp_type(q) == mp_pair_node_type) { + if (mp_type(mp_x_part(q)) != mp_known_type || mp_type(mp_y_part(q)) != mp_known_type) { + goto UNKNOWN; + } + } else if (mp_type(mp_tx_part(q)) != mp_known_type || mp_type(mp_ty_part(q)) != mp_known_type || + mp_type(mp_xx_part(q)) != mp_known_type || mp_type(mp_xy_part(q)) != mp_known_type || + mp_type(mp_yx_part(q)) != mp_known_type || mp_type(mp_yy_part(q)) != mp_known_type) { + goto UNKNOWN; + } + { + @<Transform a known big node@> + return; + } + UNKNOWN: + { + @<Transform an unknown big node and |return|@> + return; + } +} + +@ @<Transform an unknown big node and |return|@>= +mp_node r; +mp_set_up_known_trans(mp, c); +mp_make_exp_copy(mp, p); +r = mp_get_value_node(cur_exp_node); +if (mp->cur_exp.type == mp_transform_type) { + mp_bilin1(mp, mp_yy_part(r), &(mp->tyy), mp_xy_part(q), &(mp->tyx), &zero_t); + mp_bilin1(mp, mp_yx_part(r), &(mp->tyy), mp_xx_part(q), &(mp->tyx), &zero_t); + mp_bilin1(mp, mp_xy_part(r), &(mp->txx), mp_yy_part(q), &(mp->txy), &zero_t); + mp_bilin1(mp, mp_xx_part(r), &(mp->txx), mp_yx_part(q), &(mp->txy), &zero_t); +} +mp_bilin1(mp, mp_y_part(r), &(mp->tyy), mp_x_part(q), &(mp->tyx), &(mp->ty)); +mp_bilin1(mp, mp_x_part(r), &(mp->txx), mp_y_part(q), &(mp->txy), &(mp->tx)); + +@ Let |p| point to a value field inside a big node of |cur_exp|, and let |q| +point to a another value field. The |bilin1| procedure replaces |p| by $p\cdot +t+q\cdot u+\delta$. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_bilin1 (MP mp, mp_node p, mp_number *t, mp_node q, mp_number *u, mp_number *delta_orig) +{ + mp_number delta; + new_number_clone(delta, *delta_orig); + if (! number_equal(*t, unity_t)) { + mp_dep_mult(mp, (mp_value_node) p, t, 1); + } + if (number_nonzero(*u)) { + if (mp_type(q) == mp_known_type) { + mp_number tmp; + new_number(tmp); + take_scaled(tmp, mp_get_value_number(q), *u); + number_add(delta, tmp); + free_number(tmp); + } else { + /* Ensure that |type(p)=mp_proto_dependent| */ + if (mp_type(p) != mp_proto_dependent_type) { + if (mp_type(p) == mp_known_type) { + mp_new_dep(mp, p, mp_type(p), mp_const_dependency(mp, &(mp_get_value_number(p)))); + } else { + mp_set_dep_list((mp_value_node) p, + mp_p_times_v(mp, + (mp_value_node) mp_get_dep_list((mp_value_node) p), &unity_t, + mp_dependent_type, mp_proto_dependent_type, 1)); + } + mp_type(p) = mp_proto_dependent_type; + } + mp_set_dep_list((mp_value_node) p, + mp_p_plus_fq(mp, + (mp_value_node) mp_get_dep_list((mp_value_node) p), u, + (mp_value_node) mp_get_dep_list((mp_value_node) q), + mp_proto_dependent_type, mp_type(q))); + } + } + if (mp_type(p) == mp_known_type) { + mp_set_value_number(p, mp_get_value_number(p)); + number_add(mp_get_value_number(p), delta); + } else { + mp_number tmp; + mp_value_node r = (mp_value_node) mp_get_dep_list((mp_value_node) p); + while (mp_get_dep_info(r) != NULL) { + r = (mp_value_node) mp_link(r); + } + new_number_clone(tmp, mp_get_value_number(r)); + number_add(delta, tmp); + // number_add(delta, mp_get_value_number(r)); + if (r != (mp_value_node) mp_get_dep_list((mp_value_node) p)) { + mp_set_value_number(r, delta); + } else { + mp_recycle_value(mp, p); + mp_type(p) = mp_known_type; + mp_set_value_number(p, delta); + } + free_number(tmp); + } + if (mp->fix_needed) { + mp_fix_dependencies(mp); + } + free_number(delta); +} + +@ @<Transform a known big node@>= +mp_node r, pp, qq; /* list manipulation registers */ +mp_set_up_trans(mp, c); +if (mp->cur_exp.type == mp_known_type) { + /* Transform known by known */ + mp_make_exp_copy(mp, p); + r = mp_get_value_node(cur_exp_node); + if (mp->cur_exp.type == mp_transform_type) { + mp_bilin3(mp, mp_yy_part(r), &(mp->tyy), &(mp_get_value_number(mp_xy_part(q))), &(mp->tyx), &zero_t); + mp_bilin3(mp, mp_yx_part(r), &(mp->tyy), &(mp_get_value_number(mp_xx_part(q))), &(mp->tyx), &zero_t); + mp_bilin3(mp, mp_xy_part(r), &(mp->txx), &(mp_get_value_number(mp_yy_part(q))), &(mp->txy), &zero_t); + mp_bilin3(mp, mp_xx_part(r), &(mp->txx), &(mp_get_value_number(mp_yx_part(q))), &(mp->txy), &zero_t); + } + mp_bilin3(mp, mp_y_part(r), &(mp->tyy), &(mp_get_value_number(mp_x_part(q))), &(mp->tyx), &(mp->ty)); + mp_bilin3(mp, mp_x_part(r), &(mp->txx), &(mp_get_value_number(mp_y_part(q))), &(mp->txy), &(mp->tx)); +} else { + pp = mp_stash_cur_exp(mp); + qq = mp_get_value_node(pp); + mp_make_exp_copy(mp, p); + r = mp_get_value_node(cur_exp_node); + if (mp->cur_exp.type == mp_transform_type) { + mp_bilin2(mp, mp_yy_part(r), mp_yy_part(qq), &(mp_get_value_number(mp_xy_part(q))), mp_yx_part(qq), NULL); + mp_bilin2(mp, mp_yx_part(r), mp_yy_part(qq), &(mp_get_value_number(mp_xx_part(q))), mp_yx_part(qq), NULL); + mp_bilin2(mp, mp_xy_part(r), mp_xx_part(qq), &(mp_get_value_number(mp_yy_part(q))), mp_xy_part(qq), NULL); + mp_bilin2(mp, mp_xx_part(r), mp_xx_part(qq), &(mp_get_value_number(mp_yx_part(q))), mp_xy_part(qq), NULL); + } + mp_bilin2(mp, mp_y_part(r), mp_yy_part(qq), &(mp_get_value_number(mp_x_part(q))), mp_yx_part(qq), mp_y_part(qq)); + mp_bilin2(mp, mp_x_part(r), mp_xx_part(qq), &(mp_get_value_number(mp_y_part(q))), mp_xy_part(qq), mp_x_part(qq)); + mp_recycle_value(mp, pp); + mp_free_value_node(mp, pp); +} + +@ Let |p| be a |mp_proto_dependent| value whose dependency list ends at +|dep_final|. The following procedure adds |v| times another numeric quantity +to~|p|. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_add_mult_dep (MP mp, mp_value_node p, mp_number *v, mp_node r) +{ + if (mp_type(r) == mp_known_type) { + mp_number ret; + new_number(ret); + take_scaled(ret, mp_get_value_number(r), *v); + mp_set_dep_value(mp->dep_final, mp_get_dep_value(mp->dep_final)); + number_add(mp_get_dep_value(mp->dep_final), ret); + free_number(ret); + } else { + mp_set_dep_list(p, mp_p_plus_fq(mp, (mp_value_node) mp_get_dep_list(p), v, (mp_value_node) mp_get_dep_list((mp_value_node) r), mp_proto_dependent_type, mp_type(r))); + if (mp->fix_needed) { + mp_fix_dependencies(mp); + } + } +} + +@ The |bilin2| procedure is something like |bilin1|, but with known and unknown +quantities reversed. Parameter |p| points to a value field within the big node +for |cur_exp|; and |type(p)=mp_known|. Parameters |t| and~|u| point to value +fields elsewhere; so does parameter~|q|, unless it is |NULL| (which stands for +zero). Location~|p| will be replaced by $p\cdot t+v\cdot u+q$. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_bilin2 (MP mp, mp_node p, mp_node t, mp_number *v, mp_node u, mp_node q) +{ + mp_number vv; /* temporary storage for |value(p)| */ + new_number_clone(vv, mp_get_value_number(p)); + mp_new_dep(mp, p, mp_proto_dependent_type, mp_const_dependency(mp, &zero_t)); /* this sets |dep_final| */ + if (number_nonzero(vv)) { + mp_add_mult_dep(mp, (mp_value_node) p, &vv, t); /* |dep_final| doesn't change */ + } + if (number_nonzero(*v)) { + mp_number arg1; + new_number_clone(arg1, *v); + mp_add_mult_dep(mp, (mp_value_node) p, &arg1, u); + free_number(arg1); + } + if (q != NULL) { + mp_add_mult_dep(mp, (mp_value_node) p, &unity_t, q); + } + if (mp_get_dep_list((mp_value_node) p) == (mp_node) mp->dep_final) { + number_clone(vv, mp_get_dep_value(mp->dep_final)); + mp_recycle_value(mp, p); + mp_type(p) = mp_known_type; + mp_set_value_number(p, vv); + } + free_number(vv); +} + +@ Finally, in |bilin3| everything is |known|. + +@<Declare subroutines needed by |big_trans|@>= +static void mp_bilin3 (MP mp, mp_node p, mp_number *t, mp_number *v, mp_number *u, mp_number *delta_orig) +{ + mp_number delta; + mp_number tmp; + new_number(tmp); + new_number_clone(delta, *delta_orig); + if (! number_equal(*t, unity_t)) { + take_scaled(tmp, mp_get_value_number(p), *t); + } else { + number_clone(tmp, mp_get_value_number(p)); + } + number_add(delta, tmp); + if (number_nonzero(*u)) { + mp_number ret; + new_number(ret); + take_scaled(ret, *v, *u); + mp_set_value_number(p, delta); + number_add(mp_get_value_number(p), ret); + free_number(ret); + } else { + mp_set_value_number(p, delta); + } + free_number(tmp); + free_number(delta); +} + +@ @<Declare binary action...@>= +static void mp_chop_path (MP mp, mp_node p) +{ + mp_knot q; /* a knot in the original path */ + mp_knot pp, qq; /* link variables for copies of path nodes */ + mp_number a, b; /* indices for chopping */ + mp_number l; + int reversed; /* was |a>b|? */ + new_number(l); + mp_path_length(mp, &l); + new_number_clone(a, mp_get_value_number(mp_x_part(p))); + new_number_clone(b, mp_get_value_number(mp_y_part(p))); + if (number_lessequal(a, b)) { + reversed = 0; + } else { + reversed = 1; + number_swap (a, b); + } + /* Dispense with the cases |a<0| and/or |b>l| */ + if (number_negative(a)) { + if (mp_left_type(cur_exp_knot) == mp_endpoint_knot) { + set_number_to_zero(a); + if (number_negative(b)) { + set_number_to_zero(b); + } + } else { + do { + number_add(a, l); + number_add(b, l); + } while (number_negative(a)); /* a cycle always has length |l>0| */ + } + } + if (number_greater(b, l)) { + if (mp_left_type(cur_exp_knot) == mp_endpoint_knot) { + number_clone(b, l); + if (number_greater(a, l)) { + number_clone(a, l); + } + } else { + while (number_greaterequal(a, l)) { + number_subtract(a, l); + number_subtract(b, l); + } + } + } + q = cur_exp_knot; + while (number_greaterequal(a, unity_t)) { + q = mp_next_knot(q); + number_subtract(a, unity_t); + number_subtract(b, unity_t); + } + if (number_equal(b, a)) { + /* Construct a path from |pp| to |qq| of length zero */ + if (number_positive(a)) { + mp_number arg1; + new_number_clone(arg1, a); + convert_scaled_to_fraction(arg1); + mp_split_cubic(mp, q, &arg1); + free_number(arg1); + q = mp_next_knot(q); + } + pp = mp_copy_knot(mp, q); + qq = pp; + } else { + /* Construct a path from |pp| to |qq| of length $\lceil b\rceil$ */ + mp_knot rr; + pp = mp_copy_knot(mp, q); + qq = pp; + do { + q = mp_next_knot(q); + rr = qq; + qq = mp_copy_knot(mp, q); + mp_prev_knot(qq) = rr; + mp_next_knot(rr) = qq; + number_subtract(b, unity_t); + } while (number_positive(b)); + if (number_positive(a)) { + mp_knot ss = pp; + mp_number arg1; + new_number_clone(arg1, a); + convert_scaled_to_fraction(arg1); + mp_split_cubic(mp, ss, &arg1); + free_number(arg1); + pp = mp_next_knot(ss); + mp_toss_knot(mp, ss); + if (rr == ss) { + mp_number arg1, arg2; + new_number(arg1); + set_number_from_subtraction(arg1, unity_t, a); + new_number_clone(arg2, b); + make_scaled(b, arg2, arg1); + free_number(arg1); + free_number(arg2); + rr = pp; + } + } + if (number_negative(b)) { + mp_number arg1; + new_number(arg1); + set_number_from_addition(arg1, b, unity_t); + convert_scaled_to_fraction(arg1); + mp_split_cubic(mp, rr, &arg1); + free_number(arg1); + mp_toss_knot(mp, qq); + qq = mp_next_knot(rr); + } + } + mp_left_type(pp) = mp_endpoint_knot; + mp_right_type(qq) = mp_endpoint_knot; + mp_prev_knot(pp) = qq; + mp_next_knot(qq) = pp; + mp_toss_knot_list(mp, cur_exp_knot); + if (reversed) { + mp_set_cur_exp_knot(mp, mp_next_knot(mp_htap_ypoc(mp, pp))); + mp_toss_knot_list(mp, pp); + } else { + mp_set_cur_exp_knot(mp, pp); + } + free_number(l); + free_number(a); + free_number(b); +} + +@ @<Declare binary action...@>= +static void mp_set_up_offset (MP mp, mp_node p) +{ + mp_find_offset(mp, &(mp_get_value_number(mp_x_part(p))), &(mp_get_value_number(mp_y_part(p))), cur_exp_knot); + mp_pair_value(mp, &(mp->cur_x), &(mp->cur_y)); +} + +static void mp_set_up_direction_time (MP mp, mp_node p) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_find_direction_time(mp, &new_expr.data.n, &(mp_get_value_number(mp_x_part(p))), &(mp_get_value_number(mp_y_part(p))), cur_exp_knot); + mp_flush_cur_exp(mp, new_expr); +} + +static void mp_set_up_envelope (MP mp, mp_node p) +{ + mp_knot q = mp_copy_path(mp, cur_exp_knot); /* the original path */ + /* TODO: accept elliptical pens for straight paths */ + /* TODO: quite some duplicate code here: maybe make some helpers */ + if (mp_pen_is_elliptical(mp_get_value_knot(p))) { + mp_bad_envelope_pen(mp); + mp_set_cur_exp_knot(mp, q); + mp->cur_exp.type = mp_path_type; + } else { + int linejoin = mp_mitered_linejoin_code; + int linecap = mp_butt_linecap_code; + mp_number miterlimit; + new_number(miterlimit); + if (number_greater(internal_value(mp_linejoin_internal), unity_t)) { + linejoin = mp_beveled_linejoin_code; + } else if (number_positive(internal_value(mp_linejoin_internal))) { + linejoin = mp_rounded_linejoin_code; + } + if (number_greater(internal_value(mp_linecap_internal), unity_t)) { + linecap = mp_squared_linecap_code; + } else if (number_positive(internal_value(mp_linecap_internal))) { + linecap = mp_rounded_linecap_code; + } + if (number_less(internal_value(mp_miterlimit_internal), unity_t)) { + set_number_to_unity(miterlimit); + } else { + number_clone(miterlimit, internal_value(mp_miterlimit_internal)); + } + mp_set_cur_exp_knot(mp, mp_make_envelope(mp, q, mp_get_value_knot(p), linejoin, linecap, &miterlimit)); + mp->cur_exp.type = mp_path_type; + } +} + +static void mp_set_up_boundingpath (MP mp, mp_node p) +{ + mp_number miterlimit; + mp_knot q = mp_copy_path(mp, cur_exp_knot); /* the original path */ + mp_knot qq; + int linejoin = mp_mitered_linejoin_code; + int linecap = mp_butt_linecap_code; + mp_knot pen = mp_get_value_knot(p); + new_number(miterlimit); + /* + Accept elliptical pens for s paths using |mp_make_path| to convert an + elliptical pen to a polygonal one. The approximation of 8 knots should be + good enough. + */ + if (mp_pen_is_elliptical(mp_get_value_knot(p))) { + mp_knot kp, kq; + pen = mp_copy_pen(mp, mp_get_value_knot(p)); + mp_make_path(mp, pen); + kq = pen; + do { + kp = kq; + kq = mp_next_knot(kq); + mp_prev_knot(kq) = kp; + } while (kq != pen); + mp_close_path_cycle(mp, kp, pen); + } + if (number_greater(internal_value(mp_linejoin_internal), unity_t)) { + linejoin = mp_beveled_linejoin_code; + } else if (number_positive(internal_value(mp_linejoin_internal))) { + linejoin = mp_rounded_linejoin_code; + } + if (number_greater(internal_value(mp_linecap_internal), unity_t)) { + linecap = mp_squared_linecap_code; + } else if (number_positive(internal_value(mp_linecap_internal))) { + linecap = mp_rounded_linecap_code; + } + if (number_less(internal_value(mp_miterlimit_internal), unity_t)) { + set_number_to_unity(miterlimit); + } else { + number_clone(miterlimit, internal_value(mp_miterlimit_internal)); + } + qq = mp_make_envelope(mp, q, pen, linejoin, linecap, &miterlimit); + mp_set_cur_exp_knot(mp, qq); + mp->cur_exp.type = mp_path_type; + if (! mp_get_cur_bbox(mp)) { + mp_bad_binary(mp, p, mp_boundingpath_operation); + mp_set_cur_exp_knot(mp, q); + mp->cur_exp.type = mp_path_type; + return; + } else { + mp_knot ll = mp_new_knot(mp); + mp_knot lr = mp_new_knot(mp); + mp_knot ur = mp_new_knot(mp); + mp_knot ul = mp_new_knot(mp); + if (ll == NULL || lr == NULL || ur == NULL || ul == NULL){ + mp_bad_binary(mp, p, mp_boundingpath_operation); + mp_set_cur_exp_knot(mp, q); + mp->cur_exp.type = mp_path_type; + return; + } else { + mp_left_type(ll) = mp_endpoint_knot; + mp_right_type(ll) = mp_endpoint_knot; + mp_originator(ll) = mp_program_code; + mp_knotstate(ll) = mp_regular_knot; + number_clone(ll->x_coord, mp_minx); + number_clone(ll->y_coord, mp_miny); + mp_originator(lr) = mp_program_code; + mp_knotstate(lr) = mp_regular_knot; + number_clone(lr->x_coord, mp_maxx); + number_clone(lr->y_coord, mp_miny); + mp_originator(ur) = mp_program_code; + mp_knotstate(ur) = mp_regular_knot; + number_clone(ur->x_coord, mp_maxx); + number_clone(ur->y_coord, mp_maxy); + mp_originator(ul) = mp_program_code; + mp_knotstate(ul) = mp_regular_knot; + number_clone(ul->x_coord, mp_minx); + number_clone(ul->y_coord, mp_maxy); + mp_prev_knot(lr) = ll; + mp_next_knot(ll) = lr; + mp_prev_knot(ur) = lr; + mp_next_knot(lr) = ur; + mp_prev_knot(ul) = ur; + mp_next_knot(ur) = ul; + mp_close_path_cycle(mp, ul, ll); + mp_make_path(mp,ll); + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, ll); + mp_free_path(mp,qq); + } + } +} + +@ @<Declare binary action...@>= +static void mp_find_point (MP mp, mp_number *v_orig, int c) +{ + mp_knot p; /* the path */ + mp_number n; /* its length */ + mp_number v; + new_number(n); + new_number_clone(v, *v_orig); + p = cur_exp_knot; + if (mp_left_type(p) == mp_endpoint_knot) { + set_number_to_unity(n); + number_negate(n); + } + do { + p = mp_next_knot(p); + number_add(n, unity_t); + } while (p != cur_exp_knot); + if (number_zero(n)) { + set_number_to_zero(v); + } else if (number_negative(v)) { + if (mp_left_type(p) == mp_endpoint_knot) { + set_number_to_zero(v); + } else { + /* |v = n - 1 - ((-v - 1) % n) == - ((-v - 1) % n) - 1 + n| */ + number_negate(v); + number_add_scaled(v, -1); + number_modulo(v, n); + number_negate(v); + number_add_scaled(v, -1); + number_add(v, n); + } + } else if (number_greater(v, n)) { + if (mp_left_type(p) == mp_endpoint_knot) { + number_clone(v, n); + } else { + number_modulo(v, n); + } + } + p = cur_exp_knot; + while (number_greaterequal(v, unity_t)) { + p = mp_next_knot(p); + number_subtract(v, unity_t); + } + if (number_nonzero(v)) { + /* Insert a fractional node by splitting the cubic */ + convert_scaled_to_fraction(v); + mp_split_cubic(mp, p, &v); + p = mp_next_knot(p); + } + /* Set the current expression to the desired path coordinates */ + push_of_path_result(mp, c - mp_point_operation, p); + free_number(v); + free_number(n); +} + +@* Statements and commands. + +The chief executive of \MP\ is the |do_statement| routine, which contains the +master switch that causes all the various pieces of \MP\ to do their things, in +the right order. + +In a sense, this is the grand climax of the program: It applies all the tools +that we have worked so hard to construct. In another sense, this is the messiest +part of the program: It necessarily refers to other pieces of code all over the +place, so that a person can't fully understand what is going on without paging +back and forth to be reminded of conventions that are defined elsewhere. We are +now at the hub of the web. + +The structure of |do_statement| itself is quite simple. The first token of the +statement is fetched using |get_x_next|. If it can be the first token of an +expression, we look for an equation, an assignment, or a title. Otherwise we use +a |case| construction to branch at high speed to the appropriate routine for +various and sundry other types of commands, each of which has an \quote {action +procedure} that does the necessary work. + +The program uses the fact that + +$$\hbox{|min_primary_command=max_statement_command=type_name|}$$ + +to interpret a statement that starts with, e.g., |string|, as a type +declaration rather than a boolean expression. + +@c +static void worry_about_bad_statement (MP mp); + +static void flush_unparsable_junk_after_statement (MP mp); + +void mp_do_statement (MP mp) +{ + /* governs \MP's activities */ + mp->cur_exp.type = mp_vacuous_type; + mp_get_x_next(mp); + if (cur_cmd > mp_max_primary_command) { + worry_about_bad_statement(mp); + } else if (cur_cmd > mp_max_statement_command) { + /* + Do an equation, assignment, title, or + `$\langle\,$expression$\,\rangle\,$|endgroup|'; The most important + statements begin with expressions + */ + mp_value new_expr; + mp->var_flag = mp_assignment_command; + mp_scan_expression(mp); + if (cur_cmd < mp_end_group_command) { + if (cur_cmd == mp_equals_command) { + mp_do_equation(mp); + } else if (cur_cmd == mp_assignment_command) { + mp_do_assignment(mp); + } else if (mp->cur_exp.type == mp_string_type) { + /* Do a title */ + if (number_positive(internal_value(mp_tracing_titles_internal))) { + mp_print_nl(mp, ""); + mp_print_mp_str(mp, cur_exp_str); + update_terminal(); + } + } else if (mp->cur_exp.type != mp_vacuous_type) { + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Isolated expression", + "I couldn't find an '=' or ':=' after the expression that is shown above this\n" + "error message, so I guess I'll just ignore it and carry on." + ); + mp_get_x_next(mp); + } + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_vacuous_type; + } + } else { + /* + Do a statement that doesn't begin with an expression. If |do_statement| + ends with |cur_cmd=end_group|, we should have |cur_type=mp_vacuous| unless + the statement was simply an expression; in the latter case, |cur_type| and + |cur_exp| should represent that expression. + */ + if (number_positive(internal_value(mp_tracing_commands_internal))) { + mp_show_cmd_mod(mp, cur_cmd, cur_mod); + } + switch (cur_cmd) { + case mp_type_name_command: + mp_do_type_declaration(mp); + break; + case mp_macro_def_command: + switch (cur_mod) { + case mp_def_code: + case mp_var_def_code: + mp_scan_def(mp, cur_mod); + break; + case mp_primary_def_code: + case mp_secondary_def_code: + case mp_tertiary_def_code: + mp_make_op_def(mp, cur_mod); + break; + } + break; + case mp_only_set_command: + switch (cur_mod) { + case mp_random_seed_code: + mp_do_random_seed(mp); + break; + case mp_max_knot_pool_code: + mp_do_max_knot_pool(mp); + break; + } + break; + case mp_mode_command: + mp_print_ln(mp); + mp->interaction = cur_mod; + mp->selector = mp->interaction == mp_batch_mode ? mp_log_only_selector : mp_term_and_log_selector; + mp_get_x_next(mp); + break; + case mp_protection_command: + mp_do_protection(mp); + break; + case mp_property_command: + mp_do_property(mp); + break; + case mp_delimiters_command: + mp_def_delims(mp); + break; + case mp_save_command: + do { + mp_get_symbol(mp); + mp_save_variable(mp, cur_sym); + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); + break; + case mp_interim_command: + mp_do_interim(mp); + break; + case mp_let_command: + mp_do_let(mp); + break; + case mp_new_internal_command: + mp_do_new_internal(mp); + break; + case mp_show_command: + mp_do_show_whatever(mp); + break; + case mp_add_to_command: + mp_do_add_to(mp); + break; + case mp_bounds_command: + mp_do_bounds(mp); + break; + case mp_ship_out_command: + mp_do_ship_out(mp); + break; + case mp_every_job_command: + mp_get_symbol(mp); + mp->every_job_sym = cur_sym; + mp_get_x_next(mp); + break; + case mp_message_command: + mp_do_message(mp); + break; + case mp_write_command: + mp_do_write(mp); + break; + default: + break; + } + mp->cur_exp.type = mp_vacuous_type; + } + if (cur_cmd < mp_semicolon_command) { + flush_unparsable_junk_after_statement(mp); + } + mp->error_count = 0; +} + +@ @<Declarations@>= +@<Declare action procedures for use by |do_statement|@> + +@ The only command codes |>max_primary_command| that can be present at the +beginning of a statement are |semicolon| and higher; these occur when the +statement is null. + +@c +static void worry_about_bad_statement (MP mp) +{ + if (cur_cmd < mp_semicolon_command) { + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_print_cmd_mod(mp, cur_cmd, cur_mod); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "A statement can't begin with '%s'", mp_str(mp, sname)); + delete_str_ref(sname); + mp_back_error( + mp, + msg, + "I was looking for the beginning of a new statement. If you just proceed without\n" + "changing anything, I'll ignore everything up to the next ';'." + ); + mp_get_x_next(mp); + } +} + +@ The help message printed here says that everything is flushed up to +a semicolon, but actually the commands |end_group| and |stop| will +also terminate a statement. + +@c +static void flush_unparsable_junk_after_statement (MP mp) +{ + mp_back_error( + mp, + "Extra tokens will be flushed", + "I've just read as much of that statement as I could fathom, so a semicolon should\n" + "have been next. It's very puzzling ... but I'll try to get myself back together,\n" + "by ignoring everything up to the next ';'." + ); + mp->scanner_status = mp_flushing_state; + do { + get_t_next(mp); + if (cur_cmd == mp_string_command) { + delete_str_ref(cur_mod_str); + } + } while (! mp_end_of_statement); /* |cur_cmd=semicolon|, |end_group|, or |stop| */ + mp->scanner_status = mp_normal_state; +} + +@ Equations and assignments are performed by the pair of mutually recursive +@^recursion@> routines |do_equation| and |do_assignment|. These routines are +called when |cur_cmd=equals| and when |cur_cmd=assignment|, respectively; the +left-hand side is in |cur_type| and |cur_exp|, while the right-hand side is yet +to be scanned. After the routines are finished, |cur_type| and |cur_exp| will be +equal to the right-hand side (which will normally be equal to the left-hand +side). + +@<Declarations@>= +@<Declare the procedure called |make_eq|@> +static void mp_do_equation (MP mp); + +@ @c +static void trace_equation (MP mp, mp_node lhs) +{ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{("); + mp_print_exp(mp, lhs, 0); + mp_print_str(mp, ")=("); + mp_print_exp(mp, NULL, 0); + mp_print_str(mp, ")}"); + mp_end_diagnostic(mp, 0); +} + +void mp_do_equation (MP mp) +{ + mp_node lhs = mp_stash_cur_exp(mp); /* capsule for the left-hand side */ + mp_get_x_next(mp); + mp->var_flag = mp_assignment_command; + mp_scan_expression(mp); + if (cur_cmd == mp_equals_command) { + mp_do_equation(mp); + } else if (cur_cmd == mp_assignment_command) { + mp_do_assignment(mp); + } + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + trace_equation(mp, lhs); + } + if (mp->cur_exp.type == mp_unknown_path_type) { + if (mp_type(lhs) == mp_pair_type) { + mp_node p; /* temporary register */ + p = mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, lhs); + lhs = p; + } + /* in this case |make_eq| will change the pair to a path */ + } + mp_make_eq(mp, lhs); /* equate |lhs| to |(cur_type,cur_exp)| */ +} + +@ And |do_assignment| is similar to |do_equation|: + +@<Declarations@>= +static void mp_do_assignment (MP mp); + +@ @c +static void bad_lhs (MP mp) +{ + mp_disp_err(mp, NULL); + mp_error( + mp, + "Improper ':=' will be changed to '='", + "I didn't find a variable name at the left of the ':=', so I'm going to pretend\n" + "that you said '=' instead." + ); + mp_do_equation(mp); +} + +static void bad_internal_assignment (MP mp, mp_node lhs) +{ + char msg[256]; + mp_disp_err(mp, NULL); + if (internal_type(mp_get_sym_info(lhs)) == mp_known_type) { + mp_snprintf(msg, 256, + "Internal quantity '%s' must receive a known numeric value", + internal_name(mp_get_sym_info(lhs)) + ); + mp_back_error( + mp, + msg, + "I can't set this internal quantity to anything but a known numeric value, so I'll\n" + "have to ignore this assignment." + ); + } else if (internal_type(mp_get_sym_info(lhs)) == mp_boolean_type) { + mp_snprintf(msg, 256, + "Internal quantity '%s' must receive a known boolean value", + internal_name(mp_get_sym_info(lhs)) + ); + mp_back_error( + mp, + msg, + "I can't set this internal quantity to anything but a known boolean value, so I'll\n" + "have to ignore this assignment." + ); + } else { + mp_snprintf(msg, 256, + "Internal quantity '%s' must receive a known string", + internal_name(mp_get_sym_info(lhs)) + ); + mp_back_error( + mp, + msg, + "I can't set this internal quantity to anything but a known string value, so I'll\n" + "have to ignore this assignment." + ); + } + mp_get_x_next(mp); +} + +static void forbidden_internal_assignment (MP mp, mp_node lhs) +{ + char msg[256]; + mp_snprintf(msg, 256,"Internal quantity '%s' is read-only", internal_name(mp_get_sym_info(lhs))); + mp_back_error( + mp, + msg, + "I can't set this internal quantity to anything just yet (it is read-only), so\n" + "I'll have to ignore this assignment." + ); + mp_get_x_next(mp); +} + +static void bad_internal_assignment_precision (MP mp, mp_node lhs, mp_number *min, mp_number *max) +{ + char msg[256]; + char hlp[256]; + mp_snprintf(msg, 256, + "Bad '%s' has been ignored", + internal_name(mp_get_sym_info(lhs))); + mp_snprintf(hlp, 256, + "Precision values are limited by the current numbersystem.\n" + "Currently I am using '%s'; the allowed precision range is [%s,%s].", + mp_str(mp, internal_string(mp_number_system_internal)), number_tostring(*min), number_tostring(*max)); + mp_back_error(mp, msg, hlp); + mp_get_x_next(mp); +} + +static void bad_expression_assignment (MP mp, mp_node lhs) +{ + char *msg = mp_obliterated(mp, lhs); + mp_back_error( + mp, + msg, + "It seems you did a nasty thing --- probably by accident, but nevertheless you\n" + "nearly hornswoggled me ... While I was evaluating the right-hand side of this\n" + "command, something happened, and the left-hand side is no longer a variable! So I\n" + "won't change anything." + ); + mp_memory_free(msg); + mp_get_x_next(mp); +} + +static void trace_assignment (MP mp, mp_node lhs) +{ + mp_begin_diagnostic(mp); + mp_print_nl(mp, "{"); + if (mp_name_type(lhs) == mp_internal_operation) { + mp_print_str(mp, internal_name(mp_get_sym_info(lhs))); + } else { + mp_show_token_list(mp, lhs, NULL); + } + mp_print_str(mp, ":="); + mp_print_exp(mp, NULL, 0); + mp_print_chr(mp, '}'); + mp_end_diagnostic(mp, 0); +} + +void mp_do_assignment (MP mp) +{ + if (mp->cur_exp.type != mp_token_list_type) { + bad_lhs(mp); + } else { + mp_node lhs = cur_exp_node; /* token list for the left-hand side */ + mp->cur_exp.type = mp_vacuous_type; + mp_get_x_next(mp); + mp->var_flag = mp_assignment_command; + mp_scan_expression(mp); + if (cur_cmd == mp_equals_command) { + mp_do_equation(mp); + } else if (cur_cmd == mp_assignment_command) { + mp_do_assignment(mp); + } + if (number_greater(internal_value(mp_tracing_commands_internal), two_t)) { + trace_assignment (mp, lhs); + } + if (mp_name_type(lhs) == mp_internal_operation) { + /* Assign the current expression to an internal variable */ + switch (mp->cur_exp.type) { + case mp_known_type: + case mp_string_type: + case mp_boolean_type: + if (internal_type(mp_get_sym_info(lhs)) == mp->cur_exp.type) { + switch (mp_get_sym_info(lhs)) { + case mp_number_system_internal: + forbidden_internal_assignment(mp, lhs); + break; + // case mp_tracing_online_internal: + // number_clone(internal_value(mp_get_sym_info(lhs)), cur_exp_value_number); + // mp->run_internal(mp, 3, mp->int_ptr, number_to_int(internal_value(mp_get_sym_info(lhs))), internal_name(mp_get_sym_info(lhs))); + // break; + case mp_number_precision_internal: + if (mp->cur_exp.type == mp_known_type + && (! number_less (cur_exp_value_number, precision_min)) + && (! number_greater(cur_exp_value_number, precision_max)) + ) { + if (internal_type(mp_get_sym_info(lhs)) == mp_string_type) { + add_str_ref(cur_exp_str); + set_internal_string(mp_get_sym_info(lhs), cur_exp_str); + } else { + number_clone(internal_value(mp_get_sym_info(lhs)), cur_exp_value_number); + } + set_precision(); + } else { + bad_internal_assignment_precision(mp, lhs, &precision_min, &precision_max); + } + default: + if (internal_type(mp_get_sym_info(lhs)) == mp_string_type) { + add_str_ref(cur_exp_str); + set_internal_string(mp_get_sym_info(lhs), cur_exp_str); + } else { + number_clone(internal_value(mp_get_sym_info(lhs)), cur_exp_value_number); + } + break; + } + } else { + bad_internal_assignment(mp, lhs); + } + break; + default: + bad_internal_assignment(mp, lhs); + } + } else { + /* Assign the current expression to the variable |lhs| */ + mp_node p = mp_find_variable(mp, lhs); /* where the left-hand value is stored */ + if (p != NULL) { + mp_node q = mp_stash_cur_exp(mp); /* temporary capsule for the right-hand value */ + mp->cur_exp.type = mp_und_type(mp, p); + mp_recycle_value(mp, p); + mp_type(p) = mp->cur_exp.type; + mp_set_value_number(p, zero_t); + mp_make_exp_copy(mp, p); + p = mp_stash_cur_exp(mp); + mp_unstash_cur_exp(mp, q); + mp_make_eq(mp, p); + } else { + bad_expression_assignment(mp, lhs); + } + } + mp_flush_node_list(mp, lhs); + } +} + +@ And now we get to the nitty-gritty. The |make_eq| procedure is given a pointer +to a capsule that is to be equated to the current expression. + +@<Declare the procedure called |make_eq|@>= +static void mp_make_eq (MP mp, mp_node lhs); + +@ @c +static void announce_bad_equation (MP mp, mp_node lhs) +{ + char msg[256]; + mp_snprintf(msg, 256, + "Equation cannot be performed (%s=%s)", + (mp_type(lhs) <= mp_pair_type ? mp_type_string(mp_type(lhs)) : "numeric"), + (mp->cur_exp.type <= mp_pair_type ? mp_type_string(mp->cur_exp.type) : "numeric")); + mp_disp_err(mp, lhs); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + msg, + "I'm sorry, but I don't know how to make such things equal. (See the two\n" + "expressions just above the error message.)" + ); + mp_get_x_next(mp); +} + +static void mp_exclaim_inconsistent_equation (MP mp) +{ + mp_back_error( + mp, + "Inconsistent equation", + "The equation I just read contradicts what was said before. But don't worry;\n" + "continue and I'll just ignore it." + ); + mp_get_x_next(mp); +} + +static void mp_exclaim_redundant_or_inconsistent_equation (MP mp) +{ + mp_back_error( + mp, + "Redundant or inconsistent equation", + "An equation between already-known quantities can't help. But don't worry;\n" + "continue and I'll just ignore it." + ); + mp_get_x_next(mp); +} + +static void report_redundant_or_inconsistent_equation (MP mp, mp_node lhs, mp_number *v) +{ + if (mp->cur_exp.type <= mp_string_type) { + if (mp->cur_exp.type == mp_string_type) { + if (mp_str_vs_str(mp, mp_get_value_str(lhs), cur_exp_str) != 0) { + mp_exclaim_inconsistent_equation(mp); + } else { + mp_exclaim_redundant_equation(mp); + } + } else if (number_equal(*v, cur_exp_value_number)) { + mp_exclaim_redundant_equation(mp); + } else { + mp_exclaim_inconsistent_equation(mp); + } + } else { + mp_exclaim_redundant_or_inconsistent_equation(mp); + } +} + +void mp_make_eq (MP mp, mp_node lhs) +{ + mp_value new_expr; + mp_variable_type t; /* type of the left-hand side */ + mp_number v; /* value of the left-hand side */ + memset(&new_expr, 0, sizeof(mp_value)); + new_number(v); + RESTART: + t = mp_type(lhs); + if (t <= mp_pair_type) { + number_clone(v, mp_get_value_number(lhs)); + } + /* + For each type |t|, make an equation or complain if |cur_type| is + incompatible with~|t| + */ + switch (t) { + case mp_boolean_type: + case mp_string_type: + case mp_pen_type: + case mp_nep_type: + case mp_path_type: + case mp_picture_type: + if (mp->cur_exp.type == t + unknown_tag) { + new_number(new_expr.data.n); + switch (t) { + case mp_boolean_type: + number_clone(new_expr.data.n, v); + break; + case mp_string_type: + new_expr.data.str = mp_get_value_str(lhs); + break; + case mp_picture_type: + new_expr.data.node = mp_get_value_node(lhs); + break; + default: + /* pen or path */ + new_expr.data.p = mp_get_value_knot(lhs); + break; + } + mp_nonlinear_eq(mp, new_expr, cur_exp_node, 0); + mp_unstash_cur_exp(mp, cur_exp_node); + } else if (mp->cur_exp.type == t) { + report_redundant_or_inconsistent_equation(mp, lhs, &v); + } else { + announce_bad_equation(mp, lhs); + } + break; + case mp_unknown_boolean_type: + case mp_unknown_string_type: + case mp_unknown_pen_type: + case mp_unknown_nep_type: + case mp_unknown_path_type: + case mp_unknown_picture_type: + if (mp->cur_exp.type == t - unknown_tag) { + mp_nonlinear_eq(mp, mp->cur_exp, lhs, 1); + } else if (mp->cur_exp.type == t) { + mp_ring_merge (mp, lhs, cur_exp_node); + } else if (mp->cur_exp.type == mp_pair_type) { + if (t == mp_unknown_path_type) { + mp_pair_to_path(mp); + goto RESTART; + } + } else { + announce_bad_equation(mp, lhs); + } + break; + case mp_transform_type: + case mp_color_type: + case mp_cmykcolor_type: + case mp_pair_type: + if (mp->cur_exp.type == t) { + /* Do multiple equations */ + mp_node q = mp_get_value_node(cur_exp_node); + mp_node p = mp_get_value_node(lhs); + switch (t) { + case mp_transform_type: + mp_try_eq(mp, mp_yy_part(p), mp_yy_part(q)); + mp_try_eq(mp, mp_yx_part(p), mp_yx_part(q)); + mp_try_eq(mp, mp_xy_part(p), mp_xy_part(q)); + mp_try_eq(mp, mp_xx_part(p), mp_xx_part(q)); + mp_try_eq(mp, mp_ty_part(p), mp_ty_part(q)); + mp_try_eq(mp, mp_tx_part(p), mp_tx_part(q)); + break; + case mp_color_type: + mp_try_eq(mp, mp_blue_part(p), mp_blue_part(q)); + mp_try_eq(mp, mp_green_part(p), mp_green_part(q)); + mp_try_eq(mp, mp_red_part(p), mp_red_part(q)); + break; + case mp_cmykcolor_type: + mp_try_eq(mp, mp_black_part(p), mp_black_part(q)); + mp_try_eq(mp, mp_yellow_part(p), mp_yellow_part(q)); + mp_try_eq(mp, mp_magenta_part(p), mp_magenta_part(q)); + mp_try_eq(mp, mp_cyan_part(p), mp_cyan_part(q)); + break; + case mp_pair_type: + mp_try_eq(mp, mp_y_part(p), mp_y_part(q)); + mp_try_eq(mp, mp_x_part(p), mp_x_part(q)); + break; + default: + break; + } + } else { + announce_bad_equation(mp, lhs); + } + break; + case mp_known_type: + case mp_dependent_type: + case mp_proto_dependent_type: + case mp_independent_type: + if (mp->cur_exp.type >= mp_known_type) { + mp_try_eq(mp, lhs, NULL); + } else { + announce_bad_equation(mp, lhs); + } + break; + case mp_vacuous_type: + announce_bad_equation(mp, lhs); + break; + default: + announce_bad_equation(mp, lhs); + break; + } + check_arith(); + mp_recycle_value(mp, lhs); + free_number(v); + mp_free_value_node(mp, lhs); +} + +@ The first argument to |try_eq| is the location of a value node in a capsule +that will soon be recycled. The second argument is either a location within a +pair or transform node pointed to by |cur_exp|, or it is |NULL| (which means that +|cur_exp| itself serves as the second argument). The idea is to leave |cur_exp| +unchanged, but to equate the two operands. + + +@<Declarations@>= +static void mp_try_eq (MP mp, mp_node l, mp_node r); + +@d equation_threshold_k mp->math->md_equation_threshold_t + +@ @c +static void deal_with_redundant_or_inconsistent_equation (MP mp, mp_value_node p, mp_node r) +{ + mp_number absp; + new_number_abs(absp, mp_get_value_number(p)); + if (number_greater(absp, equation_threshold_k)) { /* off by .001 or more */ + char msg[256]; + mp_snprintf(msg, 256, "Inconsistent equation (off by %s)", number_tostring (mp_get_value_number(p))); + mp_back_error( + mp, + msg, + "The equation I just read contradicts what was said before. But don't worry;\n" + "continue and I'll just ignore it." + ); + mp_get_x_next(mp); + } else if (r == NULL) { + mp_exclaim_redundant_equation(mp); + } + free_number(absp); + mp_free_dep_node(mp, p); +} + +void mp_try_eq (MP mp, mp_node l, mp_node r) +{ + mp_value_node p; /* dependency list for right operand minus left operand */ + mp_value_node q; /* the constant term of |p| is here */ + mp_value_node pp; /* dependency list for right operand */ + mp_variable_type tt; /* the type of list |pp| */ + int copied; /* have we copied a list that ought to be recycled? */ + /* + Remove the left operand from its container, negate it, and put it into + dependency list~|p| with constant term~|q| + */ + mp_variable_type t = mp_type(l); /* the type of list |p| */ + switch (t) { + case mp_known_type: + { + mp_number arg1; + new_number(arg1); + number_negated_clone(arg1, mp_get_value_number(l)); + t = mp_dependent_type; + p = mp_const_dependency(mp, &arg1); + q = p; + free_number(arg1); + } + break; + case mp_independent_type: + { + t = mp_dependent_type; + p = mp_single_dependency(mp, l); + number_negate(mp_get_dep_value(p)); + q = mp->dep_final; + } + break; + default: + { + mp_value_node ll = (mp_value_node) l; + p = (mp_value_node) mp_get_dep_list(ll); + q = p; + while (1) { + number_negate(mp_get_dep_value(q)); + if (mp_get_dep_info(q) == NULL) { + break; + } else { + q = (mp_value_node) mp_link(q); + } + } + mp_link(mp_get_prev_dep(ll)) = mp_link(q); + mp_set_prev_dep((mp_value_node) mp_link(q), mp_get_prev_dep(ll)); + mp_type(ll) = mp_known_type; + } + break; + } + /* Add the right operand to list |p| */ + if (r == NULL) { + if (mp->cur_exp.type == mp_known_type) { + number_add(mp_get_value_number(q), cur_exp_value_number); + goto DONE1; + } else { + tt = mp->cur_exp.type; + if (tt == mp_independent_type) { + pp = mp_single_dependency(mp, cur_exp_node); + } else { + pp = (mp_value_node) mp_get_dep_list((mp_value_node) cur_exp_node); + } + } + } else if (mp_type(r) == mp_known_type) { + number_add(mp_get_dep_value(q), mp_get_value_number(r)); + goto DONE1; + } else { + tt = mp_type(r); + if (tt == mp_independent_type) { + pp = mp_single_dependency(mp, r); + } else { + pp = (mp_value_node) mp_get_dep_list((mp_value_node) r); + } + } + if (tt != mp_independent_type) { + copied = 0; + } else { + copied = 1; + tt = mp_dependent_type; + } + /* Add dependency list |pp| of type |tt| to dependency list~|p| of type~|t| */ + mp->watch_coefs = 0; + if (t == tt) { + p = mp_p_plus_q(mp, p, pp, (int) t); + } else if (t == mp_proto_dependent_type) { + p = mp_p_plus_fq(mp, p, &unity_t, pp, mp_proto_dependent_type, mp_dependent_type); + } else { + mp_number x; + new_number(x); + q = p; + while (mp_get_dep_info(q) != NULL) { + number_clone(x, mp_get_dep_value(q)); + fraction_to_round_scaled(x); + mp_set_dep_value(q, x); + q = (mp_value_node) mp_link(q); + } + free_number(x); + t = mp_proto_dependent_type; + p = mp_p_plus_q(mp, p, pp, (int) t); + } + mp->watch_coefs = 1; + if (copied) { + mp_flush_node_list(mp, (mp_node) pp); + } + DONE1: + if (mp_get_dep_info(p) == NULL) { + deal_with_redundant_or_inconsistent_equation(mp, p, r); + } else { + mp_linear_eq(mp, p, (int) t); + if (r == NULL && mp->cur_exp.type != mp_known_type && mp_type(cur_exp_node) == mp_known_type) { + mp_node pp = cur_exp_node; + mp_set_cur_exp_value_number(mp, &(mp_get_value_number(pp))); + mp->cur_exp.type = mp_known_type; + mp_free_value_node(mp, pp); + } + } +} + +@ Our next goal is to process type declarations. For this purpose it's convenient +to have a procedure that scans a $\langle\,$declared variable$\,\rangle$ and +returns the corresponding token list. After the following procedure has acted, +the token after the declared variable will have been scanned, so it will appear +in |cur_cmd|, |cur_mod|, and~|cur_sym|. + +@<Declarations@>= +static mp_node mp_scan_declared_variable (MP mp); + +@ @c +mp_node mp_scan_declared_variable (MP mp) +{ + mp_sym x; /* hash address of the variable's root */ + mp_node h, t; /* head and tail of the token list to be returned */ + mp_get_symbol(mp); + x = cur_sym; + if (cur_cmd != mp_tag_command) { + mp_clear_symbol(mp, x, 0); + } + h = mp_new_symbolic_node(mp); + mp_set_sym_sym(h, x); + t = h; + while (1) { + mp_get_x_next(mp); + if (cur_sym == NULL) { + break; + } else if (cur_cmd != mp_tag_command) { + /* could be smarter: */ + if (cur_cmd != mp_internal_command) { + if (cur_cmd == mp_left_bracket_command) { + /* + Descend past a collective subscript If the subscript + isn't collective, we don't accept it as part of the + declared variable. + */ + mp_sym ll = cur_sym; /* hash address of left bracket */ + mp_get_x_next(mp); + if (cur_cmd == mp_right_bracket_command) { + set_cur_sym(mp_collective_subscript); + } else { + mp_back_input(mp); + set_cur_sym(ll); + set_cur_cmd(mp_left_bracket_command); + break; + } + } else { + break; + } + } + } + mp_link(t) = mp_new_symbolic_node(mp); + t = mp_link(t); + mp_set_sym_sym(t, cur_sym); + mp_name_type(t) = cur_sym_mod; + } + if (eq_property(x) != 0) { + mp_check_overload(mp, x); + } + // if ((eq_type(x) % mp_outer_tag_command) != mp_tag_command) { + if (eq_type(x) != mp_tag_command) { + mp_clear_symbol(mp, x, 0); + } + if (equiv_node(x) == NULL) { + mp_new_root (mp, x); + } + return h; +} + +@ Type declarations are introduced by the following primitive operations. + +@ @<Put each...@>= +mp_primitive(mp, "numeric", mp_type_name_command, mp_numeric_type_operation); +@:numeric_}{|numeric| primitive@> +mp_primitive(mp, "string", mp_type_name_command, mp_string_type_operation); +@:string_}{|string| primitive@> +mp_primitive(mp, "boolean", mp_type_name_command, mp_boolean_type_operation); +@:boolean_}{|boolean| primitive@> +mp_primitive(mp, "path", mp_type_name_command, mp_path_type_operation); +@:path_}{|path| primitive@> +mp_primitive(mp, "pen", mp_type_name_command, mp_pen_type_operation); +@:pen_}{|pen| primitive@> +mp_primitive(mp, "nep", mp_type_name_command, mp_nep_type_operation); +@:nep_}{|nep| primitive@> +mp_primitive(mp, "picture", mp_type_name_command, mp_picture_type_operation); +@:picture_}{|picture| primitive@> +mp_primitive(mp, "transform", mp_type_name_command, mp_transform_type_operation); +@:transform_}{|transform| primitive@> +mp_primitive(mp, "color", mp_type_name_command, mp_color_type_operation); +@:color_}{|color| primitive@> +mp_primitive(mp, "rgbcolor", mp_type_name_command, mp_color_type_operation); +@:color_}{|rgbcolor| primitive@> +mp_primitive(mp, "cmykcolor", mp_type_name_command, mp_cmykcolor_type_operation); +@:color_}{|cmykcolor| primitive@> +mp_primitive(mp, "pair", mp_type_name_command, mp_pair_type_operation); +@:pair_}{|pair| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_type_name_command: + /* return mp_type_string(mp, m): */ + return ""; + +@ Now we are ready to handle type declarations, assuming that a |type_name| has +just been scanned. We don't use the type to operation mix here, we just have +am extra set of operations and a switch that maps on type. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_type_declaration (MP mp); + +@ @c +static void flush_spurious_symbols_after_declared_variable (MP mp); + +void mp_do_type_declaration (MP mp) +{ + int t = mp_numeric_type; /* cur_mod >= mp_transform_type ? cur_mod : cur_mod + unknown_tag; */ /* the type being declared */ + switch (cur_mod) { + case mp_string_type_operation: t = mp_unknown_string_type; break; + case mp_boolean_type_operation: t = mp_unknown_boolean_type; break; + case mp_path_type_operation: t = mp_unknown_path_type; break; + case mp_pen_type_operation: t = mp_unknown_pen_type; break; + case mp_nep_type_operation: t = mp_unknown_nep_type; break; + case mp_picture_type_operation: t = mp_unknown_picture_type; break; + case mp_transform_type_operation: t = mp_transform_type; break; + case mp_color_type_operation: t = mp_color_type; break; + case mp_cmykcolor_type_operation: t = mp_cmykcolor_type; break; + case mp_pair_type_operation: t = mp_pair_type; break; + case mp_numeric_type_operation: t = mp_numeric_type; break; + } + + do { + mp_node p = mp_scan_declared_variable(mp); /* token list for a declared variable */ + mp_node q; /* value node for the variable */ + mp_flush_variable(mp, equiv_node(mp_get_sym_sym(p)), mp_link(p), 0); + q = mp_find_variable(mp, p); + if (q != NULL) { + mp_type(q) = t; + mp_set_value_number(q, zero_t); /* todo: this was |null| */ + } else { + mp_back_error( + mp, + "Declared variable conflicts with previous vardef", + "You can't use, e.g., 'numeric foo[]' after 'vardef foo'. Proceed, and I'll ignore\n" + "the illegal redeclaration." + ); + mp_get_x_next(mp); + } + mp_flush_node_list(mp, p); + if (cur_cmd < mp_comma_command) { + flush_spurious_symbols_after_declared_variable(mp); + } + } while (! mp_end_of_statement); +} + +@ +@c +static void flush_spurious_symbols_after_declared_variable (MP mp) +{ + const char *hlp = NULL; + if (cur_cmd == mp_numeric_command) { + hlp = + "Variables in declarations must consist entirely of names and explicit subscripts\n" + "like 'x15a' aren't permitted. I'm going to discard the junk I found here, up to the\n" + "next comma or the end of the declaration."; + } else { + hlp = + "Variables in declarations must consist entirely of names and collective\n" + "subscripts, e.g., 'x[]a'. Are you trying to use a reserved word in a variable\n" + "name? I'm going to discard the junk I found here, up to the next comma or the end\n" + "of the declaration."; + } + mp_back_error( + mp, + "Illegal suffix of declared variable will be flushed", + hlp + ); + mp_get_x_next(mp); + mp->scanner_status = mp_flushing_state; + do { + get_t_next(mp); + @<Decrease the string reference count...@> + } while (cur_cmd < mp_comma_command); /* break on either |end_of_statement| or |comma| */ + mp->scanner_status = mp_normal_state; +} + +@ \MP's |main_control| procedure just calls |do_statement| repeatedly until +coming to the end of the user's program. Each execution of |do_statement| +concludes with |cur_cmd=semicolon|, |end_group|, or |stop|. + +@c +static void mp_main_control (MP mp) { + do { + mp_do_statement(mp); + if (cur_cmd == mp_end_group_command) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_error( + mp, + "Extra 'endgroup'", + "I'm not currently working on a 'begingroup', so I had better not try to end\n" + "anything." + ); + mp_flush_cur_exp(mp, new_expr); + } + } while (cur_cmd != mp_stop_command); +} + +int mp_run (MP mp) +{ + if (mp->history < mp_fatal_error_stop) { + mp_memory_free(mp->jump_buf); + mp->jump_buf = mp_memory_allocate(sizeof(jmp_buf)); + if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0) { + return mp->history; + } + mp_main_control(mp); /* come to life */ + mp_final_cleanup(mp); /* prepare for death */ + mp_close_files_and_terminate(mp); + } + return mp->history; +} + +@ This function allows setting of internals from an external source (like the +command line or a controlling application). + +It accepts two |char *|'s, even for numeric assignments when it calls |atoi| to +get an integer from the start of the string. + +@c +void mp_set_internal (MP mp, char *n, char *v, int isstring) +{ + size_t l = strlen(n); + char err[256]; + const char *errid = NULL; + if (l > 0) { + mp_sym p = mp_id_lookup(mp, n, l, 0); + if (p == NULL) { + errid = "variable does not exist"; + } else if (eq_type(p) != mp_internal_command) { + errid = "variable is not an internal"; + } else if ((internal_type(equiv(p)) == mp_string_type) && (isstring)) { + set_internal_string(equiv(p), mp_rts(mp, v)); + } else if ((internal_type(equiv(p)) == mp_known_type) && (! isstring)) { + int test = atoi(v); + if (test > 16383 && mp->math_mode == mp_math_scaled_mode) { + errid = "value is too large"; + } else if (test < -16383 && mp->math_mode == mp_math_scaled_mode) { + errid = "value is too small"; + } else { + number_clone(internal_value(equiv(p)), unity_t); + number_multiply_int(internal_value(equiv(p)), test); + } + } else { + errid = "value has the wrong type"; + } + } + if (errid != NULL) { + if (isstring) { + mp_snprintf(err, 256, "%s=\"%s\": %s, assignment ignored.", n, v, errid); + } else { + mp_snprintf(err, 256, "%s=%d: %s, assignment ignored.", n, atoi (v), errid); + } + mp_warn(mp, err); + } +} + +@ @<Exported function headers@>= +void mp_set_internal (MP mp, char *n, char *v, int isstring); + +@ For |mp_execute|, we need to define a structure to store the redirected input +and output. This structure holds the five relevant streams: the three +informational output streams, the PostScript generation stream, and the input +stream. These streams have many things in common, so it makes sense to give them +their own structure definition. + +\item{fptr} is a virtual file pointer +\item{data} is the data this stream holds +\item{cur} is a cursor pointing into |data| +\item{size} is the allocated length of the data stream +\item{used} is the actual length of the data stream + +There are small differences between input and output: |term_in| never uses +|used|, whereas the other four never use |cur|. + +@<Exported types@>= +# undef term_in +# undef term_out + +typedef struct mp_run_data +{ + void *term_in; /* dummy pointer */ + struct mp_edge_object *edges; +} mp_run_data; + +@ We need a function to clear an output stream, this is called at the beginning +of |mp_execute|. We also need one for destroying an output stream, this is called +just before a stream is (re)opened. + +@ The global instance contains a pointer instead of the actual structure even +though it is essentially static, because that makes it is easier to move the +object around. + +@<Global ...@>= +mp_run_data run_data; + +@ Another type is needed: the indirection will overload some of the file pointer +objects in the instance (but not all). For clarity, an indirect object is used +that wraps a |FILE *|. + +@<Types ... @>= +typedef struct File { + FILE *f; +} File; + +@ Here are all of the functions that need to be overloaded for |mp_execute|. + +@<Exported function headers@>= +void mplib_shipout_backend (MP mp, void *h); + +@ This is where we fill them all in. + +@<Set default function pointers@>= +mp->find_file = mp_find_file; +mp->open_file = mp_open_file; +mp->close_file = mp_close_file; +mp->write_file = mp_write_file; +mp->read_file = mp_read_file; +mp->run_script = mp_run_script; +mp->run_internal = mp_run_internal; +mp->run_logger = mp_run_logger; +mp->run_overload = mp_run_overload; +mp->run_error = mp_run_error; +mp->run_warning = mp_run_warning; +mp->make_text = mp_make_text; +mp->shipout_backend = mp_shipout_backend; + +mp->find_file_id = 0; +mp->run_script_id = 0; +mp->run_logger_id = 0; +mp->run_error_id = 0; +mp->run_warning_id = 0; +mp->run_overload_id = 0; +mp->make_text_id = 0; +mp->open_file_id = 0; + +@ This might change too. + +@c +void mplib_shipout_backend (MP mp, void *voidh) +{ + mp_edge_header_node h = (mp_edge_header_node) voidh; + mp_edge_object *hh = mp_gr_export (mp, h); + if (hh) { + mp_run_data *run = mp_rundata(mp); + if (run->edges == NULL) { + run->edges = hh; + } else { + mp_edge_object *p = run->edges; + while (p->next != NULL) { + p = p->next; + } + p->next = hh; + } + } +} + +@ Perhaps this is the most important API function in the library. + +@<Exported function ...@>= +extern mp_run_data *mp_rundata (MP mp); + +@ @c +mp_run_data *mp_rundata (MP mp) { + return &(mp->run_data); +} + +@ @<Finish non-interactive use@>= +mp_memory_free(mp->term_in); +mp->term_in = NULL; + +@ @<Start non-interactive work@>= +@<Initialize the output routines@> +mp->input_ptr = 0; +mp->max_in_stack = mp_file_bottom_text; +mp->in_open = mp_file_bottom_text; +mp->open_parens = 0; +mp->max_buf_stack = 0; +mp->param_ptr = 0; +mp->max_param_stack = 0; +start = loc = 0; +iindex = mp_file_bottom_text; +nloc = nstart = NULL; +mp->first = 0; +line = 0; +name = is_term; +mp->force_eof = 0; +if (mp->term_in == NULL) { + mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal); +} +mp->last = 0; +mp->scanner_status = mp_normal_state; +mp_fix_date_and_time(mp); +if (mp->random_seed == 0) { + mp->random_seed = (number_to_scaled(internal_value(mp_time_internal))/number_to_scaled(unity_t)) + + number_to_scaled(internal_value(mp_day_internal)); +} +init_randoms(mp->random_seed); +mp->selector = mp->interaction == mp_batch_mode ? mp_no_print_selector : mp_term_only_selector; +mp->history = mp_spotless; +if (mp->every_job_sym != NULL) { + set_cur_sym(mp->every_job_sym); + mp_back_input(mp); +} + +@ @c +int mp_execute (MP mp, const char *s, size_t l) +{ + (void) l; + if (mp->finished) { + return mp->history; + } else if (mp->history < mp_fatal_error_stop) { + mp_memory_free(mp->jump_buf); + mp->jump_buf = mp_memory_allocate(sizeof(jmp_buf)); + if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0) { + return mp->history; + } else { + mp->term_offset = 0; + mp->file_offset = 0; + if (mp->term_in == NULL) { + mp->term_in = (mp->open_file)(mp,"terminal", "r", mp_filetype_terminal); + mp->last = 0; + } + if (s && l > 0) { + (mp->write_file)(mp, mp->term_in, s); + } else { + /* we already filled the terminal buffer, so no longer: */ + /* + mp_final_cleanup(mp); + mp_close_files_and_terminate(mp); + return mp->history; + */ + } + if (mp->run_state == 0) { + /* mp->selector = mp_term_only_selector; */ + @<Start non-interactive work@> + } + mp->run_state = 1; + /* we grab one line */ + mp_input_ln(mp, mp->term_in); + mp_firm_up_the_line(mp); + mp->buffer[limit] = '%'; + mp->first = (size_t) (limit + 1); + loc = start; + do { + mp_do_statement(mp); + } while (cur_cmd != mp_stop_command); + mp_final_cleanup(mp); + mp_close_files_and_terminate(mp); + } + } + return mp->history; +} + +@ This function cleans up + +@c +int mp_finish (MP mp) +{ + int history = 0; + if (mp->finished || mp->history >= mp_fatal_error_stop) { + history = mp->history; + mp_free(mp); + } else { + mp_memory_free(mp->jump_buf); + mp->jump_buf = mp_memory_allocate(sizeof(jmp_buf)); + if (mp->jump_buf == NULL || setjmp (*(mp->jump_buf)) != 0) { + history = mp->history; + } else { + history = mp->history; + mp_final_cleanup(mp); /* prepare for death */ + } + mp_close_files_and_terminate(mp); + mp_free(mp); + } + return history; +} + +@ People may want to know the library version +@c +char *mp_metapost_version(void) { + return mp_strdup(metapost_version); +} + +@ @<Exported function headers@>= +int mp_run (MP mp); +int mp_execute (MP mp, const char *s, size_t l); +int mp_finish (MP mp); +char *mp_metapost_version (void); + +@ @<Put each...@>= +mp_primitive(mp, "end", mp_stop_command, 0); +@:end_}{|end| primitive@> +mp_primitive(mp, "dump", mp_stop_command, 1); +mp->frozen_dump = mp_frozen_primitive (mp, "dump", mp_stop_command, 1); +@:dump_}{|dump| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_stop_command: + return cur_mod == 0 ? "end" : "dump"; + +@* Commands. + +Let's turn now to statements that are classified as \quote {commands} because of their +imperative nature. We'll begin with simple ones, so that it will be clear how to +hook command processing into the |do_statement| routine; then we'll tackle the +tougher commands. + +Here's one of the simplest (when we have more seters thsi will change into one +function and a genericmessage). + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_max_knot_pool (MP mp); + +@ @c +void mp_do_max_knot_pool (MP mp) +{ + /* similar to the random seed setter */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + if (cur_cmd != mp_assignment_command) { + mp_back_error( + mp, + "Missing ':=' has been inserted", + "Always say 'maxknotpool := <numeric expression>'." + ); + @.Missing `:='@> + }; + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Unknown value will be ignored", + "Your expression was too random for me to handle, so I won't change the maximum\n" + "seed just now." + ); + @.Unknown value...ignored@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + /* the action */ + int p = (int) number_to_scaled (cur_exp_value_number) / 65536; + if (p > mp->max_knot_nodes) { + mp->max_knot_nodes = p; + } else if (p > max_num_knot_nodes) { + /* not now: flush excess nodes */ + } else { + /* we always keep the minimum */ + } + } +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_random_seed (MP mp); + +@ @c +void mp_do_random_seed (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + if (cur_cmd != mp_assignment_command) { + mp_back_error( + mp, + "Missing ':=' has been inserted", + "Always say 'randomseed := <numeric expression>'." + ); + @.Missing `:='@> + }; + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_known_type) { + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Unknown value will be ignored", + "Your expression was too random for me to handle, so I won't change the random\n" + "seed just now." + ); + @.Unknown value...ignored@> + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + @<Initialize the random seed to |cur_exp|@> + } +} + +@ @<Initialize the random seed to |cur_exp|@>= +init_randoms(number_to_scaled(cur_exp_value_number)); +if (mp->interaction < mp_silent_mode && (mp->selector == mp_log_only_selector || mp->selector == mp_term_and_log_selector)) { + int selector = mp->selector; + mp->selector = mp_log_only_selector; + mp_print_nl(mp, "{randomseed:="); + print_number(cur_exp_value_number); + mp_print_chr(mp, '}'); + mp_print_nl(mp, ""); + mp->selector = selector; +} + +@ And here's another simple one (somewhat different in flavor): + +@ @<Put each...@>= +mp_primitive(mp, "batchmode", mp_mode_command, mp_batch_mode); +@:mp_batch_mode_}{|batchmode| primitive@> +mp_primitive(mp, "nonstopmode", mp_mode_command, mp_nonstop_mode); +@:mp_nonstop_mode_}{|nonstopmode| primitive@> +mp_primitive(mp, "scrollmode", mp_mode_command, mp_scroll_mode); +@:mp_scroll_mode_}{|scrollmode| primitive@> +mp_primitive(mp, "errorstopmode", mp_mode_command, mp_error_stop_mode); +@:mp_error_stop_mode_}{|errorstopmode| primitive@> +mp_primitive(mp, "silentmode", mp_mode_command, mp_silent_mode); +@:mp_silent_mode_}{|silentmode| primitive@> + +@ @<Cases of |print_cmd_mod|...@>= +case mp_mode_command: + switch (m) { + case mp_batch_mode : return "batchmode"; + case mp_nonstop_mode : return "nonstopmode"; + case mp_scroll_mode : return "scrollmode"; + case mp_error_stop_mode: return "errorstopmode"; + default : return "silentmode"; + } +break; + +@ The |inner| and |outer| commands are only slightly harder. + +@ @<Put each...@>= +mp_primitive(mp, "inner", mp_protection_command, 0); +@:inner_}{|inner| primitive@> +mp_primitive(mp, "outer", mp_protection_command, 1); +@:outer_}{|outer| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_protection_command: + switch (m) { + case 0: return "inner"; + case 1: return "outer"; + } + break; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_protection (MP mp); + +@ @c +void mp_do_protection (MP mp) +{ +// int m = cur_mod; /* 0 to unprotect, 1 to protect */ + do { +// int t; /* the |eq_type| before we change it */ + mp_get_symbol(mp); +// t = eq_type(cur_sym); +// switch(m) { +// case 0: +// if (t >= mp_outer_tag_command) { +// set_eq_type(cur_sym, (t - mp_outer_tag_command)); +// } +// break; +// case 1: +// if (t < mp_outer_tag_command) { +// set_eq_type(cur_sym, (t + mp_outer_tag_command)); +// } +// break; +// } + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); +} + +@ The |setproperty| command expects a numeric, followed by a color and then +a list of symbols (names) that get that numeric value as property value. We use +a plural because one can use bitsets. This property, when larger than zero, can +trigger a callback when |overloadmode| is other than zero. This mechanism is +quite experimental and used in \CONTEXT\ for protecting definitions. + +@ @<Put each...@>= +mp_primitive(mp, "setproperty", mp_property_command, 1); +@:setproperty_}{|setproperty| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_property_command: + return "setproperty"; + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_property (MP mp); + +@ @c +// mp_scan_numeric_value(mp, 0, &p); + +void mp_do_property (MP mp) +{ + int p = 0; + mp_get_x_next(mp); + mp_scan_primary(mp); + switch (mp->cur_exp.type) { + case mp_numeric_type: + case mp_known_type: + { + mp_back_input(mp); + p = (int) number_to_scaled (cur_exp_value_number) / 65536; // hm + } + break; + default: + mp_back_error(mp, "Bad property value", NULL); + break; + } + mp_get_x_next(mp); + if (cur_cmd == mp_colon_command) { + do { + mp_get_symbol(mp); + set_eq_property(cur_sym, p); + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); + } else { + mp_back_error(mp, "Bad property specification, colon expected", NULL); + } +} + +@ \MP\ never defines the tokens |(| and |)| to be primitives, but plain \MP\ +begins with the declaration `|delimiters| |()|'. Such a declaration assigns +the command code |left_delimiter| to |(| and |right_delimiter| to |)|; +the |equiv| of each delimiter is the hash address of its mate. + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_def_delims (MP mp); + +@ @c +void mp_def_delims (MP mp) +{ + mp_sym l_delim, r_delim; /* the new delimiter pair */ + mp_get_clear_symbol(mp); + l_delim = cur_sym; + mp_get_clear_symbol(mp); + r_delim = cur_sym; + set_eq_type(l_delim, mp_left_delimiter_command); + set_equiv_sym(l_delim, r_delim); + set_eq_type(r_delim, mp_right_delimiter_command); + set_equiv_sym(r_delim, l_delim); + mp_get_x_next(mp); +} + +@ Here is a procedure that is called when \MP\ has reached a point where some +right delimiter is mandatory. + +@<Declarations@>= +static void mp_check_delimiter (MP mp, mp_sym l_delim, mp_sym r_delim); + +@ @c +void mp_check_delimiter (MP mp, mp_sym l_delim, mp_sym r_delim) +{ + if (cur_cmd == mp_right_delimiter_command && equiv_sym(cur_sym) == l_delim) { + return; + } else if (cur_sym != r_delim) { + char msg[256]; + mp_snprintf(msg, 256, "Missing '%s' has been inserted", mp_str(mp, text(r_delim))); + @.Missing `)'@> + mp_back_error( + mp, + msg, + "I found no right delimiter to match a left one. So I've put one in, behind the\n" + "scenes; this may fix the problem." + ); + } else { + char msg[256]; + mp_snprintf(msg, 256, "The token '%s' is no longer a right delimiter", mp_str(mp, text(r_delim))); + @.The token...delimiter@> + mp_error( + mp, + msg, + "Strange: This token has lost its former meaning! I'll read it as a right\n" + "delimiter this time; but watch out, I'll probably miss it later." + ); + } +} + +@ The next four commands save or change the values associated with tokens. + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_statement (MP mp); +static void mp_do_interim (MP mp); + +@ @c +void mp_do_interim (MP mp) { + mp_get_x_next(mp); + if (cur_cmd != mp_internal_command) { + char msg[256]; + mp_snprintf(msg, 256, + "The token '%s' isn't an internal quantity", + (cur_sym == NULL ? "(%CAPSULE)" : mp_str(mp, text(cur_sym))) + ); + @.The token...quantity@> + mp_back_error(mp, msg, "Something like 'tracingonline' should follow 'interim'."); + } else { + mp_save_internal(mp, cur_mod); + mp_back_input(mp); + } + mp_do_statement(mp); +} + +@ The following procedure is careful not to undefine the left-hand symbol too +soon, lest commands like `{\tt let x=x}' have a surprising effect. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_let (MP mp); + +@ @c +void mp_do_let (MP mp) +{ + mp_sym l; /* hash location of the left-hand symbol */ + mp_get_symbol(mp); + l = cur_sym; + mp_get_x_next(mp); + if (cur_cmd != mp_equals_command && cur_cmd != mp_assignment_command) { + mp_back_error( + mp, + "Missing '=' has been inserted", + "You should have said 'let symbol = something'. But don't worry; I'll pretend that\n" + "an equals sign was present. The next token I read will be 'something'." + ); + @.Missing `='@> + } + mp_get_symbol(mp); + switch (cur_cmd) { + case mp_defined_macro_command: + case mp_primary_def_command: + case mp_secondary_def_command: + case mp_tertiary_def_command: + mp_add_mac_ref(cur_mod_node); + break; + default: + break; + } + mp_clear_symbol(mp, l, 0); + set_eq_type(l, cur_cmd); + switch (cur_cmd) { + case mp_tag_command: + set_equiv(l, 0); /* todo: this was |null| */ + break; + case mp_defined_macro_command: + case mp_primary_def_command: + case mp_secondary_def_command: + case mp_tertiary_def_command: + set_equiv_node(l, cur_mod_node); + break; + case mp_left_delimiter_command: + case mp_right_delimiter_command: + set_equiv_sym(l, equiv_sym(cur_sym)); + break; + default: + set_equiv(l, cur_mod); + break; + } + mp_get_x_next(mp); +} + +@ @<Declarations@>= +static void mp_do_new_internal (MP mp); + +@ @<Internal library ...@>= +void mp_grow_internals (MP mp, int l); + +@ @c +void mp_grow_internals (MP mp, int l) +{ + if (l > max_halfword) { + mp_confusion(mp, "out of memory"); /* can't be reached */ + } else { + mp_internal *internal = mp_memory_allocate((size_t) (l + 1) * sizeof(mp_internal)); + for (int k = 0; k <= l; k++) { + if (k <= mp->max_internal) { + memcpy(internal + k, mp->internal + k, sizeof(mp_internal)); + } else { + memset(internal + k, 0, sizeof(mp_internal)); + new_number(((mp_internal *)(internal + k))->v.data.n); + } + } + mp_memory_free(mp->internal); + mp->internal = internal; + mp->max_internal = l; + } +} + + +/* newinternal [numeric|string|boolean] [runscript] | [runscript] */ + +/* 0:allocate 1:push 2:pop 3:pushlogging 4:poplogging */ + +void mp_do_new_internal (MP mp) +{ + int the_type = mp_known_type; + int run_script = 0; + mp_get_next(mp); /* not mp_get_next(mp) because we don't want to expand runscript */ + if (cur_cmd == mp_type_name_command && cur_mod == mp_string_type_operation) { + the_type = mp_string_type; + } else if (cur_cmd == mp_type_name_command && cur_mod == mp_boolean_type_operation) { + the_type = mp_boolean_type; + } else if (cur_cmd == mp_type_name_command && cur_mod == mp_numeric_type_operation) { + the_type = mp_numeric_type; + } else if (! (cur_cmd == mp_type_name_command && cur_mod == mp_numeric_type_operation)) { + mp_back_input(mp); + } + if (mp_numeric_type == mp_known_type) { + /* We do as traditional MP does. */ + } else { + /* We have an explicit type and check for run_internal. */ + if (the_type == mp_numeric_type) { + the_type = mp_known_type; + } + mp_get_next(mp); /* not mp_get_next(mp) because we don't want to expand runscript */ + if (cur_cmd == mp_runscript_command) { + run_script = 1; /* run_internal */ + } else { + mp_back_input(mp); + } + } + do { + if (mp->int_ptr == mp->max_internal) { + mp_grow_internals(mp, (mp->max_internal + (mp->max_internal / 4))); + } + mp_get_clear_symbol(mp); + ++mp->int_ptr; + set_eq_type(cur_sym, mp_internal_command); + set_equiv(cur_sym, mp->int_ptr); + mp_memory_free(internal_name(mp->int_ptr)); + set_internal_name(mp->int_ptr, mp_strdup(mp_str(mp, text(cur_sym)))); + if (the_type == mp_string_type) { + set_internal_string(mp->int_ptr, mp_rts(mp,"")); + } else { + set_number_to_zero(internal_value(mp->int_ptr)); + } + set_internal_type(mp->int_ptr, the_type); + set_internal_run(mp->int_ptr, run_script); + if (run_script) { + mp->run_internal(mp, 0, mp->int_ptr, the_type, internal_name(mp->int_ptr)); + } + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); +} + +@ @<Dealloc variables@>= +for (int k = 0; k <= mp->max_internal; k++) { + free_number(mp->internal[k].v.data.n); + mp_memory_free(internal_name(k)); +} +mp_memory_free(mp->internal); + +@ The various |show| commands are distinguished by modifier fields in the +usual way. + +@<Enumeration types@>= +typedef enum mp_show_codes { + mp_show_token_code, /* show the meaning of a single token */ + mp_show_stats_code, /* show current memory and string usage */ + mp_show_code, /* show a list of expressions */ + mp_show_var_code, /* show a variable and its descendents */ + mp_show_dependencies_code, /* show dependent variables in terms of independents */ +} mp_show_codes; + +@ @<Put each...@>= +mp_primitive(mp, "showtoken", mp_show_command, mp_show_token_code); +@:show_token_}{|showtoken| primitive@> +mp_primitive(mp, "showstats", mp_show_command, mp_show_stats_code); +@:show_stats_}{|showstats| primitive@> +mp_primitive(mp, "show", mp_show_command, mp_show_code); +@:show_}{|show| primitive@> +mp_primitive(mp, "showvariable", mp_show_command, mp_show_var_code); +@:show_var_}{|showvariable| primitive@> +mp_primitive(mp, "showdependencies", mp_show_command, mp_show_dependencies_code); +@:show_dependencies_}{|showdependencies| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_show_command: + switch (m) { + case mp_show_token_code : return "showtoken"; + case mp_show_stats_code : return "showstats"; + case mp_show_code : return "show"; + case mp_show_var_code : return "showvariable"; + case mp_show_dependencies_code: return "showdependencies"; + } + break; + +@ The value of |cur_mod| controls the |verbosity| in the |print_exp| routine: if +it's |show_code|, complicated structures are abbreviated, otherwise they aren't. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_show (MP mp); + +@ @c +void mp_do_show (MP mp) +{ + do { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + mp_scan_expression(mp); + mp_print_nl(mp, ">> "); + @.>>@> + mp_print_exp(mp, NULL, 2); + mp_flush_cur_exp(mp, new_expr); + } while (cur_cmd == mp_comma_command); +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_disp_token (MP mp); + +@ @c +void mp_disp_token (MP mp) +{ + mp_print_nl(mp, "> "); + @.>\relax@> + if (cur_sym == NULL) { + /* Show a numeric or string or capsule token */ + switch (cur_cmd) { + case mp_numeric_command: + print_number(cur_mod_number); + break; + case mp_capsule_command: + mp_print_capsule(mp, cur_mod_node); + break; + default: + mp_print_chr(mp, '"'); + mp_print_mp_str(mp, cur_mod_str); + mp_print_chr(mp, '"'); + delete_str_ref(cur_mod_str); + break; + } + } else { + mp_print_mp_str(mp,text(cur_sym)); + mp_print_chr(mp, '='); + // if (eq_type(cur_sym) >= mp_outer_tag_command) { + // mp_print_str(mp, "(outer) "); + // } + mp_print_cmd_mod(mp, cur_cmd, cur_mod); + if (cur_cmd == mp_defined_macro_command) { + mp_print_ln(mp); + mp_show_macro (mp, cur_mod_node, NULL); + } + /* this avoids recursion between |show_macro| and |print_cmd_mod| */ + @^recursion@> + } +} + +@ The following cases of |print_cmd_mod| might arise in connection with +|disp_token|, although they don't necessarily correspond to primitive tokens. + +@<Cases of |print_cmd_...@>= +case mp_left_delimiter_command: +case mp_right_delimiter_command: + return c == mp_left_delimiter_command ? "left delimiter" : "right delimiter"; +case mp_tag_command: + return m == 0 ? "tag" : "variable"; +case mp_defined_macro_command: + return "macro:"; +case mp_primary_def_command: + return "primarydef"; +case mp_secondary_def_command: + return "secondarydef"; +case mp_tertiary_def_command: + return "tertiarydef"; +case mp_repeat_loop_command: + return "[repeat the loop]"; +case mp_internal_command: + return internal_name(m); + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_token (MP mp); + +@ @c +void mp_do_show_token (MP mp) +{ + do { + get_t_next(mp); + mp_disp_token(mp); + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_stats (MP mp); + +@ @c +void mp_do_show_stats (MP mp) +{ + mp_print_nl(mp, "Memory usage "); + @.Memory usage...@> + mp_print_int(mp, (int) mp->var_used); + mp_print_ln(mp); + mp_print_nl(mp, "String usage "); + mp_print_int(mp, (int) mp->strs_in_use); + mp_print_chr(mp, '&'); + mp_print_int(mp, (int) mp->pool_in_use); + mp_print_ln(mp); + mp_get_x_next(mp); +} + +@ Here's a recursive procedure that gives an abbreviated account of a variable, +for use by |do_show_var|. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_disp_var (MP mp, mp_node p); + +@ @c +void mp_disp_var (MP mp, mp_node p) +{ + if (mp_type(p) == mp_structured_type) { + /* Descend the structure */ + mp_node q = mp_get_attribute_head(p); + do { + mp_disp_var(mp, q); + q = mp_link(q); + } while (q != mp->end_attr); + q = mp_get_subscr_head(p); + while (mp_name_type(q) == mp_subscript_operation) { + mp_disp_var(mp, q); + q = mp_link(q); + } + } else if (mp_type(p) >= mp_unsuffixed_macro_type) { + /* Display a variable macro */ + mp_print_nl(mp, ""); + mp_print_variable_name(mp, p); + if (mp_type(p) > mp_unsuffixed_macro_type) { + mp_print_str(mp, "@@#"); /* |suffixed_macro| */ + } + mp_print_str(mp, "=macro:"); + mp_show_macro(mp, mp_get_value_node(p), NULL); + } else if (mp_type(p) != mp_undefined_type) { + mp_print_nl(mp, ""); + mp_print_variable_name(mp, p); + mp_print_chr(mp, '='); + mp_print_exp(mp, p, 0); + } +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_var (MP mp); + +@ @c +void mp_do_show_var (MP mp) +{ + do { + get_t_next(mp); + if (cur_sym != NULL && cur_sym_mod == 0 && cur_cmd == mp_tag_command) { + if (cur_mod != 0 || cur_mod_node != NULL) { + mp_disp_var(mp, cur_mod_node); + goto DONE; + } + } + mp_disp_token(mp); + DONE: + mp_get_x_next(mp); + } while (cur_cmd == mp_comma_command); +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_dependencies (MP mp); + +@ @c +void mp_do_show_dependencies (MP mp) +{ + /* link that runs through all dependencies */ + mp_value_node p = (mp_value_node) mp_link(mp->dep_head); + while (p != mp->dep_head) { + if (mp_interesting(mp, (mp_node) p)) { + mp_print_nl(mp, ""); + mp_print_variable_name(mp, (mp_node) p); + if (mp_type(p) == mp_dependent_type) { + mp_print_chr(mp, '='); + } else { + mp_print_str(mp, " = "); /* extra spaces imply proto-dependency */ + } + mp_print_dependency(mp, (mp_value_node) mp_get_dep_list(p), mp_type(p)); + } + p = (mp_value_node) mp_get_dep_list(p); + while (mp_get_dep_info(p) != NULL) + p = (mp_value_node) mp_link(p); + p = (mp_value_node) mp_link(p); + } + mp_get_x_next(mp); +} + +@ Finally we are ready for the procedure that governs all of the show commands. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_show_whatever (MP mp); + +@ @c +void mp_do_show_whatever (MP mp) +{ + if (mp->interaction == mp_error_stop_mode) { + wake_up_terminal(); + } + switch (cur_mod) { + case mp_show_token_code: + mp_do_show_token(mp); + break; + case mp_show_stats_code: + mp_do_show_stats(mp); + break; + case mp_show_code: + mp_do_show(mp); + break; + case mp_show_var_code: + mp_do_show_var(mp); + break; + case mp_show_dependencies_code: + mp_do_show_dependencies(mp); + break; + } + if (number_positive(internal_value(mp_showstopping_internal))) { + const char *hlp = NULL; + if (mp->interaction < mp_error_stop_mode) { + --mp->error_count; + } else { + hlp = "This isn't an error message; I'm just showing something."; + } + if (cur_cmd == mp_semicolon_command) { + mp_error(mp, "OK", hlp); + } else { + mp_back_error(mp, "OK", hlp); + mp_get_x_next(mp); + } + @.OK@> + } +} + +@ We have all kind of with variants. + +@<Enumeration types@>= +typedef enum mp_with_codes { + mp_with_pen_code, + mp_with_dashed_code, + mp_with_pre_script_code, + mp_with_post_script_code, + mp_with_stacking_code, + mp_with_no_model_code, + mp_with_grey_model_code, + mp_with_uninitialized_model_code, + mp_with_rgb_model_code, + mp_with_cmyk_model_code, + mp_with_linecap_code, + mp_with_linejoin_code, + mp_with_miterlimit_code, +} mp_with_codes; + +@ We use enums so that it looks better in the editor: + +@<Enumeration types@>= +typedef enum mp_add_codes { + mp_add_double_path_code, /* command modifier for |doublepath| */ + mp_add_contour_code, /* command modifier for |contour| */ + mp_add_also_code, /* command modifier for |also| */ +} mp_add_codes ; + +@ The |addto| command needs the following additional primitives: + +@<Put each...@>= +mp_primitive(mp, "doublepath", mp_thing_to_add_command, mp_add_double_path_code); +@:double_path_}{|doublepath| primitive@> +mp_primitive(mp, "contour", mp_thing_to_add_command, mp_add_contour_code); +@:contour_}{|contour| primitive@> +mp_primitive(mp, "also", mp_thing_to_add_command, mp_add_also_code); +@:also_}{|also| primitive@> +mp_primitive(mp, "withpen", mp_with_option_command, mp_with_pen_code); +@:with_pen_}{|withpen| primitive@> +mp_primitive(mp, "dashed", mp_with_option_command, mp_with_dashed_code); +@:dashed_}{|dashed| primitive@> +mp_primitive(mp, "withprescript", mp_with_option_command, mp_with_pre_script_code); +@:with_mp_pre_script_}{|withprescript| primitive@> +mp_primitive(mp, "withpostscript", mp_with_option_command, mp_with_post_script_code); +@:with_mp_post_script_}{|withpostscript| primitive@> +mp_primitive(mp, "withstacking", mp_with_option_command, mp_with_stacking_code); +@:with_mp_stacking_}{|withstacking| primitive@> +mp_primitive(mp, "withlinecap", mp_with_option_command, mp_with_linecap_code); +@:with_mp_linecap_}{|withlinecap| primitive@> +mp_primitive(mp, "withlinejoin", mp_with_option_command, mp_with_linejoin_code); +@:with_mp_linejoin_}{|withlinejoin| primitive@> +mp_primitive(mp, "withmiterlimit", mp_with_option_command, mp_with_miterlimit_code); +@:with_mp_miterlimit_}{|withmiterlimit| primitive@> +mp_primitive(mp, "withoutcolor", mp_with_option_command, mp_with_no_model_code); +@:with_color_}{|withoutcolor| primitive@> +mp_primitive(mp, "withgreyscale", mp_with_option_command, mp_with_grey_model_code); +@:with_color_}{|withgreyscale| primitive@> +mp_primitive(mp, "withcolor", mp_with_option_command, mp_with_uninitialized_model_code); +@:with_color_}{|withcolor| primitive@> +mp_primitive(mp, "withrgbcolor", mp_with_option_command, mp_with_rgb_model_code); +@:with_color_}{|withrgbcolor| primitive@> +mp_primitive(mp, "withcmykcolor", mp_with_option_command, mp_with_cmyk_model_code); +@:with_color_}{|withcmykcolor| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_thing_to_add_command: + switch (m) { + case mp_add_contour_code : return "contour"; + case mp_add_double_path_code: return "doublepath"; + case mp_add_also_code : return "also"; + } + break; + +case mp_with_option_command: + switch (m) { + case mp_with_pen_code : return "withpen"; + case mp_with_pre_script_code : return "withprescript"; + case mp_with_post_script_code : return "withpostscript"; + case mp_with_stacking_code : return "withstacking"; + case mp_with_no_model_code : return "withoutcolor"; + case mp_with_rgb_model_code : return "withrgbcolor"; + case mp_with_uninitialized_model_code: return "withcolor"; + case mp_with_cmyk_model_code : return "withcmykcolor"; + case mp_with_grey_model_code : return "withgreyscale"; + case mp_with_linecap_code : return "withlinecap"; + case mp_with_linejoin_code : return "withlinejoin"; + case mp_with_miterlimit_code : return "withmiterlimit"; + default : return "dashed"; + } + break; + +@ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and updates +the list of graphical objects starting at |p|. Each $\langle$with clause$\rangle$ +updates all graphical objects whose |type| is compatible. Other objects are +ignored. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_scan_with_list (MP mp, mp_node p, mp_node pp); + +@ Forcing the color to be between |0| and |unity| here guarantees that no picture +will ever contain a color outside the legal range for \ps\ graphics. + +@d make_cp_a_colored_object(cp,p) do { + cp = p; + while (cp != NULL) { + if (mp_has_color(cp)) { + break; + } else { + cp = mp_link(cp); + } + } +} while (0) + +@d set_color_val(A,B) do { + if (number_negative(A)) { + set_number_to_zero(A); + } else if (number_greater(A,unity_t)) { + set_number_to_unity(A); + } else { + number_clone(A, (B)); + } +} while (0) + +@ @<Declarations@>= +/* void mp_clear_color (MP mp, void *n); */ + +@ @c +/* void mp_clear_color (MP mp, void *n) +{ + set_number_to_zero(((mp_shape_node) n)->cyan); + set_number_to_zero(((mp_shape_node) n)->magenta); + set_number_to_zero(((mp_shape_node) n)->yellow); + set_number_to_zero(((mp_shape_node) n)->black); + mp_color_model(n) = mp_uninitialized_model; +} */ + +@ @c +static void complain_invalid_with_list (MP mp, mp_variable_type t) +{ + /* Complain about improper type */ + mp_value new_expr; + const char *hlp = NULL; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + switch (t) { + case mp_with_pre_script_code: + hlp = + "Next time say 'withprescript <known string expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_post_script_code: + hlp = + "Next time say 'withpostscript <known string expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_stacking_code: + hlp = + "Next time say 'withstacking <known numeric expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_dashed_code: + hlp = + "Next time say 'dashed <known picture expression>'; I'll ignore the bad 'with'\n" + "clause and look for another."; + break; + case mp_with_uninitialized_model_code: + hlp = + "Next time say 'withcolor <known color expression>'; I'll ignore the bad 'with'\n" + "clause and look for another."; + break; + case mp_with_rgb_model_code: + hlp = + "Next time say 'withrgbcolor <known color expression>'; I'll ignore the bad 'with'\n" + "clause and look for another."; + break; + case mp_with_cmyk_model_code: + hlp = + "Next time say 'withcmykcolor <known cmykcolor expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_grey_model_code: + hlp = + "Next time say 'withgreyscale <known numeric expression>'; I'll ignore the bad\n" + " with' clause and look for another."; + break; + case mp_with_linecap_code: + hlp = + "Next time say 'withlinecap <known numeric expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_linejoin_code: + hlp = + "Next time say 'withlinejoin <known numeric expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + case mp_with_miterlimit_code: + hlp = + "Next time say 'miterlimit <known numeric expression>'; I'll ignore the bad\n" + "'with' clause and look for another."; + break; + default: + hlp = + "Next time say 'withpen <known pen expression>'; I'll ignore the bad 'with' clause\n" + "and look for another."; + break; + } + mp_back_error(mp, "Improper type", hlp); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); +} + +void mp_scan_with_list (MP mp, mp_node p, mp_node pstop) +{ + mp_node cp = MP_VOID; /* can't we reuse some? */ + mp_node pp = MP_VOID; + mp_node dp = MP_VOID; + mp_node ap = MP_VOID; + mp_node bp = MP_VOID; + mp_node sp = MP_VOID; + mp_node spstop = MP_VOID; + mp_number ml; + int miterlimit = 0; + int linecap = -1; + int linejoin = -1; + while (cur_cmd == mp_with_option_command) { + /* |cur_mod| of the |with_option| (should match |cur_type|) */ + int t; + CONTINUE: + t = cur_mod; + mp_get_x_next(mp); + if (t != mp_with_no_model_code) { + mp_scan_expression(mp); + } + switch (t) { + case mp_with_uninitialized_model_code : + switch (mp->cur_exp.type) { + case mp_cmykcolor_type: + case mp_color_type: + case mp_known_type: + case mp_boolean_type: + { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (cp == MP_VOID) { + make_cp_a_colored_object(cp, p); + } + if (cp != NULL) { + /* Transfer a color from the current expression to object~|cp| */ + switch (mp->cur_exp.type) { + case mp_color_type: + { + /* Transfer a rgbcolor from the current expression to object~|cp| */ + mp_node q = mp_get_value_node(cur_exp_node); + mp_color_model(cp) = mp_rgb_model; + set_color_val(mp_red_color(cp), mp_get_value_number(mp_red_part(q))); + set_color_val(mp_green_color(cp), mp_get_value_number(mp_green_part(q))); + set_color_val(mp_blue_color(cp), mp_get_value_number(mp_blue_part(q))); + set_number_to_zero(mp_black_color(cp)); + } + break; + case mp_cmykcolor_type: + { + /* Transfer a cmykcolor from the current expression to object~|cp| */ + mp_node q = mp_get_value_node(cur_exp_node); + mp_color_model(cp) = mp_cmyk_model; + set_color_val(mp_cyan_color(cp), mp_get_value_number(mp_cyan_part(q))); + set_color_val(mp_magenta_color(cp), mp_get_value_number(mp_magenta_part(q))); + set_color_val(mp_yellow_color(cp), mp_get_value_number(mp_yellow_part(q))); + set_color_val(mp_black_color(cp), mp_get_value_number(mp_black_part(q))); + } + break; + case mp_known_type: + { + /* Transfer a greyscale from the current expression to object~|cp| */ + // mp_number qq; + // new_number_clone(qq, cur_exp_value_number); + mp_color_model(cp) = mp_grey_model; + set_number_to_zero(mp_cyan_color(cp)); + set_number_to_zero(mp_magenta_color(cp)); + set_number_to_zero(mp_yellow_color(cp)); + set_color_val(mp_grey_color(cp), cur_exp_value_number); + // set_color_val(mp_grey_color(cp), qq); + // free_number(qq); + } + break; + default: + switch (cur_exp_value_boolean) { + case mp_false_operation: + /* Transfer a noncolor from the current expression to object~|cp| */ + mp_color_model(cp) = mp_no_model; + break; + case mp_true_operation: + /* Transfer no color from the current expression to object~|cp| */ + mp_color_model(cp) = mp_uninitialized_model; + break; + default: + break; + } + set_number_to_zero(mp_cyan_color(cp)); + set_number_to_zero(mp_magenta_color(cp)); + set_number_to_zero(mp_yellow_color(cp)); + set_number_to_zero(mp_black_color(cp)); + break; + } + } + mp_flush_cur_exp(mp, new_expr); + } + break; + default: + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + break; + case mp_with_rgb_model_code: + if (mp->cur_exp.type != mp_color_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (cp == MP_VOID) { + make_cp_a_colored_object(cp, p); + } + if (cp != NULL) { + /* Transfer a rgbcolor from the current expression to ob ject~|cp| */ + mp_node q = mp_get_value_node(cur_exp_node); + mp_color_model(cp) = mp_rgb_model; + set_color_val(mp_red_color(cp), mp_get_value_number(mp_red_part(q))); + set_color_val(mp_green_color(cp), mp_get_value_number(mp_green_part(q))); + set_color_val(mp_blue_color(cp), mp_get_value_number(mp_blue_part(q))); + set_number_to_zero(mp_black_color(cp)); + } + mp_flush_cur_exp(mp, new_expr); + } + break; + case mp_with_cmyk_model_code: + if (mp->cur_exp.type != mp_cmykcolor_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (cp == MP_VOID) { + make_cp_a_colored_object(cp, p); + } + if (cp != NULL) { + /* Transfer a cmykcolor from the current expression to object~|cp| */ + mp_node q = mp_get_value_node(cur_exp_node); + mp_color_model(cp) = mp_cmyk_model; + set_color_val(mp_cyan_color(cp), mp_get_value_number(mp_cyan_part(q))); + set_color_val(mp_magenta_color(cp), mp_get_value_number(mp_magenta_part(q))); + set_color_val(mp_yellow_color(cp), mp_get_value_number(mp_yellow_part(q))); + set_color_val(mp_black_color(cp), mp_get_value_number(mp_black_part(q))); + } + mp_flush_cur_exp(mp, new_expr); + } + break; + case mp_with_grey_model_code: + if (mp->cur_exp.type != mp_known_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + if (cp == MP_VOID) { + make_cp_a_colored_object(cp, p); + } + if (cp != NULL) { + /* Transfer a greyscale from the current expression to object~|cp| */ + // mp_number qq; + // new_number_clone(qq, cur_exp_value_number); + mp_color_model(cp) = mp_grey_model; + set_number_to_zero(mp_cyan_color(cp)); + set_number_to_zero(mp_magenta_color(cp)); + set_number_to_zero(mp_yellow_color(cp)); + set_color_val(mp_grey_color(cp), cur_exp_value_number); + // set_color_val(mp_grey_color(cp), qq); + // free_number(qq); + } + mp_flush_cur_exp(mp, new_expr); + } + break; + case mp_with_no_model_code: + if (cp == MP_VOID) { + make_cp_a_colored_object(cp, p); + } + if (cp != NULL) { + /* Transfer a noncolor from the current expression to object~|cp| */ + mp_color_model(cp) = mp_no_model; + set_number_to_zero(mp_cyan_color(cp)); + set_number_to_zero(mp_magenta_color(cp)); + set_number_to_zero(mp_yellow_color(cp)); + set_number_to_zero(mp_grey_color(cp)); + } + break; + case mp_with_pen_code: + if (mp->cur_exp.type != mp_pen_type && mp->cur_exp.type != mp_nep_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else { + if (pp == MP_VOID) { + /* Make |pp| an object in list~|p| that needs a pen */ + pp = p; + while (pp != NULL) { + if (mp_has_pen(pp)) { + break; + } else { + pp = mp_link(pp); + } + } + } + if (pp != NULL) { + switch (mp_type(pp)) { + case mp_fill_node_type: + case mp_stroked_node_type: + if (mp_pen_ptr((mp_shape_node) pp) != NULL) { + mp_toss_knot_list(mp, mp_pen_ptr((mp_shape_node) pp)); + } + mp_pen_ptr((mp_shape_node) pp) = cur_exp_knot; + mp_pen_type((mp_shape_node) pp) = mp->cur_exp.type == mp_nep_type; + break; + default: + break; + } + mp->cur_exp.type = mp_vacuous_type; + } + } + break; + case mp_with_pre_script_code: + if (mp->cur_exp.type != mp_string_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else if (cur_exp_str->len) { + if (ap == MP_VOID) { + ap = p; + } + while ((ap != NULL) && (! mp_has_script(ap))) { + ap = mp_link(ap); + } + if (ap != NULL) { + if (mp_pre_script(ap) != NULL) { + int selector = mp->selector; + mp_string s = mp_pre_script(ap); /* for string cleanup after combining */ + mp->selector = mp_new_string_selector; + mp_str_room(mp, (int) (mp_pre_script(ap)->len + cur_exp_str->len + 2)); + mp_print_mp_str(mp, cur_exp_str); + mp_str_room(mp, 1); + mp_append_char(mp, 13); + mp_print_mp_str(mp, mp_pre_script(ap)); + mp_pre_script(ap) = mp_make_string(mp); + delete_str_ref(s); + mp->selector = selector; + } else { + mp_pre_script(ap) = cur_exp_str; + } + add_str_ref(mp_pre_script(ap)); + mp->cur_exp.type = mp_vacuous_type; + } + } + break; + case mp_with_post_script_code: + if (mp->cur_exp.type != mp_string_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } else if (cur_exp_str->len) { + if (bp == MP_VOID) { + bp = p; + } + while ((bp != NULL) && (! mp_has_script(bp))) { + bp = mp_link(bp); + } + if (bp != NULL) { + if (mp_post_script(bp) != NULL) { + int selector = mp->selector; + mp_string s = mp_post_script(bp); /* for string cleanup after combining */ + mp->selector = mp_new_string_selector; + mp_str_room(mp, (int) (mp_post_script(bp)->len + cur_exp_str->len + 2)); + mp_print_mp_str(mp, mp_post_script(bp)); + mp_str_room(mp, 1); + mp_append_char(mp, 13); + mp_print_mp_str(mp, cur_exp_str); + mp_post_script(bp) = mp_make_string(mp); + delete_str_ref(s); + mp->selector = selector; + } else { + mp_post_script(bp) = cur_exp_str; + } + add_str_ref(mp_post_script(bp)); + mp->cur_exp.type = mp_vacuous_type; + } + } + break; + case mp_with_stacking_code: + switch (mp->cur_exp.type) { + case mp_known_type: + { + if (sp == MP_VOID) { + sp = p; + } + if (pp && spstop == MP_VOID) { + spstop = pstop; + } + if (sp != NULL) { + mp_stacking(sp) = round_unscaled(cur_exp_value_number); + } + if (pp && spstop != NULL) { + mp_stacking(spstop) = round_unscaled(cur_exp_value_number); + } + /* free ? */ + mp->cur_exp.type = mp_vacuous_type; + } + break; + case mp_pair_type: + { + if (pp && mp_nice_pair(mp, cur_exp_node, mp->cur_exp.type)) { + if (sp == MP_VOID) { + sp = p; + } + if (spstop == MP_VOID) { + spstop = pstop; + } + if (sp != NULL) { + mp_stacking(sp) = round_unscaled(mp_get_value_number(mp_x_part(mp_get_value_node(cur_exp_node)))); + } + if (spstop != NULL) { + mp_stacking(spstop) = round_unscaled(mp_get_value_number(mp_y_part(mp_get_value_node(cur_exp_node)))); + } + /* free ? */ + mp->cur_exp.type = mp_vacuous_type; + } else { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + } + break; + default: + { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + } + break; + case mp_with_linecap_code: + switch (mp->cur_exp.type) { + case mp_known_type: + { + linecap = round_unscaled(cur_exp_value_number); + mp->cur_exp.type = mp_vacuous_type; + break; + } + default: + { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + } + break; + case mp_with_linejoin_code: + switch (mp->cur_exp.type) { + case mp_known_type: + { + linejoin = round_unscaled(cur_exp_value_number); + mp->cur_exp.type = mp_vacuous_type; + break; + } + default: + { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + } + break; + case mp_with_miterlimit_code: + switch (mp->cur_exp.type) { + case mp_known_type: + { + miterlimit = 1; + new_number_clone(ml, cur_exp_value_number); + mp->cur_exp.type = mp_vacuous_type; + break; + } + default: + { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + } + break; + case mp_with_dashed_code: + if (mp->cur_exp.type != mp_picture_type) { + complain_invalid_with_list(mp, t); + goto CONTINUE; + } + // fall through + default: + if (dp == MP_VOID) { + /* Make |dp| a stroked node in list~|p| */ + dp = p; + while (dp != NULL) { + if (mp_type(dp) == mp_stroked_node_type) { + break; + } else { + dp = mp_link(dp); + } + } + } + if (dp != NULL) { + if (mp_dash_ptr(dp) != NULL) { + mp_delete_edge_ref(mp, mp_dash_ptr(dp)); + } + mp_dash_ptr(dp) = (mp_node) mp_make_dashes(mp, (mp_edge_header_node) cur_exp_node); + set_number_to_unity(((mp_shape_node) dp)->dashscale); + mp->cur_exp.type = mp_vacuous_type; + } + break; + } + } + /* + Copy the information from objects |cp|, |pp|, and |dp| into the rest of + the list. These were > MP_VOID tests but can we rely on that one being + |1| which is hopefully not some used address. + */ + if (cp > MP_VOID) { + /* Copy |cp|'s color into the colored objects linked to~|cp| */ + mp_node q = mp_link(cp); + while (q != NULL) { + if (mp_has_color(q)) { + mp_shape_node q0 = (mp_shape_node) q; + mp_shape_node cp0 = (mp_shape_node) cp; + number_clone(q0->red, cp0->red); + number_clone(q0->green, cp0->green); + number_clone(q0->blue, cp0->blue); + number_clone(q0->black, cp0->black); + mp_color_model(q) = mp_color_model(cp); + } + q = mp_link(q); + } + } + if (pp > MP_VOID) { + /* Copy |mp_pen_ptr(pp)| into stroked and filled nodes linked to |pp| */ + mp_node q = mp_link(pp); + while (q != NULL) { + if (mp_has_pen(q)) { + switch (mp_type(q)) { + case mp_fill_node_type: + case mp_stroked_node_type: + if (mp_pen_ptr((mp_shape_node) q) != NULL) { + mp_toss_knot_list(mp, mp_pen_ptr((mp_shape_node) q)); + } + mp_pen_ptr((mp_shape_node) q) = mp_copy_pen(mp, mp_pen_ptr((mp_shape_node) pp)); + break; + default: + break; + } + } + q = mp_link(q); + } + } + if (dp > MP_VOID) { + /* Make stroked nodes linked to |dp| refer to |mp_dash_ptr(dp)| */ + mp_node q = mp_link(dp); + while (q != NULL) { + if (mp_type(q) == mp_stroked_node_type) { + if (mp_dash_ptr(q) != NULL) { + mp_delete_edge_ref(mp, mp_dash_ptr(q)); + } + mp_dash_ptr(q) = mp_dash_ptr(dp); + set_number_to_unity(((mp_shape_node) q)->dashscale); + if (mp_dash_ptr(q) != NULL) { + mp_add_edge_ref(mp, mp_dash_ptr(q)); + } + } + q = mp_link(q); + } + } + if (linecap >= 0 && linecap < mp_weird_linecap_code) { + mp_node q = p; + while (q != NULL) { + switch (mp_type(q)) { + case mp_fill_node_type: + case mp_stroked_node_type: + mp_set_linecap(q, linecap); + break; + default: + break; + } + q = mp_link(q); + } + } + if (linejoin >= 0 && linejoin < mp_weird_linejoin_code) { + mp_node q = p; + while (q != NULL) { + switch (mp_type(q)) { + case mp_fill_node_type: + case mp_stroked_node_type: + mp_set_linejoin(q, linejoin); + break; + default: + break; + } + q = mp_link(q); + } + } + if (miterlimit) { + mp_node q = p; + while (q != NULL) { + switch (mp_type(q)) { + case mp_fill_node_type: + case mp_stroked_node_type: + number_clone(mp_miterlimit(q), ml); + break; + default: + break; + } + q = mp_link(q); + } + free_number(ml); + } + if (! pp && sp > MP_VOID) { + mp_node q = mp_link(sp); + while (q != NULL) { + mp_stacking(q) = mp_stacking(sp); + q = mp_link(q); + } + } +} + +@ One of the things we need to do when we've parsed an |addto| or similar +command is find the header of a supposed |picture| variable, given a token list +for that variable. Since the edge structure is about to be updated, we use +|private_edges| to make sure that this is possible. + +@<Declare action procedures for use by |do_statement|@>= +static mp_edge_header_node mp_find_edges_var (MP mp, mp_node t); + +@ @c +mp_edge_header_node mp_find_edges_var (MP mp, mp_node t) +{ + mp_edge_header_node cur_edges = NULL; + mp_node p = mp_find_variable(mp, t); + if (p == NULL) { + char *msg = mp_obliterated(mp, t); + mp_back_error( + mp, + msg, + "It seems you did a nasty thing --- probably by accident, but nevertheless you\n" + "nearly hornswoggled me ... While I was evaluating the right-hand side of thisn" + "command, something happened, and the left-hand side is no longer a variable! So In" + "won't change anything." + ); + mp_memory_free(msg); + mp_get_x_next(mp); + } else if (mp_type(p) != mp_picture_type) { + char msg[256]; + mp_string sname; + int selector = mp->selector; + mp->selector = mp_new_string_selector; + mp_show_token_list(mp, t, NULL); + sname = mp_make_string(mp); + mp->selector = selector; + mp_snprintf(msg, 256, "Variable %s is the wrong type(%s)", mp_str(mp, sname), mp_type_string(mp_type(p))); + @.Variable x is the wrong type@> + delete_str_ref(sname); + mp_back_error( + mp, + msg, + "I was looking for a 'known' picture variable. So I'll not change anything just\n" + "now." + ); + mp_get_x_next(mp); + } else { + mp_set_value_node(p, (mp_node) mp_private_edges(mp, (mp_edge_header_node) mp_get_value_node(p))); + cur_edges = (mp_edge_header_node) mp_get_value_node(p); + } + mp_flush_node_list(mp, t); + return cur_edges; +} + +@ @<Put each...@>= +mp_primitive(mp, "clip", mp_bounds_command, mp_start_clip_node_type); +@:clip_}{|clip| primitive@> +mp_primitive(mp, "setgroup", mp_bounds_command, mp_start_group_node_type); +@:group_}{|group| primitive@> +mp_primitive(mp, "setbounds", mp_bounds_command, mp_start_bounds_node_type); +@:set_bounds_}{|setbounds| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_bounds_command: + switch (m) { + case mp_start_clip_node_type : return "clip"; + case mp_start_group_node_type : return "setgroup"; + case mp_start_bounds_node_type: return "setbounds"; + } + break; + +@ The following function parses the beginning of an |addto| or |clip| +command: it expects a variable name followed by a token with |cur_cmd = sep| and +then an expression. The function returns the token list for the variable and +stores the command modifier for the separator token in the global variable +|last_add_type|. We must be careful because this variable might get overwritten +any time we call |get_x_next|. + +@<Glob...@>= +int last_add_type; /* command modifier that identifies the last |addto| command */ + +@ @<Declare action procedures for use by |do_statement|@>= +static mp_node mp_start_draw_cmd (MP mp, int sep); + +@ @c +mp_node mp_start_draw_cmd (MP mp, int sep) +{ + mp_node lhv = NULL; /* variable to add to left */ + int add_type = 0; /* value to be returned in |last_add_type| */ + mp_get_x_next(mp); + mp->var_flag = sep; + mp_scan_primary(mp); + if (mp->cur_exp.type != mp_token_list_type) { + /* Abandon edges command because there's no variable */ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Not a suitable variable", + "At this point I needed to see the name of a picture variable. (Or perhaps you\n" + "have indeed presented me with one; I might have missed it, if it wasn't followed\n" + "by the proper token.) So I'll not change anything just now.\n" + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + lhv = cur_exp_node; + add_type = (int) cur_mod; + mp->cur_exp.type = mp_vacuous_type; + mp_get_x_next(mp); + mp_scan_expression(mp); + } + mp->last_add_type = add_type; + return lhv; +} + +@ Here is an example of how to use |start_draw_cmd|. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_bounds (MP mp); + +@ @c +void mp_do_bounds (MP mp) +{ + mp_edge_header_node lhe; + /* initial value of |cur_mod| */ + int c = cur_cmd; + int m = cur_mod; + /* variable on left, the corresponding edge structure */ + mp_node lhv = mp_start_draw_cmd(mp, mp_to_command); + if (lhv != NULL) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + lhe = mp_find_edges_var(mp, lhv); + if (lhe == NULL) { + new_number(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); + } else if (mp->cur_exp.type != mp_path_type) { + char msg[256]; + mp_disp_err(mp, NULL); + new_number(new_expr.data.n); + mp_snprintf(msg, 256, "Improper '%s'", mp_cmd_mod_string(mp, c, m)); + mp_back_error( + mp, + msg, + "This expression should have specified a known path. So I'll not change anything\n" + "just now." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else if (mp_left_type(cur_exp_knot) == mp_endpoint_knot) { + /* Complain about a non-cycle */ + mp_back_error( + mp, + "Not a cycle", + "That contour should have ended with '..cycle' or '&cycle'. So I'll not change\n" + "anything just now." + ); + mp_get_x_next(mp); + } else { + /* Make |cur_exp| into a |setbounds| or clipping path and add it to |lhe| */ + mp_node p = mp_new_bounds_node(mp, cur_exp_knot, (int) m); + mp_node pp; + int mm = 0; + switch (m) { + case mp_start_clip_node_type : mm = mp_stop_clip_node_type; break; + case mp_start_group_node_type : mm = mp_stop_group_node_type; break; + case mp_start_bounds_node_type: mm = mp_stop_bounds_node_type; break; + } + pp = mp_new_bounds_node(mp, NULL, mm); + mp_scan_with_list(mp, p, pp); + mp_link(p) = mp_link(mp_edge_list(lhe)); + mp_link(mp_edge_list(lhe)) = p; + if (mp_obj_tail(lhe) == mp_edge_list(lhe)) { + mp_obj_tail(lhe) = p; + } + mp_link(mp_obj_tail(lhe)) = pp; + mp_obj_tail(lhe) = pp; + mp_init_bbox(mp, lhe); + } + } +} + +@ The |do_add_to| procedure is a little like |do_clip| but there are a lot more +cases to deal with. + +@<Declare action procedures for use by |do_statement|@>= +static void mp_do_add_to (MP mp); + +@ @c +void mp_do_add_to (MP mp) +{ + mp_node lhv = mp_start_draw_cmd(mp, mp_thing_to_add_command); + if (lhv != NULL) { + mp_edge_header_node lhe; /* variable on left, the corresponding edge structure */ + mp_node p; /* the graphical object or list for |scan_with_list| to update */ + mp_edge_header_node e; /* an edge structure to be merged */ + int add_type = mp->last_add_type; /* |also_code|, |contour_code|, or |double_path_code| */ + if (add_type == mp_add_also_code) { + /* + Make sure the current expression is a suitable picture and set + |e| and |p| appropriately. Setting |p:=NULL| causes the + $\langle$with list$\rangle$ to be ignored; setting |e:=NULL| + prevents anything from being added to |lhe|. + */ + p = NULL; + e = NULL; + if (mp->cur_exp.type != mp_picture_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Improper 'addto'", + "This expression should have specified a known picture. So I'll not change\n" + "anything just now." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + e = mp_private_edges(mp, (mp_edge_header_node) cur_exp_node); + mp->cur_exp.type = mp_vacuous_type; + p = mp_link(mp_edge_list(e)); + } + } else { + /* + Create a graphical object |p| based on |add_type| and the current + expression. In this case |add_type<>also_code| so setting + |p:=NULL| suppresses future attempts to add to the edge + structure. + */ + e = NULL; + p = NULL; + if (mp->cur_exp.type == mp_pair_type) { + mp_pair_to_path(mp); + } + if (mp->cur_exp.type != mp_path_type) { + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_disp_err(mp, NULL); + mp_back_error( + mp, + "Improper 'addto'", + "This expression should have specified a known path. So I'll not change anything\n" + "just now." + ); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else if (add_type != mp_add_contour_code) { + p = mp_new_shape_node(mp, cur_exp_knot, mp_stroked_node_type); + mp->cur_exp.type = mp_vacuous_type; + } else if (mp_left_type(cur_exp_knot) == mp_endpoint_knot) { + /* Complain about a non-cycle */ + mp_back_error( + mp, + "Not a cycle", + "That contour should have ended with '.. cycle' or '& cycle'. So I'll not change\n" + "anything just now." + ); + mp_get_x_next(mp); + } else { + p = mp_new_shape_node(mp, cur_exp_knot, mp_fill_node_type); + mp->cur_exp.type = mp_vacuous_type; + } + } + mp_scan_with_list(mp, p, NULL); + /* Use |p|, |e|, and |add_type| to augment |lhv| as requested */ + lhe = mp_find_edges_var(mp, lhv); + if (lhe == NULL) { + if ((e == NULL) && (p != NULL)) { + e = mp_toss_gr_object(mp, p); + } + if (e != NULL) { + mp_delete_edge_ref(mp, e); + } + } else if (add_type == mp_add_also_code) { + if (e != NULL) { + /* Merge |e| into |lhe| and delete |e| */ + if (mp_link(mp_edge_list(e)) != NULL) { + mp_link(mp_obj_tail(lhe)) = mp_link(mp_edge_list(e)); + mp_obj_tail(lhe) = mp_obj_tail(e); + mp_obj_tail(e) = mp_edge_list(e); + mp_link(mp_edge_list(e)) = NULL; + mp_flush_dash_list(mp, lhe); + } + mp_toss_edges(mp, e); + } + } else if (p != NULL) { + mp_link(mp_obj_tail(lhe)) = p; + mp_obj_tail(lhe) = p; + if (add_type == mp_add_double_path_code) { + if (mp_pen_ptr((mp_shape_node) p) == NULL) { + mp_pen_ptr((mp_shape_node) p) = mp_get_pen_circle(mp, &zero_t); + } + } + } + } +} + +@ @<Declare action procedures for use by |do_statement|@>= +@<Declare the output procedures@> +static void mp_do_ship_out (MP mp); + +@ @c +void mp_do_ship_out (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_picture_type) { + mp_disp_err(mp, NULL); + set_number_to_zero(new_expr.data.n); + mp_back_error(mp, "Not a known picture", "I can only output known pictures."); + mp_get_x_next(mp); + mp_flush_cur_exp(mp, new_expr); + } else { + mp_ship_out(mp, cur_exp_node); + set_number_to_zero(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); + } +} + +@ The |everyjob| command simply assigns a nonzero value to the global variable +|every_job_sym|. + +@ @<Glob...@>= +mp_sym every_job_sym; + +@ @<Set init...@>= +mp->every_job_sym = NULL; + +@ Finally, we have only the \quote {message} commands remaining. + +@d message_code 0 +@d err_message_code 1 +@d err_help_code 2 + +@<Put each...@>= +mp_primitive(mp, "message", mp_message_command, message_code); +@:message_}{|message| primitive@> +mp_primitive(mp, "errmessage", mp_message_command, err_message_code); +@:err_message_}{|errmessage| primitive@> +mp_primitive(mp, "errhelp", mp_message_command, err_help_code); +@:err_help_}{|errhelp| primitive@> + +@ @<Cases of |print_cmd...@>= +case mp_message_command: + if (m < err_message_code) { + return "message"; + } else if (m == err_message_code) { + return "errmessage"; + } else { + return "errhelp"; + } + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_message (MP mp); +static void mp_no_string_err (MP mp, const char *s); + +@ @c +void mp_do_message (MP mp) +{ + mp_value new_expr; + int m = cur_mod; /* the type of message */ + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_string_type) { + mp_no_string_err(mp, "A message should be a known string expression."); + } else { + switch (m) { + case message_code: + mp_print_nl(mp, ""); + mp_print_mp_str(mp, cur_exp_str); + break; + case err_message_code: + @<Print string |cur_exp| as an error message@> + break; + case err_help_code: + @<Save string |cur_exp| as the |err_help|@> + break; + } + } + set_number_to_zero(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); +} + +static void mp_no_string_err (MP mp, const char *s) +{ + mp_disp_err(mp, NULL); + mp_back_error(mp, "Not a string", s); + @.Not a string@> + mp_get_x_next(mp); +} + +@ The global variable |err_help| is zero when the user has most recently given an +empty help string, or if none has ever been given. + +@<Save string |cur_exp| as the |err_help|@>= +{ + if (mp->err_help != NULL) { + delete_str_ref(mp->err_help); + } if (cur_exp_str->len == 0) { + mp->err_help = NULL; + } else { + mp->err_help = cur_exp_str; + add_str_ref(mp->err_help); + } +} + +@ If |errmessage| occurs often in |mp_scroll_mode|, without user-defined +|errhelp|, we don't want to give a long help message each time. So we give a +verbose explanation only once. + +@<Glob...@>= +int long_help_seen; /* has the long |\\errmessage| help been used? */ + +@ @<Set init...@>= +mp->long_help_seen = 0; + +@ @<Print string |cur_exp| as an error message@>= +{ + char msg[256]; + mp_snprintf(msg, 256, "%s", mp_str(mp, cur_exp_str)); + if (mp->err_help != NULL) { + mp->use_err_help = 1; + mp_back_error(mp, msg, NULL); + } else if (mp->long_help_seen) { + mp_back_error(mp, msg, "(That was another 'errmessage'.)"); + } else { + @^Marple, Jane@> + if (mp->interaction < mp_error_stop_mode) { + mp->long_help_seen = 1; + } + mp_back_error( + mp, + msg, + "This error message was generated by an 'errmessage' command, so I can't give any\n" + "explicit help. Pretend that you're Miss Marple: Examine all clues, and deduce the\n" + "truth by inspired guesses." + ); + } + mp_get_x_next(mp); + mp->use_err_help = 0; +} + +@ @<Declare action procedures for use by |do_statement|@>= +static void mp_do_write (MP mp); +static void mp_do_write_string (MP mp, mp_string t); + +@ @c +void mp_do_write (MP mp) +{ + mp_value new_expr; + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_string_type) { + mp_no_string_err(mp, "The text to be written should be a known string expression"); + } else if (cur_cmd != mp_to_command) { + mp_back_error(mp, "Missing 'to' clause", "A write command should end with 'to <filename>'"); + mp_get_x_next(mp); + } else { + mp_string t = cur_exp_str; /* the line of text to be written */ + mp->cur_exp.type = mp_vacuous_type; + mp_get_x_next(mp); + mp_scan_expression(mp); + if (mp->cur_exp.type != mp_string_type) { + mp_no_string_err(mp, "I can\'t write to that file name. It isn't a known string"); + } else { + mp_do_write_string(mp, t); + } + } + set_number_to_zero(new_expr.data.n); + mp_flush_cur_exp(mp, new_expr); +} + +static void mp_do_write_string (MP mp, mp_string t) +{ + char *fn = mp_str(mp, cur_exp_str); + int n = mp->write_files; + int n0 = mp->write_files; + while (mp_strcmp(fn, mp->wr_fname[n]) != 0) { + if (n == 0) { + /* bottom reached */ + if (n0 == mp->write_files) { + if (mp->write_files < mp->max_write_files) { + ++mp->write_files; + } else { + int l = mp->max_write_files + (mp->max_write_files / 4); + void **wr_file = mp_memory_allocate((size_t) (l + 1) * sizeof(void *)); + char **wr_fname = mp_memory_allocate((size_t) (l + 1) * sizeof(char *)); + for (int k = 0; k <= l; k++) { + if (k <= mp->max_write_files) { + wr_file[k] = mp->wr_file[k]; + wr_fname[k] = mp->wr_fname[k]; + } else { + wr_file[k] = 0; + wr_fname[k] = NULL; + } + } + mp_memory_free(mp->wr_file); + mp_memory_free(mp->wr_fname); + mp->max_write_files = l; + mp->wr_file = wr_file; + mp->wr_fname = wr_fname; + } + } + n = n0; + mp_open_write_file(mp, fn, n); + } else { + --n; + if (mp->wr_fname[n] == NULL) { + n0 = n; + } + } + } + if (mp_str_vs_str(mp, t, mp->eof_line) == 0) { + (mp->close_file)(mp, mp->wr_file[n]); + mp_memory_free(mp->wr_fname[n]); + mp->wr_fname[n] = NULL; + if (n == mp->write_files - 1) { + mp->write_files = n; + } + } else { + int selector = mp->selector; + mp->selector = n + mp_first_file_selector; + mp_print_mp_str(mp, t); + mp_print_ln(mp); + mp->selector = selector; + } +} + +@ @<Initialize table entries@>= +mp->inf_val = mp_new_value_node(mp); +mp_set_value_number(mp->inf_val, fraction_four_t); + +@ @<Free table entries@>= +mp_free_value_node(mp, mp->inf_val); + +@ The smallest |d| such that a given list can be covered with |m| intervals is +determined by the |threshold| routine, which is sort of an inverse to +|min_cover|. The idea is to increase the interval size rapidly until finding the +range, then to go sequentially until the exact borderline has been discovered. + +@ Heights, depths, and italic corrections are different from widths not only +because their list length is more severely restricted, but also because zero +values do not need to be put into the list + +@ @<Initialize table entries@>= +mp->zero_val = mp_new_value_node(mp); +mp_set_value_number(mp->zero_val, zero_t); + +@ @<Free table entries@>= +mp_free_value_node(mp, mp->zero_val); + +@ To print |scaled| value to PDF output we need some subroutines to ensure +accurary. + +@d max_integer 0x7FFFFFFF /* $2^{31}-1$ */ + +@<Glob...@>= +int ten_pow[10]; /* $10^0..10^9$ */ +int scaled_out; /* amount of |scaled| that was taken out in |divide_scaled| */ + +@ @<Set init...@>= +mp->ten_pow[0] = 1; +for (int i = 1; i <= 9; i++) { + mp->ten_pow[i] = 10 * mp->ten_pow[i - 1]; +} + +@* Shipping pictures out. + +The |ship_out| procedure, to be described below, is given a pointer to an edge +structure. Originally teh output was targeted at \POSTSCRIPT\ but the library +has no backend. It privides the result as a structure that reflects the original +\POSTSCRIPT\ backend. We could use more direct methods but for now we follow the +route with an intermediate. Actually, it's that intermediate that is kind of +the standard output \API. We no longer report the shipped outfigure because the +backend can do that, but we keep the number. + +@<Declare the output procedures@>= +static void mp_ship_out (MP mp, mp_node h); + +@ Some of these types are already used earlier. + +@<Exported types@>= +typedef struct mp_color { + double a_val; /* r or c */ + double b_val; /* g or m */ + double c_val; /* b or y */ + double d_val; /* k */ +} mp_color; + +typedef struct mp_dash_object { + double offset; + double *array; +} mp_dash_object; + +/* + This mp_graphic_object gets cast onto the fill and stroke. For some reason + we don't distinguish between start and stop here. +*/ + +typedef struct mp_graphic_object { + int type; + int stacking; + struct mp_graphic_object *next; +} mp_graphic_object; + +typedef struct mp_shape_object { + int type; + int stacking; + struct mp_graphic_object *next; + char *pre_script; + char *post_script; + size_t pre_length; + size_t post_length; + mp_color color; + mp_gr_knot path; + mp_gr_knot htap; + mp_gr_knot pen; + double miterlimit; + mp_dash_object *dash; + unsigned char color_model; + unsigned char linejoin; + unsigned char linecap; + unsigned char padding; /* pen_type */ +} mp_shape_object; + +typedef struct mp_start_object { + int type; + int stacking; + struct mp_graphic_object *next; + char *pre_script; + char *post_script; + size_t pre_length; + size_t post_length; + mp_gr_knot path; +} mp_start_object; + +typedef struct mp_stop_object { + int type; + int stacking; + struct mp_graphic_object *next; + char *pre_script; + char *post_script; + size_t pre_length; + size_t post_length; + mp_gr_knot path; +} mp_stop_object; + +typedef struct mp_edge_object { + struct mp_graphic_object *body; + struct mp_edge_object *next; + MP parent; + double minx; + double miny; + double maxx; + double maxy; + double width; + double height; + double depth; + double italic; + int charcode; + int padding; +} mp_edge_object; + +@d gr_next_knot(A) (A)->next +@d gr_originator(A) (A)->originator +@d mp_knotstate(A) (A)->state +@d gr_type(A) (A)->type +@d gr_link(A) (A)->next +@d gr_color_model(A) (A)->color_model +@d gr_red_val(A) (A)->color.a_val +@d gr_green_val(A) (A)->color.b_val +@d gr_blue_val(A) (A)->color.c_val +@d gr_cyan_val(A) (A)->color.a_val +@d gr_magenta_val(A) (A)->color.b_val +@d gr_yellow_val(A) (A)->color.c_val +@d gr_black_val(A) (A)->color.d_val +@d gr_grey_val(A) (A)->color.d_val +@d gr_path_ptr(A) (A)->path +@d gr_htap_ptr(A) (A)->htap +@d gr_pen_ptr(A) (A)->pen +@d gr_linejoin_val(A) (A)->linejoin +@d gr_linecap_val(A) (A)->linecap +@d gr_stacking_val(A) (A)->stacking +@d gr_miterlimit_val(A) (A)->miterlimit +@d gr_pre_script(A) (A)->pre_script +@d gr_post_script(A) (A)->post_script +@d gr_pre_length(A) (A)->pre_length +@d gr_post_length(A) (A)->post_length +@d gr_dash_ptr(A) (A)->dash + +@d mp_gr_export_color(q,p) +if (mp_color_model(p) == mp_uninitialized_model) { + gr_color_model(q) = number_to_scaled(internal_value(mp_default_color_model_internal))/65536; + gr_cyan_val(q) = 0; + gr_magenta_val(q) = 0; + gr_yellow_val(q) = 0; + gr_black_val(q) = gr_color_model(q) == mp_cmyk_model ? (number_to_scaled(unity_t)/65536.0) : 0; +} else { + gr_color_model(q) = mp_color_model(p); + gr_cyan_val(q) = number_to_double(p->cyan); + gr_magenta_val(q) = number_to_double(p->magenta); + gr_yellow_val(q) = number_to_double(p->yellow); + gr_black_val(q) = number_to_double(p->black); +} + +@d mp_gr_export_scripts(q,p) +if (mp_pre_script (p)) { + gr_pre_script(q) = mp_strndup((const char *) mp_pre_script(p)->str, mp_pre_script(p)->len); + gr_pre_length(q) = mp_pre_script(p)->len; +} +if (mp_post_script(p)) { + gr_post_script(q) = mp_strndup((const char *) mp_post_script(p)->str, mp_post_script(p)->len); + gr_post_length(q) = mp_post_script(p)->len; +} + +@ @c +struct mp_edge_object *mp_gr_export (MP mp, mp_edge_header_node h) +{ + mp_node p; /* the current graphical object */ + mp_edge_object *hh = mp_memory_allocate(sizeof(mp_edge_object)); /* the first graphical object */ + mp_graphic_object *hp = NULL; /* the current graphical object */ + mp_set_bbox(mp, h, 1); + hh->parent = mp; + hh->body = NULL; + hh->next = NULL; + hh->minx = number_to_double(h->minx); + hh->minx = fabs(hh->minx) < 0.00001 ? 0 : hh->minx; + hh->miny = number_to_double(h->miny); + hh->miny = fabs(hh->miny) < 0.00001 ? 0 : hh->miny; + hh->maxx = number_to_double(h->maxx); + hh->maxx = fabs(hh->maxx) < 0.00001 ? 0 : hh->maxx; + hh->maxy = number_to_double(h->maxy); + hh->maxy = fabs(hh->maxy) < 0.00001 ? 0 : hh->maxy; + hh->charcode = round_unscaled(internal_value(mp_char_code_internal)); + hh->width = number_to_double(internal_value(mp_char_wd_internal)); + hh->height = number_to_double(internal_value(mp_char_ht_internal)); + hh->depth = number_to_double(internal_value(mp_char_dp_internal)); + hh->italic = number_to_double(internal_value(mp_char_ic_internal)); + p = mp_link(mp_edge_list(h)); + while (p != NULL) { + mp_graphic_object *hq = mp_new_graphic_object(mp, (int) ((mp_type(p) - mp_fill_node_type) + 1)); + switch (mp_type(p)) { + /* todo: share code between fill and stroked */ + case mp_fill_node_type: + { + mp_number d_width; /* the current pen width */ + mp_shape_node p0 = (mp_shape_node) p; + mp_shape_object *tf = (mp_shape_object *) hq; + gr_pen_ptr(tf) = mp_export_knot_list(mp, mp_pen_ptr(p0)); + new_number(d_width); + mp_get_pen_scale(mp, &d_width, mp_pen_ptr(p0)); /* whats the point ? */ + free_number(d_width); + if ((mp_pen_ptr(p0) == NULL) || mp_pen_is_elliptical(mp_pen_ptr(p0))) { + gr_path_ptr(tf) = mp_export_knot_list(mp, mp_path_ptr(p0)); + } else { + mp_knot pc = mp_copy_path(mp, mp_path_ptr(p0)); + mp_knot pp = mp_make_envelope(mp, pc, mp_pen_ptr(p0), p0->linejoin, 0, &(p0->miterlimit)); + gr_path_ptr(tf) = mp_export_knot_list(mp, pp); + mp_toss_knot_list(mp, pp); + pc = mp_htap_ypoc(mp, mp_path_ptr(p0)); + pp = mp_make_envelope(mp, pc, mp_pen_ptr((mp_shape_node) p), p0->linejoin, 0, &(p0->miterlimit)); + gr_htap_ptr(tf) = mp_export_knot_list(mp, pp); + mp_toss_knot_list(mp, pp); + } + mp_gr_export_color(tf, p0); + mp_gr_export_scripts(tf, p); + gr_linejoin_val(tf) = p0->linejoin; + gr_stacking_val(tf) = p0->stacking; + gr_miterlimit_val(tf) = number_to_double(p0->miterlimit); + } + break; + case mp_stroked_node_type: + { + mp_number d_width; /* the current pen width */ + mp_shape_node p0 = (mp_shape_node) p; + mp_shape_object *ts = (mp_shape_object *) hq; + gr_pen_ptr(ts) = mp_export_knot_list(mp, mp_pen_ptr(p0)); + new_number(d_width); + mp_get_pen_scale(mp, &d_width, mp_pen_ptr(p0)); + if (mp_pen_is_elliptical(mp_pen_ptr(p0))) { + gr_path_ptr(ts) = mp_export_knot_list(mp, mp_path_ptr(p0)); + } else { + mp_knot pc = mp_copy_path(mp, mp_path_ptr(p0)); + int t = p0->linecap; + if (mp_left_type(pc) != mp_endpoint_knot) { + mp_left_type(mp_insert_knot(mp, pc, &(pc->x_coord), &(pc->y_coord))) = mp_endpoint_knot; + mp_right_type(pc) = mp_endpoint_knot; + pc = mp_next_knot(pc); + t = 1; + } + pc = mp_make_envelope(mp, pc, mp_pen_ptr(p0), p0->linejoin, (int) t, &(p0->miterlimit)); + gr_path_ptr(ts) = mp_export_knot_list(mp, pc); + mp_toss_knot_list(mp, pc); + } + mp_gr_export_color(ts, p0); + mp_gr_export_scripts(ts, p); + gr_linejoin_val(ts) = p0->linejoin; + gr_miterlimit_val(ts) = number_to_double(p0->miterlimit); + gr_linecap_val(ts) = p0->linecap; + gr_stacking_val(ts) = p0->stacking; + gr_dash_ptr(ts) = mp_export_dashes(mp, p0, &d_width); + free_number(d_width); + } + break; + case mp_start_clip_node_type: + case mp_start_group_node_type: + case mp_start_bounds_node_type: + { + mp_start_node p0 = (mp_start_node) p; + mp_start_object *tb = (mp_start_object *) hq; + gr_path_ptr(tb) = mp_export_knot_list(mp, mp_path_ptr((mp_start_node) p)); + gr_stacking_val(tb) = p0->stacking; + mp_gr_export_scripts(tb, p); + } + break; + case mp_stop_clip_node_type: + case mp_stop_group_node_type: + case mp_stop_bounds_node_type: + { + mp_stop_node p0 = (mp_stop_node) p; + mp_stop_object *tb = (mp_stop_object *) hq; + gr_stacking_val(tb) = p0->stacking; + } + break; + default: + break; + } + if (hh->body == NULL) { + hh->body = hq; + } else { + gr_link(hp) = hq; + } + hp = hq; + p = mp_link(p); + } + return hh; +} + +@ The code here comes from the psout.w file and is part of the stipped down +library for \LUAMETATEX. There is no backend code in this subset. For that you +need the official \METAPOST\ distribution. One way of making a stand alone image +is to wrap the code in a small \CONTEXT\ file and process it to \PDF, which then +can be converted to another image format. You can blame me for errors. + +@<MPlib export header stuff@>= +struct mp_edge_object *mp_gr_export (MP mp, mp_edge_header_node h); +mp_graphic_object *mp_new_graphic_object (MP mp, int type); +void mp_gr_toss_objects (mp_edge_object *hh); +void mp_gr_toss_object (mp_graphic_object *p); + +@ @c +static void mp_do_gr_toss_dashes (mp_dash_object *dl) { + if (dl) { + mp_memory_free(dl->array); + mp_memory_free(dl); + } +} + +@ @c +static void mp_do_gr_toss_knot_list (mp_gr_knot p) +{ + if (p) { + mp_gr_knot q = p; + do { + mp_gr_knot r = gr_next_knot(q); + mp_memory_free(q); + q = r; + } while (q != p); + } +} + +@ @c +mp_graphic_object *mp_new_graphic_object (MP mp, int type) +{ + mp_graphic_object *p; + size_t size; + (void) mp; + switch (type) { + case mp_fill_code: + case mp_stroked_code: + size = sizeof(mp_shape_object); + break; + case mp_start_clip_code: + case mp_start_group_code: + case mp_start_bounds_code: + size = sizeof(mp_start_object); + break; + default: + size = sizeof(mp_graphic_object); + break; + } + p = (mp_graphic_object *) mp_memory_allocate(size); + memset(p, 0, size); + gr_type(p) = type; + return p; +} + +@ @c +void mp_gr_toss_object (mp_graphic_object *p) +{ + switch (gr_type(p)) { + case mp_fill_code: + case mp_stroked_code: + { + mp_shape_object *o = (mp_shape_object *) p; + mp_memory_free(gr_pre_script(o)); + mp_memory_free(gr_post_script(o)); + mp_do_gr_toss_knot_list(gr_pen_ptr(o)); + mp_do_gr_toss_knot_list(gr_path_ptr(o)); + if (gr_htap_ptr(o)) { + mp_do_gr_toss_knot_list(gr_htap_ptr(o)); + } + if (gr_dash_ptr(o)) { + mp_do_gr_toss_dashes(gr_dash_ptr(o)); + } + } + break; + case mp_start_clip_code: + case mp_start_group_code: + case mp_start_bounds_code: + { + mp_start_object *o = (mp_start_object *) p; + mp_memory_free(gr_pre_script(o)); + mp_memory_free(gr_post_script(o)); + mp_do_gr_toss_knot_list(gr_path_ptr(o)); + } + break; + case mp_stop_clip_code: + case mp_stop_group_code: + case mp_stop_bounds_code: + break; + } + mp_memory_free(p); +} + +@ @c +void mp_gr_toss_objects (mp_edge_object *hh) +{ + mp_graphic_object *p = hh->body; + while (p) { + mp_graphic_object *q = gr_link(p); + mp_gr_toss_object(p); + p = q; + } + mp_memory_free(hh); +} + +@ This function is now nearly trivial. + +@c +void mp_ship_out (MP mp, mp_node h) { + (mp->shipout_backend)(mp, h); +} + +@ @<Declarations@>= +static void mp_shipout_backend (MP mp, void *h); + +@ We keep the template as comment: + +@c +static void mp_shipout_backend (MP mp, void *voidh) +{ + (void) mp; + (void) voidh; +} + +@ @<Exported types@>= +typedef void (*mp_backend_writer) (MP, void *); + +@ @<Option variables@>= +mp_backend_writer shipout_backend; + +@* Some extensions. + +Get a numeric value from \MP\ is not easy. We have to consider the macro and the +loops, as also the internal type (this is a first attempt, and more work is +needed). If we are inside a |for| loop, then the global |loop_ptr| is not null +and the other loops eventually nested are available by mean of |loop_ptr->link|. +The current numeric value is stored in |old_value|. + +@ @<Exported function headers@>= +void mp_scan_next_value (MP mp, int keep, int *token, int *mode, int *kind); +void mp_scan_expr_value (MP mp, int keep, int *kind); +void mp_scan_token_value (MP mp, int keep, int *token, int *mode, int *kind); +void mp_scan_symbol_value (MP mp, int keep, char **s, int expand); +void mp_scan_property_value (MP mp, int keep, int *kind, char **s, int *property, int *detail); + +int mp_skip_token_value (MP mp, int token); + +void mp_scan_numeric_value (MP mp, int primary, double *d); +void mp_scan_boolean_value (MP mp, int primary, int *b); +void mp_scan_string_value (MP mp, int primary, char **s, size_t *l); +void mp_scan_pair_value (MP mp, int primary, double *x, double *y); +void mp_scan_color_value (MP mp, int primary, double *r, double *g, double *b); +void mp_scan_cmykcolor_value (MP mp, int primary, double *c, double *m, double *y, double *k); +void mp_scan_transform_value (MP mp, int primary, double *x, double *y, double *xx, double *xy, double *yx, double *yy); +void mp_scan_path_value (MP mp, int primary, mp_knot *k); + +void mp_push_numeric_value (MP mp, double n); +void mp_push_integer_value (MP mp, int i); +void mp_push_boolean_value (MP mp, int b); +void mp_push_string_value (MP mp, const char *s, int l); +void mp_push_pair_value (MP mp, double x, double y); +void mp_push_color_value (MP mp, double r, double g, double b); +void mp_push_cmykcolor_value (MP mp, double c, double m, double y, double k); +void mp_push_transform_value (MP mp, double x, double y, double xx, double xy, double yx, double yy); +void mp_push_path_value (MP mp, mp_knot k); + +@ This is a lightweight version, one that also omits the quotes around strings. +When we scan we check the type anyway. We don't really have a list either. So we +only serialize symbolic names, strings and single tokens. + +@c +// void mp_scan_symbol_value (MP mp, int keep, char **s, int expand) +// { +// if (mp->extensions) { +// mp_node p; +// unsigned char *r = NULL; +// if (expand) { +// mp_get_x_next(mp); +// } else { +// mp_get_next(mp); +// } +// if (keep) { +// mp_back_input(mp); +// } +// *s = NULL; +// p = mp_cur_tok(mp); +// if (p) { +// /* simplified mp_show_token_list */ +// if (mp_type(p) == mp_symbol_node_type) { +// // if (mp_name_type(p) != mp_expr_operation && mp_name_type(p) != mp_suffix_operation && mp_name_type(p) != mp_text_operation) { +// mp_sym sr = mp_get_sym_sym(p); +// // if (sr != mp_collective_subscript) { +// mp_string rr = text(sr); +// if (rr && rr->str) { +// r = rr->str; +// } +// // } +// // } +// } else if (mp_name_type(p) == mp_token_operation) { +// if (mp_type(p) == mp_string_type) { +// r = mp_get_value_str(p)->str; +// } +// } +// } +// if (r) { +// *s = (char *) mp_strdup((char *) r); +// } else { +// *s = NULL; +// } +// } +// } + +void mp_scan_symbol_value (MP mp, int keep, char **s, int expand) +{ + if (mp->extensions) { + if (expand) { + mp_get_x_next(mp); + } else { + mp_get_next(mp); + } + if (keep) { + mp_back_input(mp); + } + if (cur_sym == NULL && (cur_sym_mod == 0 || cur_sym_mod == mp_normal_operation)) { + *s = NULL; + } else { + unsigned char *r = NULL; + mp_node p = mp_new_symbolic_node(mp); + mp_set_sym_sym(p, cur_sym); + mp_name_type(p) = cur_sym_mod; + if (mp_type(p) == mp_symbol_node_type) { + mp_sym sr = mp_get_sym_sym(p); + mp_string rr = text(sr); + if (rr && rr->str) { + r = rr->str; + } + } else if (mp_name_type(p) == mp_token_operation) { + if (mp_type(p) == mp_string_type) { + r = mp_get_value_str(p)->str; + } + } + mp_free_symbolic_node(mp, p); + if (r) { + *s = (char *) mp_strdup((char *) r); + } else { + *s = NULL; + } + } + } +} + +void mp_scan_property_value (MP mp, int keep, int *kind, char **str, int *property, int *detail) +{ + if (mp->extensions) { + mp_symbol_entry *entry; + mp_get_symbol(mp); + entry = cur_sym; + if (entry) { + mp_node node = entry->type == mp_tag_command ? entry->v.data.node : NULL; + *kind = entry->type; + *str = (char *) mp_strdup((char *) entry->text->str); + *property = entry->property; + if (node) { + *detail = node->type; + } + if (keep) { + mp_back_input(mp); + } + } + } +} + +void mp_scan_next_value (MP mp, int keep, int *token, int *mode, int *kind) +{ + if (mp->extensions) { + mp_get_next(mp); + if (keep) { + mp_back_input(mp); + } + *token = cur_cmd; + *mode = cur_mod; + *kind = mp->cur_exp.type; + } +} + +void mp_scan_expr_value (MP mp, int keep, int *kind) +{ + if (mp->extensions) { + mp_get_next(mp); + mp_scan_primary(mp); + *kind = mp->cur_exp.type; + if (keep) { + mp_back_input(mp); + mp_back_expr(mp); + } + } +} + +void mp_scan_token_value (MP mp, int keep, int *token, int *mode, int *kind) +{ + if (mp->extensions) { + mp_get_x_next(mp); + if (keep) { + mp_back_input(mp); + } + *token = cur_cmd; + *mode = cur_mod; + *kind = mp->cur_exp.type; + } +} + +int mp_skip_token_value (MP mp, int token) +{ + if (mp->extensions) { + mp_get_x_next(mp); + if (token == cur_cmd) { + return 1; + } else { + mp_back_input(mp); + } + } + return 0; +} + +static void mp_scan_something (MP mp, int primary) +{ + mp_get_x_next(mp); + switch (primary) { + case 0: mp_scan_expression(mp); break; + case 1: mp_scan_primary(mp); break; + case 2: mp_scan_secondary(mp); break; + case 3: mp_scan_tertiary(mp); break; + default: mp_scan_expression(mp); break; + } +} + +void mp_scan_numeric_value (MP mp, int primary, double *d) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_known_type) { + mp_back_input(mp); /* hm */ + } else { + mp_back_input(mp); /* hm */ + *d = number_to_double(cur_exp_value_number); + } + } +} + +# define mp_set_double_value(mp,target,what) \ +if (mp_type(what) == mp_known_type) { \ + *target = number_to_double(mp_get_value_number(what)); \ +} + +void mp_scan_pair_value (MP mp, int primary, double *x, double *y) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_pair_type) { + mp_back_input(mp); /* hm */ + } else { + mp_node p ; + mp_back_input(mp); /* hm */ + p = mp_get_value_node(cur_exp_node); + mp_set_double_value(mp, x, mp_x_part(p)); + mp_set_double_value(mp, y, mp_y_part(p)); + } + } +} + +void mp_scan_color_value (MP mp, int primary, double *r, double *g, double *b) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_color_type) { + mp_back_input(mp); /* hm */ + } else { + mp_node p ; + mp_back_input(mp); /* hm */ + p = mp_get_value_node(cur_exp_node); + mp_set_double_value(mp, r, mp_red_part(p)); + mp_set_double_value(mp, g, mp_green_part(p)); + mp_set_double_value(mp, b, mp_blue_part(p)); + } + } +} + +void mp_scan_cmykcolor_value (MP mp, int primary, double *c, double *m, double *y, double *k) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_cmykcolor_type) { + mp_back_input(mp); /* hm */ + } else { + mp_node p ; + mp_back_input(mp); /* hm */ + p = mp_get_value_node(cur_exp_node); + mp_set_double_value(mp, c, mp_cyan_part(p)); + mp_set_double_value(mp, m, mp_magenta_part(p)); + mp_set_double_value(mp, y, mp_yellow_part(p)); + mp_set_double_value(mp, k, mp_black_part(p)); + } + } +} + +void mp_scan_transform_value (MP mp, int primary, double *x, double *y, double *xx, double *xy, double *yx, double *yy) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_transform_type) { + mp_back_input(mp); /* hm */ + } else { + mp_node p ; + mp_back_input(mp); /* hm */ + p = mp_get_value_node(cur_exp_node); + mp_set_double_value(mp, x, mp_x_part(p)); + mp_set_double_value(mp, y, mp_y_part(p)); + mp_set_double_value(mp, xx, mp_xx_part(p)); + mp_set_double_value(mp, xy, mp_xy_part(p)); + mp_set_double_value(mp, yx, mp_yx_part(p)); + mp_set_double_value(mp, yy, mp_yy_part(p)); + } + } +} + +void mp_scan_path_value (MP mp, int primary, mp_knot *k) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_path_type && mp->cur_exp.type != mp_pen_type) { + mp_back_input(mp); /* hm */ + } else { + mp_back_input(mp); /* hm */ + *k = cur_exp_knot; + } + } +} + +void mp_scan_boolean_value (MP mp, int primary, int *b) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_boolean_type) { + mp_back_input(mp); /* hm */ + } else { + mp_back_input(mp); /* hm */ + *b = cur_exp_value_boolean == mp_true_operation ? 1 : 0 ; + } + } +} + +void mp_scan_string_value (MP mp, int primary, char **s, size_t *l) +{ + if (mp->extensions) { + mp_scan_something(mp, primary); + if (mp->cur_exp.type != mp_string_type) { + mp_back_input(mp); /* hm */ + *s = NULL ; + *l = 0; + } else { + mp_back_input(mp); /* hm */ + *s = (char *) cur_exp_str->str ; + *l = cur_exp_str->len; + } + } +} + +void mp_push_numeric_value (MP mp, double n) +{ + mp_number m; + new_number_from_double(mp, m, n); + mp->cur_exp.type = mp_known_type; + mp_set_cur_exp_value_number(mp, &m); + mp_back_expr(mp); +} + +void mp_push_integer_value (MP mp, int i) +{ + mp_number m; + new_number(m); + set_number_from_int(m, i); + mp->cur_exp.type = mp_known_type; + mp_set_cur_exp_value_number(mp, &m); + mp_back_expr(mp); +} + +void mp_push_boolean_value (MP mp, int b) +{ + mp->cur_exp.type = mp_boolean_type; + mp_set_cur_exp_value_boolean(mp, b ? mp_true_operation : mp_false_operation); + mp_back_expr(mp); +} + +void mp_push_string_value (MP mp, const char *s, int l) +{ + mp->cur_exp.type = mp_string_type; + mp_set_cur_exp_str(mp, mp_rtsl(mp, (char *) s, l)); + mp_back_expr(mp); +} + +void mp_push_pair_value (MP mp, double x, double y) +{ + /* + mp_value new_expr; + */ + mp_number px, py; + mp_node p = mp_new_value_node(mp); + mp_node v; + mp_init_pair_node(mp, p); + v = mp_get_value_node(p); + new_number_from_double(mp, px, x); + new_number_from_double(mp, py, y); + mp_type(mp_x_part(v)) = mp_known_type; + mp_type(mp_y_part(v)) = mp_known_type; + mp_set_value_number(mp_x_part(v), px); + mp_set_value_number(mp_y_part(v), py); + free_number(px); + free_number(py); + /* + memset(&new_expr, 0, sizeof(mp_value)); + new_number(new_expr.data.n); + new_expr.type = mp_type(p); + new_expr.data.node = p; + mp_flush_cur_exp(mp, new_expr); + mp->cur_exp.type = mp_pair_type; + mp_name_type(p) = mp_capsule_operation; + */ + mp_name_type(p) = mp_capsule_operation; + mp->cur_exp.type = mp_pair_type; + mp_set_cur_exp_node(mp, p); + mp_back_expr(mp); +} + +void mp_push_color_value (MP mp, double r, double g, double b) +{ + mp_number pr, pg, pb; + mp_node p = mp_new_value_node(mp); + mp_node v; + mp_init_color_node(mp, p, mp_color_type); + v = mp_get_value_node(p); + new_number_from_double(mp, pr, r); + new_number_from_double(mp, pg, g); + new_number_from_double(mp, pb, b); + mp_type(mp_red_part (v)) = mp_known_type; + mp_type(mp_green_part(v)) = mp_known_type; + mp_type(mp_blue_part (v)) = mp_known_type; + mp_set_value_number(mp_red_part (v), pr); + mp_set_value_number(mp_green_part(v), pg); + mp_set_value_number(mp_blue_part (v), pb); + free_number(pr); + free_number(pg); + free_number(pb); + mp_name_type(p) = mp_capsule_operation; + mp->cur_exp.type = mp_color_type; + mp_set_cur_exp_node(mp, p); + mp_back_expr(mp); +} + +void mp_push_cmykcolor_value (MP mp, double c, double m, double y, double k) +{ + mp_number pc, pm, py, pk; + mp_node p = mp_new_value_node(mp); + mp_node v; + mp_init_color_node(mp, p, mp_cmykcolor_type); + v = mp_get_value_node(p); + new_number_from_double(mp, pc, c); + new_number_from_double(mp, pm, m); + new_number_from_double(mp, py, y); + new_number_from_double(mp, pk, k); + mp_type(mp_cyan_part (v)) = mp_known_type; + mp_type(mp_magenta_part(v)) = mp_known_type; + mp_type(mp_yellow_part (v)) = mp_known_type; + mp_type(mp_black_part (v)) = mp_known_type; + mp_set_value_number(mp_cyan_part (v), pc); + mp_set_value_number(mp_magenta_part(v), pm); + mp_set_value_number(mp_yellow_part (v), py); + mp_set_value_number(mp_black_part (v), pk); + free_number(pc); + free_number(pm); + free_number(py); + free_number(pk); + mp_name_type(p) = mp_capsule_operation; + mp->cur_exp.type = mp_cmykcolor_type; + mp_set_cur_exp_node(mp, p); + mp_back_expr(mp); +} + +void mp_push_transform_value (MP mp, double x, double y, double xx, double xy, double yx, double yy) +{ + mp_number px, py, pxx, pxy, pyx, pyy ; + mp_node p = mp_new_value_node(mp); + mp_node v; + mp_init_transform_node(mp, p); + v = mp_get_value_node(p); + new_number_from_double(mp, px, x); + new_number_from_double(mp, py, y); + new_number_from_double(mp, pxx, xx); + new_number_from_double(mp, pxy, xy); + new_number_from_double(mp, pyx, yx); + new_number_from_double(mp, pyy, yy); + mp_type(mp_x_part (v)) = mp_known_type; + mp_type(mp_y_part (v)) = mp_known_type; + mp_type(mp_xx_part(v)) = mp_known_type; + mp_type(mp_xy_part(v)) = mp_known_type; + mp_type(mp_yx_part(v)) = mp_known_type; + mp_type(mp_yy_part(v)) = mp_known_type; + mp_set_value_number(mp_x_part (v), px); + mp_set_value_number(mp_y_part (v), py); + mp_set_value_number(mp_xx_part(v), pxx); + mp_set_value_number(mp_xy_part(v), pxy); + mp_set_value_number(mp_yx_part(v), pyx); + mp_set_value_number(mp_yy_part(v), pyy); + free_number(px); + free_number(py); + free_number(pxx); + free_number(pxy); + free_number(pyx); + free_number(pyy); + mp_name_type(p) = mp_capsule_operation; + mp->cur_exp.type = mp_transform_type; + mp_set_cur_exp_node(mp, p); + mp_back_expr(mp); +} + +void mp_push_path_value (MP mp, mp_knot k) +{ + mp->cur_exp.type = mp_path_type; + mp_set_cur_exp_knot(mp, k); + mp_back_expr(mp); +} + +@* The main program. + +This is it: the part of \MP\ that executes all those procedures we have written. + +Well---almost. We haven't put the parsing subroutines into the program yet; and +we'd better leave space for a few more routines that may have been forgotten. + +@c +@<Declare the basic parsing subroutines@> +@<Declare miscellaneous procedures that were declared |forward|@> + +@ Here we do whatever is needed to complete \MP's job gracefully on the local +operating system. The code here might come into play after a fatal error; it must +therefore consist entirely of \quote {safe} operations that cannot produce error +messages. For example, it would be a mistake to call |str_room| or |make_string| +at this time, because a call on |overflow| might lead to an infinite loop. +@^system dependencies@> + +Watch out: we also close all files when we do a subrun (execute) so that's why +we have this static closer. + +@ @<Declarations@>= +static void mp_close_files (MP mp); +static void mp_close_files_and_terminate (MP mp); + +@ @c +static void mp_close_files (MP mp) +{ + if (mp->rd_fname != NULL) { + for (int k = 0; k < (int) mp->read_files; k++) { + if (mp->rd_fname[k] != NULL) { + (mp->close_file)(mp, mp->rd_file[k]); + mp_memory_free(mp->rd_fname[k]); + mp->rd_fname[k] = NULL; + } + } + } + if (mp->wr_fname != NULL) { + for (int k = 0; k < (int) mp->write_files; k++) { + if (mp->wr_fname[k] != NULL) { + (mp->close_file)(mp, mp->wr_file[k]); + mp_memory_free(mp->wr_fname[k]); + mp->wr_fname[k] = NULL; + } + } + } +} + +void mp_close_files_and_terminate (MP mp) +{ + if (mp->finished) { + return; + } else { + mp_close_files(mp); + wake_up_terminal(); + mp_print_ln(mp); + mp->finished = 1; + } +} + +@ @<Dealloc ...@>= +mp_close_files(mp); +if (mp->rd_fname != NULL) { + mp_memory_free(mp->rd_file); + mp_memory_free(mp->rd_fname); + mp->rd_file = NULL; + mp->rd_fname = NULL; +} +if (mp->wr_fname != NULL) { + mp_memory_free(mp->wr_file); + mp_memory_free(mp->wr_fname); + mp->wr_file = NULL; + mp->wr_fname = NULL; +} + +@ We get to the |final_cleanup| routine when |end| or |dump| has been +scanned. + +@c +void mp_final_cleanup (MP mp) +{ + while (mp->input_ptr > 0) { + if (token_state) { + mp_end_token_list(mp); + } else { + mp_end_file_reading(mp); + } + } + while (mp->loop_ptr != NULL) { + mp_stop_iteration(mp); + } + if (mp->interaction < mp_silent_mode) { + while (mp->open_parens > 0) { + mp_print_str(mp, " )"); + --mp->open_parens; + } + } + while (mp->cond_ptr != NULL) { + mp_print_nl(mp, "(end occurred when "); + @.end occurred...@> + mp_print_cmd_mod(mp, mp_fi_or_else_command, mp->cur_if); + /* |if| or |elseif| or |else| */ + if (mp->if_line != 0) { + mp_print_str(mp, " on line "); + mp_print_int(mp, mp->if_line); + } + mp_print_str(mp, " was incomplete)"); + mp->if_line = mp_if_line_field(mp->cond_ptr); + mp->cur_if = mp_name_type(mp->cond_ptr); + mp->cond_ptr = mp_link(mp->cond_ptr); + } + if (mp->history != mp_spotless) { + if (((mp->history == mp_warning_issued) || (mp->interaction < mp_error_stop_mode))) { + if (mp->selector == mp_term_and_log_selector) { + mp->selector = mp_term_only_selector; + mp_print_nl(mp, "(see the transcript file for additional information)"); + @.see the transcript file...@> + mp->selector = mp_term_and_log_selector; + } + } + } +} + +@ @<Declarations@>= +static void mp_final_cleanup (MP mp); +static void mp_init_prim (MP mp); +static void mp_init_tab (MP mp); + +@ Initialize all the primitives. + +@c void mp_init_prim (MP mp) +{ + @<Put each...@> +} + +@ Initialize other tables: + +@c void mp_init_tab (MP mp) +{ + @<Initialize table entries@> +} + +@* Index. + +Here is where you can find all uses of each identifier in the program, with +underlined entries pointing to where the identifier was defined. If the +identifier is only one letter long, however, you get to see only the underlined +entries. {\sl All references are to section numbers instead of page numbers.} + +This index also lists error messages and other aspects of the program that you +might want to look up some day. For example, the entry for \quote {system +dependencies} lists all sections that should receive special attention from +people who are installing \MP\ in a new operating environment. A list of various +things that can't happen appears under ``this can't happen''. Approximately 25 +sections are listed under \quote {inner loop}; these account for more than 60\pct! of +\MP's running time, exclusive of input and output. |