diff options
Diffstat (limited to 'Build/source/texk/web2c/mp.web')
-rw-r--r-- | Build/source/texk/web2c/mp.web | 1946 |
1 files changed, 1578 insertions, 368 deletions
diff --git a/Build/source/texk/web2c/mp.web b/Build/source/texk/web2c/mp.web index 93481bc1598..1b159920d05 100644 --- a/Build/source/texk/web2c/mp.web +++ b/Build/source/texk/web2c/mp.web @@ -1,4 +1,4 @@ -% $Id: mp.web,v 1.5 2005/06/22 17:06:28 olaf Exp $ +% $Id: mp.web,v 1.8 2005/08/24 10:54:02 taco Exp $ % MetaPost, by John Hobby. Public domain. % Much of this program was copied with permission from MF.web Version 1.9 @@ -97,8 +97,8 @@ undergoes any modifications, so that it will be clear which version of @^extensions to \MP@> @^system dependencies@> -@d banner=='This is MetaPost, Version 0.901' {printed when \MP\ starts} -@d metapost_version=="0.901" +@d banner=='This is MetaPost, Version 0.980' {printed when \MP\ starts} +@d metapost_version=="0.980" @ Different \PASCAL s have slightly different conventions, and the present @!@:PASCAL H}{\ph@> @@ -401,6 +401,7 @@ because some fussy \PASCAL\ compilers will complain about redundant labels. @d found=40 {go here when you've found it} @d found1=41 {like |found|, when there's more than one per routine} @d found2=42 {like |found|, when there's more than two per routine} +@d found3=43 {like |found|, when there's more than three per routine} @d not_found=45 {go here when you've found nothing} @d common_ending=50 {go here when you want to merge with another branch} @@ -1423,63 +1424,21 @@ length followed by the string itself, and the information is recorded in @!init @!pool_file:alpha_file; {the string-pool file output by \.{TANGLE}} tini -@ @d bad_pool(#)==begin wake_up_terminal; write_ln(term_out,#); - a_close(pool_file); get_strings_started:=false; return; - end -@<Read the other strings...@>= -name_of_file:=pool_name; {we needn't set |name_length|} -if a_open_in(pool_file) then - begin c:=false; - repeat @<Read one string, but return |false| if the - string memory space is getting too tight for comfort@>; - until c; - a_close(pool_file); get_strings_started:=true; - end -else bad_pool('! I can''t read MP.POOL.') -@.I can't read MP.POOL@> - -@ @<Read one string...@>= -begin if eof(pool_file) then bad_pool('! MP.POOL has no check sum.'); -@.MP.POOL has no check sum@> -read(pool_file,m,n); {read two digits of string length} -if m='*' then @<Check the pool check sum@> -else begin if (xord[m]<"0")or(xord[m]>"9")or@| - (xord[n]<"0")or(xord[n]>"9") then - bad_pool('! MP.POOL line doesn''t begin with two digits.'); -@.MP.POOL line doesn't...@> - l:=xord[m]*10+xord[n]-"0"*11; {compute the length} - if pool_ptr+l+string_vacancies>pool_size then - bad_pool('! You have to increase POOLSIZE.'); -@.You have to increase POOLSIZE@> - if str_ptr+strings_vacant>=max_strings then - bad_pool('! You have to increase MAXSTRINGS.'); -@.You have to increase MAXSTRINGS@> - for k:=1 to l do - begin if eoln(pool_file) then m:=' '@+else read(pool_file,m); - append_char(xord[m]); - end; - read_ln(pool_file); g:=make_string; str_ref[g]:=max_str_ref; +@ @<Read the other strings...@>= + g := loadpoolstrings((pool_size-string_vacancies)); + if g=0 then begin + wake_up_terminal; write_ln(term_out,'! You have to increase POOLSIZE.'); + get_strings_started:=false; + return; end; -end + get_strings_started:=true; + @ The \.{WEB} operation \.{@@\$} denotes the value that should be at the end of this \.{MP.POOL} file; any other value means that the wrong pool file has been loaded. @^check sum@> -@<Check the pool check sum@>= -begin a:=0; k:=1; -loop@+ begin if (xord[n]<"0")or(xord[n]>"9") then - bad_pool('! MP.POOL check sum doesn''t have nine digits.'); -@.MP.POOL check sum...@> - a:=10*a+xord[n]-"0"; - if k=9 then goto done; - incr(k); read(pool_file,n); - end; -done: if a<>@$ then bad_pool('! MP.POOL doesn''t match; TANGLE me again.'); -@.MP.POOL doesn't match@> -c:=true; -end @* \[5] On-line and off-line printing. Messages that are sent to a user's terminal and to the transcript-log file @@ -1626,8 +1585,13 @@ log_only: begin wlog(xchr[s]); incr(file_offset); term_only: begin wterm(xchr[s]); incr(term_offset); if term_offset=max_print_line then print_ln; end; -ps_file_only: begin wps(xchr[s]); incr(ps_offset); - end; +ps_file_only: if s=13 then begin + wps_cr; ps_offset:=0; + end + else + begin + wps(xchr[s]); incr(ps_offset); + end; no_print: do_nothing; pseudo: if tally<trick_count then trick_buf[tally mod error_line]:=s; new_string: begin if pool_ptr>=max_pool_ptr then @@ -1907,9 +1871,10 @@ in reverse order, i.e., with |help_line[0]| appearing last. @!help_ptr:0..6; {the number of help lines present} @!use_err_help:boolean; {should the |err_help| string be shown?} @!err_help:str_number; {a string set up by \&{errhelp}} +@!filename_template:str_number; {a string set up by \&{filenametemplate}} @ @<Set init...@>= -help_ptr:=0; use_err_help:=false; err_help:=0; +help_ptr:=0; use_err_help:=false; err_help:=0; filename_template:=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 @@ -3982,7 +3947,8 @@ At any rate, here is the list, for future reference. @d message_command=27 {communicate to user (\&{message}, \&{errmessage})} @d every_job_command=28 {designate a starting token (\&{everyjob})} @d delimiters=29 {define a pair of delimiters (\&{delimiters})} -@d special_command=30 {output special info (\&{special})} +@d special_command=30 {output special info (\&{special}) + or font map info (\&{fontmapfile}, \&{fontmapline})} @d write_command=31 {write text to a file (\&{write})} @d type_name=32 {declare a type (\&{numeric}, \&{pair}, etc.} @d max_statement_command=type_name @@ -4083,16 +4049,17 @@ and |string_type| in that order. @d unknown_picture=picture_type+unknown_tag @d transform_type=12 {\&{transform} variable or capsule} @d color_type=13 {\&{color} variable or capsule} -@d pair_type=14 {\&{pair} variable or capsule} -@d numeric_type=15 {variable that has been declared \&{numeric} but not used} -@d known=16 {\&{numeric} with a known value} -@d dependent=17 {a linear combination with |fraction| coefficients} -@d proto_dependent=18 {a linear combination with |scaled| coefficients} -@d independent=19 {\&{numeric} with unknown value} -@d token_list=20 {variable name or suffix argument or text argument} -@d structured=21 {variable with subscripts and attributes} -@d unsuffixed_macro=22 {variable defined with \&{vardef} but no \.{\AT!\#}} -@d suffixed_macro=23 {variable defined with \&{vardef} and \.{\AT!\#}} +@d cmykcolor_type=14 {\&{cmykcolor} variable or capsule} +@d pair_type=15 {\&{pair} variable or capsule} +@d numeric_type=16 {variable that has been declared \&{numeric} but not used} +@d known=17 {\&{numeric} with a known value} +@d dependent=18 {a linear combination with |fraction| coefficients} +@d proto_dependent=19 {a linear combination with |scaled| coefficients} +@d independent=20 {\&{numeric} with unknown value} +@d token_list=21 {variable name or suffix argument or text argument} +@d structured=22 {variable with subscripts and attributes} +@d unsuffixed_macro=23 {variable defined with \&{vardef} but no \.{\AT!\#}} +@d suffixed_macro=24 {variable defined with \&{vardef} and \.{\AT!\#}} @# @d unknown_types==unknown_boolean,unknown_string, unknown_pen,unknown_picture,unknown_path @@ -4113,6 +4080,7 @@ picture_type:print("picture"); unknown_picture:print("unknown picture"); transform_type:print("transform"); color_type:print("color"); +cmykcolor_type:print("cmykcolor"); pair_type:print("pair"); known:print("known numeric"); dependent:print("dependent"); @@ -4145,8 +4113,13 @@ here; they will be explained in more detail later. @d red_part_sector=11 {|name_type| in the \&{redpart} of a node} @d green_part_sector=12 {|name_type| in the \&{greenpart} of a node} @d blue_part_sector=13 {|name_type| in the \&{bluepart} of a node} -@d capsule=14 {|name_type| in stashed-away subexpressions} -@d token=15 {|name_type| in a numeric token or string token} +@d cyan_part_sector=14 {|name_type| in the \&{redpart} of a node} +@d magenta_part_sector=15 {|name_type| in the \&{greenpart} of a node} +@d yellow_part_sector=16 {|name_type| in the \&{bluepart} of a node} +@d black_part_sector=17 {|name_type| in the \&{greenpart} of a node} +@d grey_part_sector=18 {|name_type| in the \&{bluepart} of a node} +@d capsule=19 {|name_type| in stashed-away subexpressions} +@d token=20 {|name_type| in a numeric token or string token} @ Primitive operations that produce values have a secondary identification code in addition to their command code; it's something like genera and species. @@ -4185,77 +4158,83 @@ values they test for. @d char_op=51 {operation code for \.{char}} @d length_op=52 {operation code for \.{length}} @d turning_op=53 {operation code for \.{turningnumber}} -@d x_part=54 {operation code for \.{xpart}} -@d y_part=55 {operation code for \.{ypart}} -@d xx_part=56 {operation code for \.{xxpart}} -@d xy_part=57 {operation code for \.{xypart}} -@d yx_part=58 {operation code for \.{yxpart}} -@d yy_part=59 {operation code for \.{yypart}} -@d red_part=60 {operation code for \.{redpart}} -@d green_part=61 {operation code for \.{greenpart}} -@d blue_part=62 {operation code for \.{bluepart}} -@d font_part=63 {operation code for \.{fontpart}} -@d text_part=64 {operation code for \.{textpart}} -@d path_part=65 {operation code for \.{pathpart}} -@d pen_part=66 {operation code for \.{penpart}} -@d dash_part=67 {operation code for \.{dashpart}} -@d sqrt_op=68 {operation code for \.{sqrt}} -@d m_exp_op=69 {operation code for \.{mexp}} -@d m_log_op=70 {operation code for \.{mlog}} -@d sin_d_op=71 {operation code for \.{sind}} -@d cos_d_op=72 {operation code for \.{cosd}} -@d floor_op=73 {operation code for \.{floor}} -@d uniform_deviate=74 {operation code for \.{uniformdeviate}} -@d char_exists_op=75 {operation code for \.{charexists}} -@d font_size=76 {operation code for \.{fontsize}} -@d ll_corner_op=77 {operation code for \.{llcorner}} -@d lr_corner_op=78 {operation code for \.{lrcorner}} -@d ul_corner_op=79 {operation code for \.{ulcorner}} -@d ur_corner_op=80 {operation code for \.{urcorner}} -@d arc_length=81 {operation code for \.{arclength}} -@d angle_op=82 {operation code for \.{angle}} -@d cycle_op=83 {operation code for \.{cycle}} -@d filled_op=84 {operation code for \.{filled}} -@d stroked_op=85 {operation code for \.{stroked}} -@d textual_op=86 {operation code for \.{textual}} -@d clipped_op=87 {operation code for \.{clipped}} -@d bounded_op=88 {operation code for \.{bounded}} -@d plus=89 {operation code for \.+} -@d minus=90 {operation code for \.-} -@d times=91 {operation code for \.*} -@d over=92 {operation code for \./} -@d pythag_add=93 {operation code for \.{++}} -@d pythag_sub=94 {operation code for \.{+-+}} -@d or_op=95 {operation code for \.{or}} -@d and_op=96 {operation code for \.{and}} -@d less_than=97 {operation code for \.<} -@d less_or_equal=98 {operation code for \.{<=}} -@d greater_than=99 {operation code for \.>} -@d greater_or_equal=100 {operation code for \.{>=}} -@d equal_to=101 {operation code for \.=} -@d unequal_to=102 {operation code for \.{<>}} -@d concatenate=103 {operation code for \.\&} -@d rotated_by=104 {operation code for \.{rotated}} -@d slanted_by=105 {operation code for \.{slanted}} -@d scaled_by=106 {operation code for \.{scaled}} -@d shifted_by=107 {operation code for \.{shifted}} -@d transformed_by=108 {operation code for \.{transformed}} -@d x_scaled=109 {operation code for \.{xscaled}} -@d y_scaled=110 {operation code for \.{yscaled}} -@d z_scaled=111 {operation code for \.{zscaled}} -@d in_font=112 {operation code for \.{infont}} -@d intersect=113 {operation code for \.{intersectiontimes}} -@d double_dot=114 {operation code for improper \.{..}} -@d substring_of=115 {operation code for \.{substring}} +@d color_model_part=54 {operation code for \.{colormodel}} +@d x_part=55 {operation code for \.{xpart}} +@d y_part=56 {operation code for \.{ypart}} +@d xx_part=57 {operation code for \.{xxpart}} +@d xy_part=58 {operation code for \.{xypart}} +@d yx_part=59 {operation code for \.{yxpart}} +@d yy_part=60 {operation code for \.{yypart}} +@d red_part=61 {operation code for \.{redpart}} +@d green_part=62 {operation code for \.{greenpart}} +@d blue_part=63 {operation code for \.{bluepart}} +@d cyan_part=64 {operation code for \.{cyanpart}} +@d magenta_part=65 {operation code for \.{magentapart}} +@d yellow_part=66 {operation code for \.{yellowpart}} +@d black_part=67 {operation code for \.{blackpart}} +@d grey_part=68 {operation code for \.{greypart}} +@d font_part=69 {operation code for \.{fontpart}} +@d text_part=70 {operation code for \.{textpart}} +@d path_part=71 {operation code for \.{pathpart}} +@d pen_part=72 {operation code for \.{penpart}} +@d dash_part=73 {operation code for \.{dashpart}} +@d sqrt_op=74 {operation code for \.{sqrt}} +@d m_exp_op=75 {operation code for \.{mexp}} +@d m_log_op=76 {operation code for \.{mlog}} +@d sin_d_op=77 {operation code for \.{sind}} +@d cos_d_op=78 {operation code for \.{cosd}} +@d floor_op=79 {operation code for \.{floor}} +@d uniform_deviate=80 {operation code for \.{uniformdeviate}} +@d char_exists_op=81 {operation code for \.{charexists}} +@d font_size=82 {operation code for \.{fontsize}} +@d ll_corner_op=83 {operation code for \.{llcorner}} +@d lr_corner_op=84 {operation code for \.{lrcorner}} +@d ul_corner_op=85 {operation code for \.{ulcorner}} +@d ur_corner_op=86 {operation code for \.{urcorner}} +@d arc_length=87 {operation code for \.{arclength}} +@d angle_op=88 {operation code for \.{angle}} +@d cycle_op=89 {operation code for \.{cycle}} +@d filled_op=90 {operation code for \.{filled}} +@d stroked_op=91 {operation code for \.{stroked}} +@d textual_op=92 {operation code for \.{textual}} +@d clipped_op=93 {operation code for \.{clipped}} +@d bounded_op=94 {operation code for \.{bounded}} +@d plus=95 {operation code for \.+} +@d minus=96 {operation code for \.-} +@d times=97 {operation code for \.*} +@d over=98 {operation code for \./} +@d pythag_add=99 {operation code for \.{++}} +@d pythag_sub=100 {operation code for \.{+-+}} +@d or_op=101 {operation code for \.{or}} +@d and_op=102 {operation code for \.{and}} +@d less_than=103 {operation code for \.<} +@d less_or_equal=104 {operation code for \.{<=}} +@d greater_than=105 {operation code for \.>} +@d greater_or_equal=106 {operation code for \.{>=}} +@d equal_to=107 {operation code for \.=} +@d unequal_to=108 {operation code for \.{<>}} +@d concatenate=109 {operation code for \.\&} +@d rotated_by=110 {operation code for \.{rotated}} +@d slanted_by=111 {operation code for \.{slanted}} +@d scaled_by=112 {operation code for \.{scaled}} +@d shifted_by=113 {operation code for \.{shifted}} +@d transformed_by=114 {operation code for \.{transformed}} +@d x_scaled=115 {operation code for \.{xscaled}} +@d y_scaled=116 {operation code for \.{yscaled}} +@d z_scaled=117 {operation code for \.{zscaled}} +@d in_font=118 {operation code for \.{infont}} +@d intersect=119 {operation code for \.{intersectiontimes}} +@d double_dot=120 {operation code for improper \.{..}} +@d substring_of=121 {operation code for \.{substring}} @d min_of=substring_of -@d subpath_of=116 {operation code for \.{subpath}} -@d direction_time_of=117 {operation code for \.{directiontime}} -@d point_of=118 {operation code for \.{point}} -@d precontrol_of=119 {operation code for \.{precontrol}} -@d postcontrol_of=120 {operation code for \.{postcontrol}} -@d pen_offset_of=121 {operation code for \.{penoffset}} -@d arc_time_of=122 {operation code for \.{arctime}} -@d mp_version=123 {operation code for \.{mpversion}} +@d subpath_of=122 {operation code for \.{subpath}} +@d direction_time_of=123 {operation code for \.{directiontime}} +@d point_of=124 {operation code for \.{point}} +@d precontrol_of=125 {operation code for \.{precontrol}} +@d postcontrol_of=126 {operation code for \.{postcontrol}} +@d pen_offset_of=127 {operation code for \.{penoffset}} +@d arc_time_of=128 {operation code for \.{arctime}} +@d mp_version=129 {operation code for \.{mpversion}} @p procedure print_op(@!c:quarterword); begin if c<=numeric_type then print_type(c) @@ -4293,6 +4272,12 @@ yy_part:print("yypart"); red_part:print("redpart"); green_part:print("greenpart"); blue_part:print("bluepart"); +cyan_part:print("cyanpart"); +magenta_part:print("magentapart"); +yellow_part:print("yellowpart"); +black_part:print("blackpart"); +grey_part:print("greypart"); +color_model_part:print("colormodel"); font_part:print("fontpart"); text_part:print("textpart"); path_part:print("pathpart"); @@ -4393,7 +4378,10 @@ fuss with. Every such parameter has an identifying code number, defined here. @d boundary_char=31 {the right boundary character for ligatures} @d prologues=32 {positive to output conforming PostScript using built-in fonts} @d true_corners=33 {positive to make \&{llcorner} etc. ignore \&{setbounds}} -@d max_given_internal=33 +@d default_color_model=34 {the default color model for unspecified items} +@d restore_clip_color=35 +@d mpprocset=36 {wether or not create PostScript command shortcuts} +@d max_given_internal=36 @<Glob...@>= @!internal:array[1..max_internal] of scaled; @@ -4479,6 +4467,34 @@ primitive("prologues",internal_quantity,prologues);@/ @!@:prologues_}{\&{prologues} primitive@> primitive("truecorners",internal_quantity,true_corners);@/ @!@:true_corners_}{\&{truecorners} primitive@> +primitive("mpprocset",internal_quantity,mpprocset);@/ +@!@:mpprocset_}{\&{mpprocset} primitive@> +primitive("defaultcolormodel",internal_quantity,default_color_model);@/ +@!@:default_color_model_}{\&{defaultcolormodel} primitive@> +primitive("restoreclipcolor",internal_quantity,restore_clip_color);@/ +@!@:restore_clip_color_}{\&{restoreclipcolor} 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. + +@d no_model=1 +@d grey_model=3 +@d rgb_model=5 +@d cmyk_model=7 +@d uninitialized_model=9 + +@<Initialize table entries (done by \.{INIMP} only)@>= +internal[default_color_model]:=(rgb_model*unity); +internal[restore_clip_color]:=unity; @ Well, we do have to list the names one more time, for use in symbolic printouts. @@ -4517,6 +4533,9 @@ int_name[warning_check]:="warningcheck"; int_name[boundary_char]:="boundarychar"; int_name[prologues]:="prologues"; int_name[true_corners]:="truecorners"; +int_name[default_color_model]:="defaultcolormodel"; +int_name[mpprocset]:="mpprocset"; +int_name[restore_clip_color]:="restoreclipcolor"; @ The following procedure, which is called just before \MP\ initializes its input and output, establishes the initial values of the date and time. @@ -4891,6 +4910,10 @@ primitive("skipto",skip_to,0);@/ @!@:skip_to_}{\&{skipto} primitive@> primitive("special",special_command,0); @!@:special}{\&{special} primitive@> +primitive("fontmapfile",special_command,1); +@!@:fontmapfile}{\&{fontmapfile} primitive@> +primitive("fontmapline",special_command,2); +@!@:fontmapline}{\&{fontmapline} primitive@> primitive("step",step_token,0);@/ @!@:step_}{\&{step} primitive@> primitive("str",str_op,0);@/ @@ -4944,7 +4967,9 @@ scan_tokens:print("scantokens"); semicolon:print(";"); ship_out_command:print("shipout"); skip_to:print("skipto"); -special_command: print("special"); +special_command: if m=2 then print("fontmapline") else + if m=1 then print("fontmapfile") else + print("special"); step_token:print("step"); str_op:print("str"); tension:print("tension"); @@ -5031,7 +5056,7 @@ begin while p<>null do vacuous,boolean_type,known:do_nothing; string_type:delete_str_ref(value(q)); unknown_types,pen_type,path_type,picture_type,pair_type,color_type, - transform_type,dependent,proto_dependent,independent: + cmykcolor_type,transform_type,dependent,proto_dependent,independent: begin g_pointer:=q; token_recycle; end; othercases confusion("token") @@ -5411,15 +5436,21 @@ while expressions are being evaluated. We call them {\sl capsules}. @d red_part_loc(#)==# {where the \&{redpart} is found in a color node} @d green_part_loc(#)==#+2 {where the \&{greenpart} is found in a color node} @d blue_part_loc(#)==#+4 {where the \&{bluepart} is found in a color node} +@d cyan_part_loc(#)==# {where the \&{cyanpart} is found in a color node} +@d magenta_part_loc(#)==#+2 {where the \&{magentapart} is found in a color node} +@d yellow_part_loc(#)==#+4 {where the \&{yellowpart} is found in a color node} +@d black_part_loc(#)==#+6 {where the \&{blackpart} is found in a color node} +@d grey_part_loc(#)==# {where the \&{greypart} is found in a color node} @# @d pair_node_size=4 {the number of words in a pair node} @d transform_node_size=12 {the number of words in a transform node} @d color_node_size=6 {the number of words in a color node} +@d cmykcolor_node_size=8 {the number of words in a color node} @<Glob...@>= @!big_node_size:array[transform_type..pair_type] of small_number; @!sector0:array[transform_type..pair_type] of small_number; -@!sector_offset:array[x_part_sector..blue_part_sector] of small_number; +@!sector_offset:array[x_part_sector..black_part_sector] of small_number; @ The |sector0| array gives for each big node type, |name_type| values for its first subfield; the |sector_offset| array gives for each @@ -5431,13 +5462,17 @@ big node. big_node_size[transform_type]:=transform_node_size; big_node_size[pair_type]:=pair_node_size; big_node_size[color_type]:=color_node_size; +big_node_size[cmykcolor_type]:=cmykcolor_node_size; sector0[transform_type]:=x_part_sector; sector0[pair_type]:=x_part_sector; sector0[color_type]:=red_part_sector; +sector0[cmykcolor_type]:=cyan_part_sector; for k:=x_part_sector to yy_part_sector do sector_offset[k]:=2*(k-x_part_sector); for k:=red_part_sector to blue_part_sector do sector_offset[k]:=2*(k-red_part_sector); +for k:=cyan_part_sector to black_part_sector do + sector_offset[k]:=2*(k-cyan_part_sector); @ If |type(p)=pair_type| or |transform_type| and if |value(p)=null|, the procedure call |init_big_node(p)| will allocate a pair or transform node @@ -5528,6 +5563,11 @@ yy_part_sector: print("yy"); red_part_sector: print("red"); green_part_sector: print("green"); blue_part_sector: print("blue"); +cyan_part_sector: print("cyan"); +magenta_part_sector: print("magenta"); +yellow_part_sector: print("yellow"); +black_part_sector: print("black"); +grey_part_sector: print("grey"); capsule: begin print("%CAPSULE"); print_int(p-null); return; @.CAPSULE@> end; @@ -5796,7 +5836,8 @@ string_type,unknown_string:und_type:=unknown_string; pen_type,unknown_pen:und_type:=unknown_pen; path_type,unknown_path:und_type:=unknown_path; picture_type,unknown_picture:und_type:=unknown_picture; -transform_type,color_type,pair_type,numeric_type:und_type:=type(p); +transform_type,color_type,cmykcolor_type, +pair_type,numeric_type:und_type:=type(p); known,dependent,proto_dependent,independent:und_type:=numeric_type; end; {there are no other cases} end; @@ -8001,8 +8042,8 @@ two such objects overlap, but it suffices to draw the first one first and let the second one overwrite it if necessary. @ Let's consider the types of graphical objects one at a time. -First of all, a filled contour is represented by a six-word node. The first -word contains |type| and |link| fields, and the next four words contain a +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|, |ljoin_val| and |miterlim_val| give the relevant information. @@ -8011,20 +8052,31 @@ give the relevant information. {a pointer to the path that needs filling} @d pen_p(#)==info(#+1) {a pointer to the pen to fill or stroke with} -@d obj_red_loc(#)==#+2 {the first of three locations for the color} -@d red_val(#)==mem[#+2].sc +@d color_model(#)==type(#+2) { the color model } +@d obj_red_loc(#)==#+3 {the first of three locations for the color} +@d obj_cyan_loc==obj_red_loc {the first of four locations for the color} +@d obj_grey_loc==obj_red_loc {the location for the color} +@d red_val(#)==mem[#+3].sc {the red component of the color in the range $0\ldots1$} -@d green_val(#)==mem[#+3].sc +@d cyan_val==red_val +@d grey_val==red_val +@d green_val(#)==mem[#+4].sc {the green component of the color in the range $0\ldots1$} -@d blue_val(#)==mem[#+4].sc +@d magenta_val==green_val +@d blue_val(#)==mem[#+5].sc + {the blue component of the color in the range $0\ldots1$} +@d yellow_val==blue_val +@d black_val(#)==mem[#+6].sc {the blue component of the color in the range $0\ldots1$} @d ljoin_val(#)==name_type(#) {the value of \&{linejoin}} @:linejoin_}{\&{linejoin} primitive@> -@d miterlim_val(#)==mem[#+5].sc {the value of \&{miterlimit}} +@d miterlim_val(#)==mem[#+7].sc {the value of \&{miterlimit}} @:miterlimit_}{\&{miterlimit} primitive@> -@d obj_color_part(#)==mem[#+2-red_part].sc +@d obj_color_part(#)==mem[#+3-red_part].sc {interpret an object pointer that has been offset by |red_part..blue_part|} -@d fill_node_size=6 +@d pre_script(#)==mem[#+8].hh.lh +@d post_script(#)==mem[#+8].hh.rh +@d fill_node_size=9 @d fill_code=1 @p function new_fill_node(@!p: pointer): pointer; @@ -8037,6 +8089,10 @@ begin t:=get_node(fill_node_size); red_val(t):=0; green_val(t):=0; blue_val(t):=0; + black_val(t):=0; + color_model(t):=uninitialized_model; + pre_script(t):=null; + post_script(t):=null; @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>; new_fill_node:=t; end; @@ -8055,13 +8111,13 @@ 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. -@d dash_p(#)==link(#+6) +@d dash_p(#)==link(#+9) {a pointer to the edge structure that gives the dash pattern} -@d lcap_val(#)==type(#+6) +@d lcap_val(#)==type(#+9) {the value of \&{linecap}} @:linecap_}{\&{linecap} primitive@> -@d dash_scale(#)==mem[#+7].sc {dash lengths are scaled by this factor} -@d stroked_node_size=8 +@d dash_scale(#)==mem[#+10].sc {dash lengths are scaled by this factor} +@d stroked_node_size=11 @d stroked_code=2 @p function new_stroked_node(@!p:pointer): pointer; @@ -8075,6 +8131,10 @@ begin t:=get_node(stroked_node_size); red_val(t):=0; green_val(t):=0; blue_val(t):=0; + black_val(t):=0; + color_model(t):=uninitialized_model; + pre_script(t):=null; + post_script(t):=null; @<Set the |ljoin_val| and |miterlim_val| fields in object |t|@>; if internal[linecap]>unity then lcap_val(t):=2 else if internal[linecap]>0 then lcap_val(t):=1 @@ -8129,20 +8189,20 @@ black with its reference point at the origin. @d text_p(#)==link(#+1) {a string pointer for the text to display} @d font_n(#)==info(#+1) {the font number} -@d width_val(#)==mem[#+5].sc {unscaled width of the text} -@d height_val(#)==mem[#+6].sc {unscaled height of the text} -@d depth_val(#)==mem[#+7].sc {unscaled depth of the text} -@d text_tx_loc(#)==#+8 +@d width_val(#)==mem[#+7].sc {unscaled width of the text} +@d height_val(#)==mem[#+9].sc {unscaled height of the text} +@d depth_val(#)==mem[#+10].sc {unscaled depth of the text} +@d text_tx_loc(#)==#+11 {the first of six locations for transformation parameters} -@d tx_val(#)==mem[#+8].sc {$x$ shift amount} -@d ty_val(#)==mem[#+9].sc {$y$ shift amount} -@d txx_val(#)==mem[#+10].sc {|txx| transformation parameter} -@d txy_val(#)==mem[#+11].sc {|txy| transformation parameter} -@d tyx_val(#)==mem[#+12].sc {|tyx| transformation parameter} -@d tyy_val(#)==mem[#+13].sc {|tyy| transformation parameter} -@d text_trans_part(#)==mem[#+8-x_part].sc +@d tx_val(#)==mem[#+11].sc {$x$ shift amount} +@d ty_val(#)==mem[#+12].sc {$y$ shift amount} +@d txx_val(#)==mem[#+13].sc {|txx| transformation parameter} +@d txy_val(#)==mem[#+14].sc {|txy| transformation parameter} +@d tyx_val(#)==mem[#+15].sc {|tyx| transformation parameter} +@d tyy_val(#)==mem[#+16].sc {|tyy| transformation parameter} +@d text_trans_part(#)==mem[#+11-x_part].sc {interpret a text node ponter that has been offset by |x_part..yy_part|} -@d text_node_size=14 +@d text_node_size=17 @d text_code=3 @p @<Declare text measuring subroutines@>@; @@ -8156,6 +8216,10 @@ begin t:=get_node(text_node_size); red_val(t):=0; green_val(t):=0; blue_val(t):=0; + black_val(t):=0; + color_model(t):=uninitialized_model; + pre_script(t):=null; + post_script(t):=null; tx_val(t):=0; ty_val(t):=0; txx_val(t):=unity; txy_val(t):=0; tyx_val(t):=0; tyy_val(t):=unity; @@ -8348,12 +8412,20 @@ end; case type(p) of fill_code: begin toss_knot_list(path_p(p)); if pen_p(p)<>null then toss_knot_list(pen_p(p)); + if pre_script(p)<>null then delete_str_ref(pre_script(p)); + if post_script(p)<>null then delete_str_ref(post_script(p)); end; stroked_code: begin toss_knot_list(path_p(p)); if pen_p(p)<>null then toss_knot_list(pen_p(p)); + if pre_script(p)<>null then delete_str_ref(pre_script(p)); + if post_script(p)<>null then delete_str_ref(post_script(p)); e:=dash_p(p); end; -text_code: delete_str_ref(text_p(p)); +text_code: begin + delete_str_ref(text_p(p)); + if pre_script(p)<>null then delete_str_ref(pre_script(p)); + if post_script(p)<>null then delete_str_ref(post_script(p)); + end; start_clip_code,start_bounds_code: toss_knot_list(path_p(p)); stop_clip_code,stop_bounds_code: do_nothing; end; {there are no other cases} @@ -8545,10 +8617,21 @@ black (the default color). @<Declare subroutines needed by |print_edges|@>= @<Declare a procedure called |print_compact_node|@>@; procedure print_obj_color(@!p:pointer); -begin if (red_val(p)>0) or (green_val(p)>0) or (blue_val(p)>0) then - begin print("colored "); - print_compact_node(obj_red_loc(p),3); - end; +begin if color_model(p)=grey_model then + if grey_val(p)>0 then + begin print("greyed "); + print_compact_node(obj_grey_loc(p),1); + end + else if color_model(p)=cmyk_model then + if (cyan_val(p)>0) or (magenta_val(p)>0) or (yellow_val(p)>0) or (black_val(p)>0) then + begin print("colored "); + print_compact_node(obj_cyan_loc(p),4); + end + else if color_model(p)=rgb_model then + if (red_val(p)>0) or (green_val(p)>0) or (blue_val(p)>0) then + begin print("processcolored "); + print_compact_node(obj_red_loc(p),3); + end; end; @ We also need a procedure for printing consecutive scaled values as if they @@ -8751,7 +8834,7 @@ if (x_coord(pp)>x0) or (x0>x3) then @!x0,@!x1,@!x2,@!x3:scaled; {$x$ coordinates of the segment from |qq| to |rr|} @ @<Make sure |p| and |p0| are the same color and |goto not_found|...@>= -if (red_val(p)<>red_val(p0)) or@| +if (red_val(p)<>red_val(p0)) or (black_val(p)<>black_val(p0)) or@| (green_val(p)<>green_val(p0)) or (blue_val(p)<>blue_val(p0)) then begin print_err("Picture is too complicated to use as a dash pattern"); help3("When you say `dashed p', everything in picture p should")@/ @@ -9895,9 +9978,9 @@ link(spec_p2):=link(spec_p1); link(spec_p1):=c;@/ remove_cubic(spec_p1); c:=spec_p1; -if c<>link(c) then begin -originator(spec_p2):=program_code; -remove_cubic(spec_p2); +if c<>link(c) then begin +originator(spec_p2):=program_code; +remove_cubic(spec_p2); end else @<Make |c| look like a cycle of length one@>; end @@ -14687,6 +14770,12 @@ points to a color node that contains three numeric values, each of which is |independent|, |dependent|, |proto_dependent|, or |known|. \smallskip\hang +|cur_type=cmykcolor_type| means that |cur_exp| points to a |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|, |proto_dependent|, or |known|. + +\smallskip\hang |cur_type=pair_type| means that |cur_exp| points to a capsule node whose type is |pair_type|. The |value| part of this capsule points to a pair node that contains two numeric values, @@ -14763,7 +14852,7 @@ function stash_cur_exp:pointer; var @!p:pointer; {the capsule that will be returned} begin case cur_type of unknown_types,transform_type,color_type,pair_type,dependent,proto_dependent, - independent:p:=cur_exp; + independent,cmykcolor_type:p:=cur_exp; othercases begin p:=get_node(value_node_size); name_type(p):=capsule; type(p):=cur_type; value(p):=cur_exp; end @@ -14796,7 +14885,7 @@ procedure unstash_cur_exp(@!p:pointer); begin cur_type:=type(p); case cur_type of unknown_types,transform_type,color_type,pair_type,dependent,proto_dependent, - independent: cur_exp:=p; + independent,cmykcolor_type: cur_exp:=p; othercases begin cur_exp:=value(p); free_node(p,value_node_size); end @@ -14838,7 +14927,7 @@ unknown_types,numeric_type:@<Display a variable string_type:begin print_char(""""); print(v); print_char(""""); end; pen_type,path_type,picture_type:@<Display a complex type@>; -transform_type,color_type,pair_type:if v=null then print_type(t) +transform_type,color_type,pair_type,cmykcolor_type:if v=null then print_type(t) else @<Display a big node@>; known:print_scaled(v); dependent,proto_dependent:print_dp(t,v,verbosity); @@ -14925,7 +15014,7 @@ because |cur_exp| will not contain a pointer value. procedure flush_cur_exp(@!v:scaled); begin case cur_type of unknown_types,transform_type,color_type,pair_type,@| - dependent,proto_dependent,independent: + dependent,proto_dependent,independent,cmykcolor_type: begin recycle_value(cur_exp); free_node(cur_exp,value_node_size); end; string_type:delete_str_ref(cur_exp); @@ -14954,7 +15043,7 @@ unknown_types:ring_delete(p); string_type:delete_str_ref(v); path_type,pen_type:toss_knot_list(v); picture_type:delete_edge_ref(v); -pair_type,color_type,transform_type:@<Recycle a big node@>; +cmykcolor_type,pair_type,color_type,transform_type:@<Recycle a big node@>; dependent,proto_dependent:@<Recycle a dependency list@>; independent:@<Recycle an independent variable@>; token_list,structured:confusion("recycle"); @@ -15255,7 +15344,7 @@ if interrupt<>0 then if OK_to_interrupt then @ @<Scan a delimited primary@>= begin l_delim:=cur_sym; r_delim:=cur_mod; get_x_next; scan_expression; if (cur_cmd=comma) and (cur_type>=known) then - @<Scan the rest of a pair or triplet of numerics@> + @<Scan the rest of a delimited set of numerics@> else check_delimiter(l_delim,r_delim); end @@ -15295,7 +15384,7 @@ end @ This code uses the fact that |red_part_loc| and |green_part_loc| are synonymous with |x_part_loc| and |y_part_loc|. -@<Scan the rest of a pair or triplet of numerics@>= +@<Scan the rest of a delimited set of numerics@>= begin p:=stash_cur_exp; get_x_next; scan_expression; @<Make sure the second part of a pair or color has a numeric type@>; @@ -15307,6 +15396,19 @@ stash_in(y_part_loc(r)); unstash_cur_exp(p); stash_in(x_part_loc(r)); if cur_cmd=comma then @<Scan the last of a triplet of numerics@>; +if cur_cmd=comma then begin + type(q):=cmykcolor_type; + init_big_node(q); t:=value(q); + mem[cyan_part_loc(t)]:=mem[red_part_loc(r)]; + value(cyan_part_loc(t)):=value(red_part_loc(r)); + mem[magenta_part_loc(t)]:=mem[green_part_loc(r)]; + value(magenta_part_loc(t)):=value(green_part_loc(r)); + mem[yellow_part_loc(t)]:=mem[blue_part_loc(r)]; + value(yellow_part_loc(t)):=value(blue_part_loc(r)); + recycle_value(r); + r:=t; + @<Scan the last of a quartet of numerics@>; + end; check_delimiter(l_delim,r_delim); cur_type:=type(q); cur_exp:=q; @@ -15326,16 +15428,29 @@ if cur_type<known then @ @<Scan the last of a triplet of numerics@>= begin get_x_next; scan_expression; if cur_type<known then - begin exp_err("Nonnumeric bluepart has been replaced by 0"); + begin exp_err("Nonnumeric third part has been replaced by 0"); @.Nonnumeric...replaced by 0@> - help3("I've just scanned a color `(r,g,b)'; but the `b' isn't")@/ + help3("I've just scanned a color `(a,b,c)' or cmykcolor(a,b,c,d); but the `c' isn't")@/ ("of numeric type. So I've changed that part to zero.")@/ - ("(The b that I didn't like appears above the error message.)");@/ + ("(The c that I didn't like appears above the error message.)");@/ put_get_flush_error(0); end; stash_in(blue_part_loc(r)); end +@ @<Scan the last of a quartet of numerics@>= +begin get_x_next; scan_expression; +if cur_type<known then + begin exp_err("Nonnumeric blackpart has been replaced by 0"); +@.Nonnumeric...replaced by 0@> + help3("I've just scanned a cmykcolor `(c,m,y,k)'; but the `k' isn't")@/ + ("of numeric type. So I've changed that part to zero.")@/ + ("(The k that I didn't like appears above the error message.)");@/ + put_get_flush_error(0); + end; +stash_in(black_part_loc(r)); +end + @ 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. @@ -15674,7 +15789,7 @@ picture_type:begin cur_exp:=value(p);add_edge_ref(cur_exp); end; pen_type:cur_exp:=copy_pen(value(p)); path_type:cur_exp:=copy_path(value(p)); -transform_type,color_type,pair_type:@<Copy the big node |p|@>; +transform_type,color_type,cmykcolor_type,pair_type:@<Copy the big node |p|@>; dependent,proto_dependent:encapsulate(copy_dep_list(dep_list(p))); numeric_type:begin new_indep(p); goto restart; end; @@ -16369,6 +16484,18 @@ primitive("greenpart",unary,green_part);@/ @!@:green_part_}{\&{greenpart} primitive@> primitive("bluepart",unary,blue_part);@/ @!@:blue_part_}{\&{bluepart} primitive@> +primitive("cyanpart",unary,cyan_part);@/ +@!@:cyan_part_}{\&{cyanpart} primitive@> +primitive("magentapart",unary,magenta_part);@/ +@!@:magenta_part_}{\&{magentapart} primitive@> +primitive("yellowpart",unary,yellow_part);@/ +@!@:yellow_part_}{\&{yellowpart} primitive@> +primitive("blackpart",unary,black_part);@/ +@!@:black_part_}{\&{blackpart} primitive@> +primitive("greypart",unary,grey_part);@/ +@!@:grey_part_}{\&{greypart} primitive@> +primitive("colormodel",unary,color_model_part);@/ +@!@:color_model_part_}{\&{colormodel} primitive@> primitive("fontpart",unary,font_part);@/ @!@:font_part_}{\&{fontpart} primitive@> primitive("textpart",unary,text_part);@/ @@ -16580,7 +16707,7 @@ fully known colors. function nice_color_or_pair(@!p:integer;@!t:quarterword):boolean; label exit; var @!q,@!r:pointer; {for scanning the big node} -begin if (t<>pair_type)and(t<>color_type) then +begin if (t<>pair_type)and(t<>color_type)and(t<>cmykcolor_type) then nice_color_or_pair:=false else begin q:=value(p); r:=q+big_node_size[type(p)]; @@ -16597,7 +16724,7 @@ exit:end; procedure print_known_or_unknown_type(@!t:small_number;@!v:integer); begin print_char("("); if t>known then print("unknown numeric") -else begin if (t=pair_type)or(t=color_type) then +else begin if (t=pair_type)or(t=color_type)or(t=cmykcolor_type) then if not nice_color_or_pair(v,t) then print("unknown "); print_type(t); end; @@ -16636,7 +16763,8 @@ and recycling it afterwards (cf.~the |stash_in| routine). @<Negate the current expression@>= case cur_type of -color_type,pair_type,independent: begin q:=cur_exp; make_exp_copy(q); +color_type,cmykcolor_type,pair_type,independent: begin + q:=cur_exp; make_exp_copy(q); if cur_type=dependent then negate_dep_list(dep_list(cur_exp)) else if cur_type<=pair_type then {|color_type| or |pair_type|} begin p:=value(cur_exp); @@ -16717,6 +16845,14 @@ xx_part,xy_part,yx_part,yy_part: if cur_type=transform_type then take_part(c) red_part,green_part,blue_part: if cur_type=color_type then take_part(c) else if cur_type=picture_type then take_pict_part(c) else bad_unary(c); +cyan_part,magenta_part,yellow_part,black_part: if cur_type=cmykcolor_type + then take_part(c) else if cur_type=picture_type then take_pict_part(c) + else bad_unary(c); +grey_part: if cur_type=known then cur_exp:=value(c) + else if cur_type=picture_type then take_pict_part(c) + else bad_unary(c); +color_model_part: if cur_type=picture_type then take_pict_part(c) + else bad_unary(c); @ 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. @@ -16752,6 +16888,24 @@ if p<>null then red_part,green_part,blue_part: if has_color(p) then flush_cur_exp(obj_color_part(p+c)) else goto not_found; + cyan_part,magenta_part,yellow_part,black_part: + if has_color(p) then + if color_model(p)=uninitialized_model then + flush_cur_exp(unity) + else + flush_cur_exp(obj_color_part(p+c+(red_part-cyan_part))) + else goto not_found; + grey_part: + if has_color(p) then + flush_cur_exp(obj_color_part(p+c+(red_part-grey_part))) + else goto not_found; + color_model_part: + if has_color(p) then + if color_model(p)=uninitialized_model then + flush_cur_exp(internal[default_color_model]) + else + flush_cur_exp(color_model(p)*unity) + else goto not_found; @<Handle other cases in |take_pict_part| or |goto not_found|@>@; end; {all cases have been enumerated} return; @@ -16930,10 +17084,7 @@ if p<>null then found:pict_length:=n; end; -@ The turning number is computed only with respect to a triangular pen whose -@:turning_number_}{\&{turningnumber} primitive@> -vertices are $(0,1)$ and $(\pm{1\over2},0)$. The choice of pen isn't supposed -to matter but rounding error could make a difference if the path has a cusp. +@ Implement |turningnumber| @<Additional cases of unary...@>= turning_op:if cur_type=pair_type then flush_cur_exp(0) @@ -16944,36 +17095,8 @@ turning_op:if cur_type=pair_type then flush_cur_exp(0) flush_cur_exp(turn_cycles(cur_exp)); end; - -@ This code is based on Bogus\l{}av Jackowski's -|emergency_turningnumber| macro, with some minor changes by Taco -Hoekwater. The macro code looked more like this: -{\obeylines -vardef turning\_number primary p = -~~save res, ang, turns; -~~res := 0; -~~if length p <= 2: -~~~~if Angle ((point 0 of p) - (postcontrol 0 of p)) >= 0: 1 else: -1 fi -~~else: -~~~~for t = 0 upto length p-1 : -~~~~~~angc := Angle ((point t+1 of p) - (point t of p)) -~~~~~~~~- Angle ((point t of p) - (point t-1 of p)); -~~~~~~if angc > 180: angc := angc - 360; fi; -~~~~~~if angc < -180: angc := angc + 360; fi; -~~~~~~res := res + angc; -~~~~endfor; -~~res/360 -~~fi -enddef;} -The general idea is to calculate only the sum of the angles of straight lines between -the points, of a path, not worrying about cusps or self-intersections in the segments -at all. If the segment is not well-behaved, the result is not necesarily correct. But -the old code was not always correct either, and worse, it sometimes failed for well-behaved -paths as well. All known bugs that were triggered by the original code no longer occur -with this code, and it runs roughly 3 times as fast because the algorithm is much simpler. - -@ The macro |Angle()| returns the value of the |angle| primitive, or $0$ if the argument is -|origin|. Converting that calling convention to web code gives the |an_angle| function. +@ The function |an_angle| returns the value of the |angle| primitive, or $0$ if the +argument is |origin|. @<Declare unary action...@>= function an_angle (@!xpar,@!ypar:scaled):angle; @@ -16985,42 +17108,63 @@ begin end; -@ It is possible to overflow the return value of the |turn_cycles| -function when the path is sufficiently long and winding, but I am not -going to bother testing for that. In any case, it would only return -the looped result value, which is not a big problem. +@ 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. -The macro code for the repeat loop was a bit nicer to look -at than the pascal code, because it could use |point -1 of p|. In -pascal, the fastest way to loop around the path is not to look -backward once, but forward twice. These defines help hide the trick. +@d p_nextnext==link(link(p)) +@d p_next==link(p) -@d p_to==link(link(p)) -@d p_here==link(p) -@d p_from==p +@d seven_twenty_deg==@'5500000000 {$720\cdot2^{20}$, represents $720^\circ$} @<Declare unary action...@>= function turn_cycles (@!c:pointer):scaled; +label exit; var @!res,ang:angle; { the angles of intermediate results } @!turns:scaled; { the turn counter } @!p:pointer; { for running around the path } -begin res:=0; turns:= 0; p:=c; -if ((link(p) = p) or (link(link(p)) = p)) then +@!xp,yp:integer; { coordinates of next point } +@!x,y:integer; { helper coordinates } +@!in_angle,out_angle:angle; { helper angles} +begin +res:=0; +turns:= 0; +p:=c; +if (p_next=p)or(p_nextnext=p) then if an_angle (x_coord(p) - right_x(p), y_coord(p) - right_y(p)) >= 0 then turn_cycles := unity else turn_cycles := -unity else begin repeat - ang := an_angle (x_coord(p_to) - x_coord(p_here), y_coord(p_to) - y_coord(p_here)) - - an_angle (x_coord(p_here) - x_coord(p_from), y_coord(p_here) - y_coord(p_from)); - reduce_angle(ang); + xp := x_coord(p_next); yp := y_coord(p_next); + ang := bezier_slope(x_coord(p), y_coord(p), right_x(p), right_y(p), + left_x(p_next), left_y(p_next), xp, yp); + if ang>seven_twenty_deg then begin + print_err("Strange path"); + error; + turn_cycles := 0; + return; + end; + res := res + ang; + { incoming angle at next point } + x := left_x(p_next); y := left_y(p_next); + if (xp=x)and(yp=y) then begin x := right_x(p); y := right_y(p); end; + if (xp=x)and(yp=y) then begin x := x_coord(p); y := y_coord(p); end; + in_angle := an_angle(xp - x, yp - y); + { outgoing angle at next point } + x := right_x(p_next); y := right_y(p_next); + if (xp=x)and(yp=y) then begin x := left_x(p_nextnext); y := left_y(p_nextnext); end; + if (xp=x)and(yp=y) then begin x := x_coord(p_nextnext); y := y_coord(p_nextnext); end; + out_angle := an_angle(x - xp, y- yp); + ang := (out_angle - in_angle); res := res + ang; - if res >= three_sixty_deg then begin + while res >= three_sixty_deg do begin res := res - three_sixty_deg; turns := turns + unity; end; - if res <= -three_sixty_deg then begin + while res <= -three_sixty_deg do begin res := res + three_sixty_deg; turns := turns - unity; end; @@ -17028,17 +17172,7 @@ else begin until p=c; turn_cycles := turns; end; -end; - -@ @<Declare unary action...@>= -function count_turns(@!c:pointer):scaled; -var @!p:pointer; {a knot in envelope spec |c|} -@!t:integer; {total pen offset changes counted} -begin t:=0; p:=c; -repeat t:=t+info(p)-zero_off; -p:=link(p); -until p=c; -count_turns:=(t div 3)*unity; +exit: end; @ @d type_test_end== flush_cur_exp(true_code) @@ -17055,7 +17189,7 @@ string_type: type_range(string_type)(unknown_string); pen_type: type_range(pen_type)(unknown_pen); path_type: type_range(path_type)(unknown_path); picture_type: type_range(picture_type)(unknown_picture); -transform_type,color_type,pair_type: type_test(c); +transform_type,color_type,cmykcolor_type,pair_type: type_test(c); numeric_type: type_range(known)(independent); known_op,unknown_op: test_known(c); @@ -17068,7 +17202,7 @@ begin b:=false_code; case cur_type of vacuous,boolean_type,string_type,pen_type,path_type,picture_type, known: b:=true_code; -transform_type,color_type,pair_type:begin p:=value(cur_exp); +transform_type,color_type,cmykcolor_type,pair_type:begin p:=value(cur_exp); q:=p+big_node_size[cur_type]; repeat q:=q-2; if type(q)<>known then goto done; @@ -17322,7 +17456,7 @@ that returns |null| if and only if its argument is not tarnished. @<Sidestep |independent| cases in capsule |p|@>= case type(p) of -transform_type,color_type,pair_type: old_p:=tarnished(p); +transform_type,color_type,cmykcolor_type,pair_type: old_p:=tarnished(p); independent: old_p:=void; othercases old_p:=null endcases; @@ -17333,7 +17467,8 @@ if old_p<>null then @ @<Sidestep |independent| cases in the current expression@>= case cur_type of -transform_type,color_type,pair_type:old_exp:=tarnished(cur_exp); +transform_type,color_type,cmykcolor_type, +pair_type:old_exp:=tarnished(cur_exp); independent:old_exp:=void; othercases old_exp:=null endcases; @@ -17561,7 +17696,8 @@ begin if type(p)=known then else begin v:=cur_exp; unstash_cur_exp(p); end; if cur_type=known then cur_exp:=take_scaled(cur_exp,v) -else if (cur_type=pair_type)or(cur_type=color_type) then +else if (cur_type=pair_type)or(cur_type=color_type)or + (cur_type=cmykcolor_type) then begin p:=value(cur_exp)+big_node_size[cur_type]; repeat p:=p-2; dep_mult(p,v,true); @@ -17599,7 +17735,7 @@ var @!p:pointer; {a pair node} begin if internal[tracing_commands]>two then @<Trace the fraction multiplication@>; case cur_type of -transform_type,color_type,pair_type:old_exp:=tarnished(cur_exp); +transform_type,color_type,cmykcolor_type,pair_type:old_exp:=tarnished(cur_exp); independent:old_exp:=void; othercases old_exp:=null endcases; @@ -18646,7 +18782,8 @@ unknown_types:if cur_type=t-unknown_tag then else if cur_type=pair_type then if t=unknown_path then begin pair_to_path; goto restart; end; -transform_type,color_type,pair_type:if cur_type=t then +transform_type,color_type,cmykcolor_type, +pair_type:if cur_type=t then @<Do multiple equations and |goto done|@>; known,dependent,proto_dependent,independent:if cur_type>=known then begin try_eq(lhs,null); goto done; @@ -18833,6 +18970,10 @@ primitive("transform",type_name,transform_type);@/ @!@:transform_}{\&{transform} primitive@> primitive("color",type_name,color_type);@/ @!@:color_}{\&{color} primitive@> +primitive("rgbcolor",type_name,color_type);@/ +@!@:color_}{\&{rgbcolor} primitive@> +primitive("cmykcolor",type_name,cmykcolor_type);@/ +@!@:color_}{\&{cmykcolor} primitive@> primitive("pair",type_name,pair_type);@/ @!@:pair_}{\&{pair} primitive@> @@ -19323,6 +19464,11 @@ end; @d contour_code=1 {command modifier for `\&{contour}'} @d also_code=2 {command modifier for `\&{also}'} +@ Pre and postscripts need two new identifiers: + +@d with_pre_script=11 +@d with_post_script=13 + @<Put each...@>= primitive("doublepath",thing_to_add,double_path_code);@/ @!@:double_path_}{\&{doublepath} primitive@> @@ -19334,15 +19480,34 @@ primitive("withpen",with_option,pen_type);@/ @!@:with_pen_}{\&{withpen} primitive@> primitive("dashed",with_option,picture_type);@/ @!@:dashed_}{\&{dashed} primitive@> -primitive("withcolor",with_option,color_type);@/ +primitive("withprescript",with_option,with_pre_script);@/ +@!@:with_pre_script_}{\&{withprescript} primitive@> +primitive("withpostscript",with_option,with_post_script);@/ +@!@:with_post_script_}{\&{withpostscript} primitive@> +primitive("withoutcolor",with_option,no_model);@/ +@!@:with_color_}{\&{withoutcolor} primitive@> +primitive("withgreyscale",with_option,grey_model);@/ +@!@:with_color_}{\&{withgreyscale} primitive@> +primitive("withcolor",with_option,uninitialized_model);@/ @!@:with_color_}{\&{withcolor} primitive@> +{ \&{withrgbcolor} is an alias for \&{withcolor}} +primitive("withrgbcolor",with_option,rgb_model);@/ +@!@:with_color_}{\&{withrgbcolor} primitive@> +primitive("withcmykcolor",with_option,cmyk_model);@/ +@!@:with_color_}{\&{withcmykcolor} primitive@> @ @<Cases of |print_cmd...@>= thing_to_add:if m=contour_code then print("contour") else if m=double_path_code then print("doublepath") else print("also"); with_option:if m=pen_type then print("withpen") - else if m=color_type then print("withcolor") + else if m=with_pre_script then print("withprescript") + else if m=with_post_script then print("withpostscript") + else if m=no_model then print("withoutcolor") + else if m=rgb_model then print("withrgbcolor") + else if m=uninitialized_model then print("withcolor") + else if m=cmyk_model then print("withcmykcolor") + else if m=grey_model then print("withgreyscale") else print("dashed"); @ The |scan_with_list| procedure parses a $\langle$with list$\rangle$ and @@ -19355,18 +19520,55 @@ procedure scan_with_list(@!p:pointer); label done, done1, done2; var @!t:small_number; {|cur_mod| of the |with_option| (should match |cur_type|)} @!q:pointer; {for list manipulation} -@!cp,@!pp,@!dp:pointer; +@!old_setting:0..max_selector; {saved |selector| setting} +@!k:pointer; {for finding the near-last item in a list } +@!s:str_number; {for string cleanup after combining } +@!cp,@!pp,@!dp,@!ap,@!bp:pointer; {objects being updated; |void| initially; |null| to suppress update} -begin cp:=void; pp:=void; dp:=void; +begin cp:=void; pp:=void; dp:=void; ap:=void; bp:=void; while cur_cmd=with_option do - begin t:=cur_mod; get_x_next; scan_expression; - if cur_type<>t then @<Complain about improper type@> - else if t=color_type then + begin t:=cur_mod; + get_x_next; + if t<>no_model then scan_expression; + if ((t=with_pre_script)and(cur_type<>string_type))or + ((t=with_post_script)and(cur_type<>string_type))or + ((t=uninitialized_model)and + ((cur_type<>cmykcolor_type)and(cur_type<>color_type) + and(cur_type<>known)and(cur_type<>boolean_type)))or + ((t=cmyk_model)and(cur_type<>cmykcolor_type))or + ((t=rgb_model)and(cur_type<>color_type))or + ((t=grey_model)and(cur_type<>known))or + ((t=pen_type)and(cur_type<>t))or + ((t=picture_type)and(cur_type<>t)) then @<Complain about improper type@> + else if t=uninitialized_model then begin if cp=void then @<Make |cp| a colored object in object list~|p|@>; if cp<>null then @<Transfer a color from the current expression to object~|cp|@>; flush_cur_exp(0); end + else if t=rgb_model then + begin if cp=void then @<Make |cp| a rgb colored object in object list~|p|@>; + if cp<>null then + @<Transfer a rgbcolor from the current expression to object~|cp|@>; + flush_cur_exp(0); + end + else if t=cmyk_model then + begin if cp=void then @<Make |cp| a cmyk colored object in object list~|p|@>; + if cp<>null then + @<Transfer a cmykcolor from the current expression to object~|cp|@>; + flush_cur_exp(0); + end + else if t=grey_model then + begin if cp=void then @<Make |cp| a grey colored object in object list~|p|@>; + if cp<>null then + @<Transfer a greyscale from the current expression to object~|cp|@>; + flush_cur_exp(0); + end + else if t=no_model then + begin if cp=void then @<Make |cp| a no colored object in object list~|p|@>; + if cp<>null then + @<Transfer a noncolor from the current expression to object~|cp|@>; + end else if t=pen_type then begin if pp=void then @<Make |pp| an object in list~|p| that needs a pen@>; @@ -19375,6 +19577,54 @@ while cur_cmd=with_option do pen_p(pp):=cur_exp; cur_type:=vacuous; end; end + else if t=with_pre_script then + begin if ap=void then + ap:=p; + while (ap<>null)and(not has_color(ap)) do + ap:=link(ap); + if ap<>null then + begin if pre_script(ap)<>null then begin { build a new,combined string } + s:=pre_script(ap); + old_setting:=selector; + selector:=new_string; + str_room(length(pre_script(ap))+length(cur_exp)+2); + print(cur_exp); + append_char(13); {a forced \ps\ newline } + print(pre_script(ap)); + pre_script(ap):=make_string; + delete_str_ref(s); + selector:=old_setting; + end + else + pre_script(ap):=cur_exp; + cur_type:=vacuous; + end; + end + else if t=with_post_script then + begin if bp=void then + k:=p; bp:=k; + while link(k)<>null do begin + k:=link(k); + if has_color(k) then bp:=k; + end; + if bp<>null then + begin if post_script(bp)<>null then begin + s:=post_script(bp); + old_setting:=selector; + selector:=new_string; + str_room(length(post_script(bp))+length(cur_exp)+2); + print(post_script(bp)); + append_char(13); {a forced \ps\ newline } + print(cur_exp); + post_script(bp):=make_string; + delete_str_ref(s); + selector:=old_setting; + end + else + post_script(bp):=cur_exp; + cur_type:=vacuous; + end; + end else begin if dp=void then @<Make |dp| a stroked node in list~|p|@>; if dp<>null then begin if dash_p(dp)<>null then delete_edge_ref(dash_p(dp)); @@ -19393,10 +19643,20 @@ begin exp_err("Improper type"); @.Improper type@> help2("Next time say `withpen <known pen expression>';")@/ ("I'll ignore the bad `with' clause and look for another."); -if t=picture_type then +if t=with_pre_script then + help_line[1]:="Next time say `withprescript <known string expression>';" +else if t=with_post_script then + help_line[1]:="Next time say `withpostscript <known string expression>';" +else if t=picture_type then help_line[1]:="Next time say `dashed <known picture expression>';" -else if t=color_type then - help_line[1]:="Next time say `withcolor <known color expression>';"; +else if t=uninitialized_model then + help_line[1]:="Next time say `withcolor <known color expression>';" +else if t=rgb_model then + help_line[1]:="Next time say `withrgbcolor <known color expression>';" +else if t=cmyk_model then + help_line[1]:="Next time say `withcmykcolor <known cmykcolor expression>';" +else if t=grey_model then + help_line[1]:="Next time say `withgreyscale <known numeric expression>';"; put_get_flush_error(0); end @@ -19404,10 +19664,26 @@ end picture will ever contain a color outside the legal range for \ps\ graphics. @<Transfer a color from the current expression to object~|cp|@>= +begin if cur_type=color_type then + @<Transfer a rgbcolor from the current expression to object~|cp|@> +else if cur_type=cmykcolor_type then + @<Transfer a cmykcolor from the current expression to object~|cp|@> +else if cur_type=known then + @<Transfer a greyscale from the current expression to object~|cp|@> +else if cur_exp=false_code then + @<Transfer a noncolor from the current expression to object~|cp|@>; +end + +@ @<Transfer a rgbcolor from the current expression to object~|cp|@>= begin q:=value(cur_exp); +cyan_val(cp):=0; +magenta_val(cp):=0; +yellow_val(cp):=0; +black_val(cp):=0; red_val(cp):=value(red_part_loc(q)); green_val(cp):=value(green_part_loc(q)); blue_val(cp):=value(blue_part_loc(q));@/ +color_model(cp):=rgb_model; if red_val(cp)<0 then red_val(cp):=0; if green_val(cp)<0 then green_val(cp):=0; if blue_val(cp)<0 then blue_val(cp):=0; @@ -19416,7 +19692,49 @@ if green_val(cp)>unity then green_val(cp):=unity; if blue_val(cp)>unity then blue_val(cp):=unity; end -@ @<Make |cp| a colored object in object list~|p|@>= +@ @<Transfer a cmykcolor from the current expression to object~|cp|@>= +begin q:=value(cur_exp); +cyan_val(cp):=value(cyan_part_loc(q)); +magenta_val(cp):=value(magenta_part_loc(q)); +yellow_val(cp):=value(yellow_part_loc(q));@/ +black_val(cp):=value(black_part_loc(q));@/ +color_model(cp):=cmyk_model; +if cyan_val(cp)<0 then cyan_val(cp):=0; +if magenta_val(cp)<0 then magenta_val(cp):=0; +if yellow_val(cp)<0 then yellow_val(cp):=0; +if black_val(cp)<0 then black_val(cp):=0; +if cyan_val(cp)>unity then cyan_val(cp):=unity; +if magenta_val(cp)>unity then magenta_val(cp):=unity; +if yellow_val(cp)>unity then yellow_val(cp):=unity; +if black_val(cp)>unity then black_val(cp):=unity; +end + +@ @<Transfer a greyscale from the current expression to object~|cp|@>= +begin q:=cur_exp; +cyan_val(cp):=0; +magenta_val(cp):=0; +yellow_val(cp):=0; +black_val(cp):=0; +grey_val(cp):=q; +color_model(cp):=grey_model; +if grey_val(cp)<0 then grey_val(cp):=0; +if grey_val(cp)>unity then grey_val(cp):=unity; +end + +@ @<Transfer a noncolor from the current expression to object~|cp|@>= +begin +cyan_val(cp):=0; +magenta_val(cp):=0; +yellow_val(cp):=0; +black_val(cp):=0; +grey_val(cp):=0; +color_model(cp):=no_model; +end + +@ It is a bit silly to repeat this action in five different +forms with the only difference being the label. Ah well. + +@<Make |cp| a colored object in object list~|p|@>= begin cp:=p; while cp<>null do begin if has_color(cp) then goto done; @@ -19425,6 +19743,42 @@ while cp<>null do done:do_nothing; end +@ @<Make |cp| a rgb colored object in object list~|p|@>= +begin cp:=p; +while cp<>null do + begin if has_color(cp) then goto done6; + cp:=link(cp); + end; +done6:do_nothing; +end + +@ @<Make |cp| a cmyk colored object in object list~|p|@>= +begin cp:=p; +while cp<>null do + begin if has_color(cp) then goto done5; + cp:=link(cp); + end; +done5:do_nothing; +end + +@ @<Make |cp| a grey colored object in object list~|p|@>= +begin cp:=p; +while cp<>null do + begin if has_color(cp) then goto done4; + cp:=link(cp); + end; +done4:do_nothing; +end + +@ @<Make |cp| a no colored object in object list~|p|@>= +begin cp:=p; +while cp<>null do + begin if has_color(cp) then goto done3; + cp:=link(cp); + end; +done3:do_nothing; +end + @ @<Make |pp| an object in list~|p| that needs a pen@>= begin pp:=p; while pp<>null do @@ -19444,7 +19798,7 @@ done2:do_nothing; end @ @<Copy the information from objects |cp|, |pp|, and |dp| into...@>= -if cp>void then @<Copy |cp|'s color into the colored objects linked to~|cp|@>; +@<Copy |cp|'s color into the colored objects linked to~|cp|@>; if pp>void then @<Copy |pen_p(pp)| into stroked and filled nodes linked to |pp|@>; if dp>void then @<Make stroked nodes linked to |dp| refer to |dash_p(dp)|@> @@ -19456,6 +19810,8 @@ while q<>null do begin red_val(q):=red_val(cp); green_val(q):=green_val(cp); blue_val(q):=blue_val(cp);@/ + black_val(q):=black_val(cp);@/ + color_model(q):=color_model(cp);@/ end; q:=link(q); end; @@ -19735,6 +20091,18 @@ start_sym:=0; @d message_code=0 @d err_message_code=1 @d err_help_code=2 +@d filename_template_code=3 +@d print_with_leading_zeroes(#)== g := pool_ptr; + print_int(#); g := pool_ptr-g; + if f>g then begin + pool_ptr := pool_ptr - g; + while f>g do begin + print_char("0"); + decr(f); + end; + print_int(#); + end; + f := 0 @<Put each...@>= primitive("message",message_command,message_code);@/ @@ -19743,10 +20111,13 @@ primitive("errmessage",message_command,err_message_code);@/ @!@:err_message_}{\&{errmessage} primitive@> primitive("errhelp",message_command,err_help_code);@/ @!@:err_help_}{\&{errhelp} primitive@> +primitive("filenametemplate",message_command,filename_template_code);@/ +@!@:filename_template_}{\&{filenametemplate} primitive@> @ @<Cases of |print_cmd...@>= message_command: if m<err_message_code then print("message") else if m=err_message_code then print("errmessage") + else if m=filename_template_code then print("filenametemplate") else print("errhelp"); @ @<Cases of |do_statement|...@>= @@ -19764,6 +20135,7 @@ else case m of end; err_message_code:@<Print string |cur_exp| as an error message@>; err_help_code:@<Save string |cur_exp| as the |err_help|@>; + filename_template_code:@<Save the filename template@>; end; {there are no other cases} flush_cur_exp(0); end; @@ -20980,6 +21352,11 @@ font_number=0..font_max; @ @<Glob...@>= font_info:array[0..font_mem_size] of memory_word; {height, width, and depth data} +@!font_enc_name:array[font_number] of str_number; + {encoding names, if any} +@!font_ps_name_fixed:array[font_number] of boolean; + {are the postscript names fixed already? } +@!mp_font_map: ^fm_entry_ptr; {pointer into AVL tree of font mappings} next_fmem:0..font_mem_size; {next unused entry in |font_info|} last_fnum:font_number; {last font number used so far} font_dsize:array[font_number] of scaled; @@ -21302,6 +21679,203 @@ if height_val(p)<-depth_val(p) then depth_val(p):=0; end +@ The new primitives fontmapfile and fontmapline. + +@<Declare action procedures for use by |do_statement|@>= +procedure do_mapfile; +begin get_x_next; scan_expression; +if cur_type<>string_type then @<Complain about improper map operation@> +else mpmapfile(cur_exp); +end; +procedure do_mapline; +begin get_x_next; scan_expression; +if cur_type<>string_type then @<Complain about improper map operation@> +else begin mpmapline(cur_exp); + end; +end; + +@ @<Complain about improper map operation@>= +begin exp_err("Unsuitable expression"); +help1("Only known strings can be map files or map lines."); +put_get_error; +end + +@ the C code needs to know how to get at the null font, how remove +a string from memory, etc. + +@d is_valid_char(#)==((font_bc[f] <= #) and (# <= font_ec[f]) and + ichar_exists(char_info(f)(#))) + +@p function get_nullfont: font_number; +begin + get_nullfont := null_font; +end; +@# +procedure flush_str(s: str_number); {flush a string if possible} +begin + flush_string(s); +end; +@# +function get_nullstr: str_number; +begin + get_nullstr := ""; +end; +@# +function get_termandlogid: integer; +begin + get_termandlogid:=term_and_log; +end; +@# +function get_charwidth(f: font_number; c: eight_bits): scaled; +begin + if is_valid_char(c) then + get_charwidth := char_width(f)(char_info(f)(c)) + else + get_charwidth := 0; +end; +@# +function tfm_lookup(s: str_number; fs: scaled): font_number; +{looks up for a TFM with name |s| loaded at |fs| size; if found then flushes |s|} +var k: font_number; +begin + if fs <> 0 then begin { should not be used! } + for k := null_font + 1 to last_fnum do + if str_vs_str(font_name[k], s) and (font_sizes[k] = fs) then begin + flush_str(s); + tfm_lookup := k; + return; + end; + end + else begin + for k := null_font + 1 to last_fnum do + if str_vs_str(font_name[k], s) then begin + flush_str(s); + tfm_lookup := k; + return; + end; + end; + tfm_lookup := null_font; + exit: +end; +@# +function new_dummy_font: font_number; +begin + new_dummy_font := read_font_info("dummy"); +end; + +@x +function round_xn_over_d(@!x:scaled; @!n,@!d:integer):scaled; +var positive:boolean; {was |x>=0|?} +@!t,@!u,@!v:nonnegative_integer; {intermediate quantities} +begin if x>=0 then positive:=true +else begin negate(x); positive:=false; + end; +t:=(x mod @'100000)*n; +u:=(x div @'100000)*n+(t div @'100000); +v:=(u mod d)*@'100000 + (t mod @'100000); +if u div d>=@'100000 then arith_error:=true +else u:=@'100000*(u div d) + (v div d); +v := v mod d; +if 2*v >= d then + incr(u); +if positive then + round_xn_over_d := u +else + round_xn_over_d := -u; +end; + + +@ +@<Declare the \ps\ output procedures@>= +procedure ps_print_cmd(@!l:str_number;@!s:str_number); +begin +if internal[mpprocset]>0 then begin ps_room(length(s)); print(s); end +else begin ps_room(length(l)); print(l); end; +end; +@# +procedure print_cmd(@!l:str_number;@!s:str_number); +begin +if internal[mpprocset]>0 then print(s) else print(l); +end; +@# +function mp_char_marked(@!f:font_number;@!c: eight_bits): boolean; +var @!b:integer; {|char_base[f]|} +begin b:=char_base[f]; + if (c>=font_bc[f])and(c<=font_ec[f])and(font_info[b+c].qqqq.b3<>0) then + mp_char_marked:=true + else + mp_char_marked:=false; +end; + +@ The fontmap entries need a typedef + +@<Types...@>= +fm_entry_ptr = ^integer; +@!nonnegative_integer=0..@'17777777777; {$0\L x<2^{31}$} + +@ To print |scaled| value to PDF output we need some subroutines to ensure +accurary. + +@d max_integer == @"7FFFFFFF {$2^{31}-1$} +@d call_func(#) == begin if # <> 0 then do_nothing end + +@<Glob...@>= +@!one_bp: scaled; {scaled value corresponds to 1bp} +@!one_hundred_bp: scaled; {scaled value corresponds to 100bp} +@!one_hundred_inch: scaled; {scaled value corresponds to 100in} +@!ten_pow: array[0..9] of integer; {$10^0..10^9$} +@!scaled_out: integer; {amount of |scaled| that was taken out in +|divide_scaled|} + +@ @<Set init...@>= +one_bp := 65782; {65781.76} +one_hundred_bp := 6578176; +one_hundred_inch := 473628672; +ten_pow[0] := 1; +for i := 1 to 9 do + ten_pow[i] := 10*ten_pow[i - 1]; +mp_font_map:=xmalloc_array(fm_entry_ptr,font_max); +for i := null_font to font_max do begin + font_enc_name[i] := 0; + font_ps_name_fixed[i] := false; + mp_font_map[i] := 0; + end; + + + +@ The following function divides |s| by |m|. |dd| is number of decimal digits. + +@p function divide_scaled(s, m: scaled; dd: integer): scaled; +var q, r: scaled; + sign, i: integer; +begin + sign := 1; + if s < 0 then begin + sign := -sign; + s := -s; + end; + if m < 0 then begin + sign := -sign; + m := -m; + end; + if m = 0 then + confusion("arithmetic: divided by zero") + else if m >= (max_integer div 10) then + confusion("arithmetic: number too big"); + q := s div m; + r := s mod m; + for i := 1 to dd do begin + q := 10*q + (10*r) div m; + r := (10*r) mod m; + end; + if 2*r >= m then begin + incr(q); + r := r - m; + end; + scaled_out := sign*(s - (r div ten_pow[dd])); + divide_scaled := sign*q; +end; + @ The file |ps_tab_file| gives a table of \TeX\ font names and corresponding PostScript names for fonts that do not have to be downloaded, i.e., fonts that can be used when |internal[prologues]>0|. Each line consists of a \TeX\ name, @@ -21392,16 +21966,91 @@ file named according to the current \&{charcode}. @<Declare the \ps\ output procedures@>= procedure open_output_file; +label @!continue; { after a digit is seen} var @!c:integer; {\&{charcode} rounded to the nearest integer} @!old_setting:0..max_selector; {previous |selector| setting} -@!s:str_number; {a file extension derived from |c|} +@!s,n:str_number; {a file extension derived from |c|} +@!i:pool_pointer; { indexes into |filename_template| } +@!cc:integer; {a temporary integer for template building } +@!f,g:integer; {field widths} begin if job_name=0 then open_log_file; c:=round_unscaled(internal[char_code]); -if c<0 then s:=".ps" -else @<Use |c| to compute the file extension |s|@>; -pack_job_name(s); -while not a_open_out(ps_file) do - prompt_file_name("file name for output",s); +if filename_template=0 then begin + if c<0 then s:=".ps" + else @<Use |c| to compute the file extension |s|@>; + pack_job_name(s); + while not a_open_out(ps_file) do + prompt_file_name("file name for output",s); + end +else begin + {initializations} + s := ""; + n := ""; + old_setting:=selector; selector:=new_string; + f := 0; + i := str_start[filename_template]; + while i<str_stop(filename_template) do begin + if so(str_pool[i])="%" then begin + continue: + incr(i); + if i<str_stop(filename_template) then + begin + if so(str_pool[i])="j" then + print(job_name) + else if so(str_pool[i])="d" then begin + cc:= round_unscaled(internal[day]); + print_with_leading_zeroes(cc); + end + else if so(str_pool[i])="m" then begin + cc:= round_unscaled(internal[month]); + print_with_leading_zeroes(cc); + end + else if so(str_pool[i])="y" then begin + cc:= round_unscaled(internal[year]); + print_with_leading_zeroes(cc); + end + else if so(str_pool[i])="H" then begin + cc:= round_unscaled(internal[time]) div 60; + print_with_leading_zeroes(cc); + end + else if so(str_pool[i])="M" then begin + cc:= round_unscaled(internal[time]) mod 60; + print_with_leading_zeroes(cc); + end + else if so(str_pool[i])="c" then begin + if c<0 then print("ps") + else begin + print_with_leading_zeroes(c); + end; + end + else if (so(str_pool[i])>="0") and (so(str_pool[i])<="9") then begin + if (f<10) then + f := (f*10) + so(str_pool[i])-"0"; + goto continue; + end + else + print(str_pool[i]) + end + end + else begin + if so(str_pool[i])="." then + if n="" then + n := make_string; + print(str_pool[i]); + end; + incr(i); + end; + s := make_string; + selector:= old_setting; + if n="" then begin + n:=s; + s:=""; + end; + pack_file_name(n,"",s); + while not a_open_out(ps_file) do + prompt_file_name("file name for output",s); + delete_str_ref(n); + end; delete_str_ref(s); @<Store the true output file name if appropriate@>; @<Begin the progress report for the ouput of picture~|c|@>; @@ -21504,13 +22153,13 @@ var @!p,@!q:pointer; {for scanning the path} @!d:scaled; {a temporary value} @!curved:boolean; {|true| unless the cubic is almost straight} begin ps_room(40); -if need_newpath then print("newpath "); +if need_newpath then print_cmd("newpath ","n "); need_newpath:=true; ps_pair_out(x_coord(h),y_coord(h)); -print("moveto");@/ +print_cmd("moveto","m");@/ p:=h; repeat if right_type(p)=endpoint then - begin if p=h then ps_print(" 0 0 rlineto"); + begin if p=h then ps_print_cmd(" 0 0 rlineto"," 0 0 r"); return; end; q:=link(p); @@ -21518,7 +22167,7 @@ q:=link(p); |p| to~|q|@>; p:=q; until p=h; -ps_print(" closepath"); +ps_print_cmd(" closepath"," p"); exit:end; @ @<Glob...@>= @@ -21534,11 +22183,11 @@ if curved then begin ps_pair_out(right_x(p),right_y(p)); ps_pair_out(left_x(q),left_y(q)); ps_pair_out(x_coord(q),y_coord(q)); - ps_print("curveto"); + ps_print_cmd("curveto","c"); end else if q<>h then begin ps_pair_out(x_coord(q),y_coord(q)); - ps_print("lineto"); + ps_print_cmd("lineto","l"); end @ Two types of straight lines come up often in \MP\ paths: @@ -21566,23 +22215,35 @@ if abs(right_x(p)-x_coord(p)-d)<=bend_tolerance then This allows us to be sure that \ps\ has the correct values when they are needed without wasting time and space setting them unnecessarily. +@d gs_node_size=10 +@d gs_red ==mem[gs_state+1].sc +@d gs_green ==mem[gs_state+2].sc +@d gs_blue ==mem[gs_state+3].sc +@d gs_black ==mem[gs_state+4].sc + {color from the last \&{setcmykcolor} or \&{setrgbcolor} or \&{setgray} command} +@d gs_colormodel==mem[gs_state+5].qqqq.b0 + {the current colormodel} +@d gs_ljoin ==mem[gs_state+5].qqqq.b1 +@d gs_lcap ==mem[gs_state+5].qqqq.b2 + {values from the last \&{setlinejoin} and \&{setlinecap} commands} +@d gs_adj_wx ==mem[gs_state+5].qqqq.b3 + {what resolution-dependent adjustment applies to the width} +@d gs_miterlim ==mem[gs_state+6].sc + {the value from the last \&{setmiterlimit} command} +@d gs_dash_p ==mem[gs_state+7].hh.lh + {edge structure for last \&{setdash} command} +@d gs_previous ==mem[gs_state+7].hh.rh + {backlink to the previous |gs_state| structure} +@d gs_dash_sc ==mem[gs_state+8].sc + {scale factor used with |gs_dash_p|} +@d gs_width ==mem[gs_state+9].sc + {width setting or $-1$ if no \&{setlinewidth} command so far} + @<Glob...@>= -@!gs_red,@!gs_green,@!gs_blue:scaled; - {color from the last \&{setrgbcolor} or \&{setgray} command} -@:setrgbcolor}{\&{setrgbcolor} command@> -@:setgray}{\&{setgray} command@> -@!gs_ljoin,@!gs_lcap:quarterword; - {values from the last \&{setlinejoin} and \&{setlinecap} commands} -@:setlinejoin}{\&{setlinejoin} command@> -@:setlinecap}{\&{setlinecap} command@> -@!gs_miterlim:scaled; {the value from the last \&{setmiterlimit} command} -@:setmiterlimit}{\&{setmiterlimit} command@> -@!gs_dash_p:pointer; {edge structure for last \&{setdash} command} -@:setdash}{\&{setdash} command@> -@!gs_dash_sc:scaled; {scale factor used with |gs_dash_p|} -@!gs_width:scaled; {width setting or $-1$ if no \&{setlinewidth} command so far} -@!gs_adj_wx:boolean; {what resolution-dependent adjustment applies to the width} -@:setlinewidth}{\&{setlinewidth} command@> +gs_state:pointer; + +@ @<Set init...@>= +gs_state:=null; @ To avoid making undue assumptions about the initial graphics state, these parameters are given special values that are guaranteed not to match anything @@ -21594,13 +22255,41 @@ to recover from a situation where we have lost track of the graphics state. @<Declare the \ps\ output procedures@>= procedure unknown_graphics_state(c:scaled); -begin gs_red:=c; gs_green:=c; gs_blue:=c;@/ -gs_ljoin:=3; -gs_lcap:=3; -gs_miterlim:=0;@/ -gs_dash_p:=void; -gs_dash_sc:=0; -gs_width:=-1; +var @!p:pointer; {to shift graphic states around} + @!k:quarterword; {a loop index for copying the |gs_state|} +begin if (c=0)or(c=-1) then begin + if gs_state=null then begin + gs_state := get_node(gs_node_size); + gs_previous:=null; + end + else begin + while gs_previous<>null do begin + p := gs_previous; + free_node(gs_state,gs_node_size); + gs_state:=p; + end; + end; + gs_red:=c; gs_green:=c; gs_blue:=c; gs_black:=c;@/ + gs_colormodel:=uninitialized_model; + gs_ljoin:=3; + gs_lcap:=3; + gs_miterlim:=0;@/ + gs_dash_p:=void; + gs_dash_sc:=0; + gs_width:=-1; + end +else if c=1 then begin + p:= gs_state; + gs_state := get_node(gs_node_size); + for k:=1 to gs_node_size-1 do + mem[gs_state+k]:=mem[p+k]; + gs_previous := p; + end +else if c=2 then begin + p := gs_previous; + free_node(gs_state,gs_node_size); + gs_state:=p; + end; end; @ When it is time to output a graphical object, |fix_graphics_state| ensures @@ -21635,7 +22324,7 @@ if type(p)=stroked_code then if gs_lcap<>lcap_val(p) then begin ps_room(13); print_char(" "); - print_char("0"+lcap_val(p)); print(" setlinecap"); + print_char("0"+lcap_val(p)); print_cmd(" setlinecap"," lc"); gs_lcap:=lcap_val(p); end @@ -21643,36 +22332,86 @@ if type(p)=stroked_code then if gs_ljoin<>ljoin_val(p) then begin ps_room(14); print_char(" "); - print_char("0"+ljoin_val(p)); print(" setlinejoin"); + print_char("0"+ljoin_val(p)); print_cmd(" setlinejoin"," lj"); gs_ljoin:=ljoin_val(p); end; if gs_miterlim<>miterlim_val(p) then begin ps_room(27); print_char(" "); - print_scaled(miterlim_val(p)); print(" setmiterlimit"); + print_scaled(miterlim_val(p)); print_cmd(" setmiterlimit"," ml"); gs_miterlim:=miterlim_val(p); end @ @<Make sure \ps\ will use the right color for object~|p|@>= -if (gs_red<>red_val(p))or(gs_green<>green_val(p))or@| - (gs_blue<>blue_val(p)) then - begin gs_red:=red_val(p); - gs_green:=green_val(p); - gs_blue:=blue_val(p);@/ - if (gs_red=gs_green)and(gs_green=gs_blue) then - begin ps_room(16); - print_char(" "); - print_scaled(gs_red); - print(" setgray"); +begin + if (color_model(p)=rgb_model)or@| + ((color_model(p)=uninitialized_model)and + ((internal[default_color_model] div unity)=rgb_model)) then + begin if (gs_colormodel<>rgb_model)or(gs_red<>red_val(p))or@| + (gs_green<>green_val(p))or(gs_blue<>blue_val(p)) then + begin gs_red:=red_val(p); + gs_green:=green_val(p); + gs_blue:=blue_val(p); + gs_black:= -1;@/ + gs_colormodel:=rgb_model; + begin ps_room(36); + print_char(" "); + print_scaled(gs_red); print_char(" "); + print_scaled(gs_green); print_char(" "); + print_scaled(gs_blue); + print_cmd(" setrgbcolor", " R"); + end; + end; end - else begin ps_room(36); - print_char(" "); - print_scaled(gs_red); print_char(" "); - print_scaled(gs_green); print_char(" "); - print_scaled(gs_blue); - print(" setrgbcolor"); + else if (color_model(p)=cmyk_model)or@| + ((color_model(p)=uninitialized_model)and + ((internal[default_color_model] div unity)=cmyk_model)) then + begin if (gs_red<>cyan_val(p))or(gs_green<>magenta_val(p))or@| + (gs_blue<>yellow_val(p))or(gs_black<>black_val(p))or@| + (gs_colormodel<>cmyk_model) then + begin + if color_model(p)=uninitialized_model then begin + gs_red:=unity; + gs_green:=unity; + gs_blue:=unity; + gs_black:=unity;@/ + end + else begin + gs_red:=cyan_val(p); + gs_green:=magenta_val(p); + gs_blue:=yellow_val(p); + gs_black:=black_val(p);@/ + end; + gs_colormodel:=cmyk_model; + begin ps_room(45); + print_char(" "); + print_scaled(gs_red); print_char(" "); + print_scaled(gs_green); print_char(" "); + print_scaled(gs_blue); print_char(" "); + print_scaled(gs_black); + print_cmd(" setcmykcolor"," C"); + end; + end; + end + else if (color_model(p)=grey_model)or@| + ((color_model(p)=uninitialized_model)and + ((internal[default_color_model] div unity)=grey_model)) then + begin if (gs_red<>grey_val(p))or(gs_colormodel<>grey_model) then + begin gs_red := grey_val(p); + gs_green:= -1; + gs_blue:= -1; + gs_black:= -1;@/ + gs_colormodel:=grey_model; + begin ps_room(16); + print_char(" "); + print_scaled(gs_red); + print_cmd(" setgray"," G"); + end; + end; end; - end; + if color_model(p)=no_model then + gs_colormodel:=no_model; +end @ In order to get consistent widths for horizontal and vertical pen strokes, we want \ps\ to use an integer number of pixels for the \&{setwidth} parameter. @@ -21700,11 +22439,19 @@ if (ww<>gs_width) or (adj_wx<>gs_adj_wx) then begin if adj_wx then begin ps_room(13); print_char(" "); print_scaled(ww); - ps_print(" 0 dtransform exch truncate exch idtransform pop setlinewidth"); + ps_print_cmd(" 0 dtransform exch truncate exch idtransform pop setlinewidth"," hlw"); end - else begin ps_room(15); - print(" 0 "); print_scaled(ww); - ps_print(" dtransform truncate idtransform setlinewidth pop"); + else begin + if internal[mpprocset]>0 then begin + ps_room(13); + print_char(" "); + print_scaled(ww); + ps_print(" vlw"); + end + else begin ps_room(15); + print(" 0 "); print_scaled(ww); + ps_print(" dtransform truncate idtransform setlinewidth pop"); + end; end; gs_width := ww; gs_adj_wx := adj_wx; @@ -21792,7 +22539,7 @@ else begin hh:=dash_p(p); end; if hh=null then begin if gs_dash_p<>null then - begin ps_print(" [] 0 setdash"); + begin ps_print_cmd(" [] 0 setdash"," rd"); gs_dash_p:=null; end; end @@ -21808,7 +22555,7 @@ cannot be printed without overflow. begin gs_dash_p:=hh; gs_dash_sc:=scf; if (dash_y(hh)=0) or (abs(dash_y(hh)) div unity >= el_gordo div scf) then - ps_print(" [] 0 setdash") + ps_print_cmd(" [] 0 setdash"," rd") else begin pp:=dash_list(hh); start_x(null_dash):=start_x(pp)+dash_y(hh);@/ ps_room(28); @@ -21821,7 +22568,7 @@ else begin pp:=dash_list(hh); ps_room(22); print("] "); print_scaled(take_scaled(dash_offset(hh),scf)); - print(" setdash"); + print_cmd(" setdash"," sd"); end; end @@ -21869,10 +22616,29 @@ begin transformed:=false;@/ translation@>; @<Tweak the transformation parameters so the transformation is nonsingular@>; ps_path_out(path_p(h));@/ -if fill_also then print_nl("gsave fill grestore"); -@<Issue \ps\ commands to transform the coordinate system@>; -ps_print(" stroke"); -if transformed then ps_print(" grestore"); +if internal[mpprocset]=0 then begin + if fill_also then print_nl("gsave fill grestore"); + @<Issue \ps\ commands to transform the coordinate system@>; + ps_print(" stroke"); + if transformed then ps_print(" grestore"); + end +else begin + if fill_also then print_nl("B") else print_ln; + if (txy<>0)or(tyx<>0) then + begin {print_ln;} + print(" ["); + ps_pair_out(txx,tyx); + ps_pair_out(txy,tyy);@/ + ps_print("0 0] t"); + end + else if (txx<>unity)or(tyy<>unity) then + begin {print_ln;} + ps_pair_out(txx,tyy); + print(" s"); + end; + ps_print(" S"); + if transformed then ps_print(" Q"); +end; print_ln; end; @@ -21883,7 +22649,7 @@ tyx:=left_y(p);@/ txy:=right_x(p); tyy:=right_y(p); if (x_coord(p)<>0)or(y_coord(p)<>0) then - begin print_nl("gsave "); + begin print_ln; print_cmd("gsave ","q "); ps_pair_out(x_coord(p),y_coord(p)); ps_print("translate ");@/ txx:=txx-x_coord(p); @@ -21908,7 +22674,7 @@ if gs_width<>unity then end; if (txy<>0)or(tyx<>0)or(txx<>unity)or(tyy<>unity) then if (not transformed) then - begin ps_print("gsave "); + begin ps_print_cmd("gsave ","q "); transformed:=true; end @@ -21956,7 +22722,7 @@ if abs(det)<d1 then @<Declare the \ps\ output procedures@>= procedure ps_fill_out(@!p:pointer); {fill cyclic path~|p|} begin ps_path_out(p); -ps_print(" fill"); +ps_print_cmd(" fill"," F"); print_ln; end; @@ -22235,7 +23001,7 @@ end; last_pending:=spec_head; @ @<Cases of |do_statement|...@>= -special_command:do_special; +special_command: if cur_mod=0 then do_special else if cur_mod=1 then do_mapfile else do_mapline; @ @<Declare action procedures for use by |do_statement|@>= procedure do_special; @@ -22271,7 +23037,7 @@ setting is saved in a global variable so that |begin_diagnostic| can access it. @<Declare the \ps\ output procedures@>= procedure ship_out(@!h:pointer); {output edge structure |h|} -label done,found; +label done,done2,found,found2,found3; var @!p:pointer; {the current graphical object} @!q:pointer; {something that |p| points to} @!t:integer; {a temporary value} @@ -22283,12 +23049,42 @@ var @!p:pointer; {the current graphical object} @!ds,@!scf:scaled; {design size and scale factor for a text node} @!transformed:boolean; {is the coordinate system being transformed?} begin open_output_file; -if (internal[prologues]>0) and (last_ps_fnum<last_fnum) then - read_psname_table; non_ps_setting:=selector; selector:=ps_file_only;@/ +if (internal[prologues]=two)or(internal[prologues]=three) then begin + @<Print improved initial comment and bounding box for edge structure~|h|@>; + @<Scan all the text nodes and mark the used characters@>; + mploadencodings(last_fnum); + @<Update encoding names@>; + @<Print the improved prologue and setup@>; + @<Print any pending specials@>; + unknown_graphics_state(0); + need_newpath:=true; + p:=link(dummy_loc(h)); + while p<>null do + begin if has_color(p) then + if (pre_script(p))<>null then begin + print_nl (pre_script(p)); print_ln; + end; + fix_graphics_state(p); + case type(p) of + @<Cases for translating graphical object~|p| into \ps@>@; + start_bounds_code,stop_bounds_code: do_nothing; + end; {all cases are enumerated} + p:=link(p); + end; + print_cmd("showpage","P"); print_ln; + print("%%EOF"); print_ln; + a_close(ps_file); + selector:=non_ps_setting; + if internal[prologues]<=0 then clear_sizes; + @<End progress report@>; + end +else begin @<Print the initial comment and give the bounding box for edge structure~|h|@>; +if (internal[prologues]>0) and (last_ps_fnum<last_fnum) then + read_psname_table; print("%%BeginProlog"); print_ln; -if internal[prologues]>0 then @<Print the prologue@>; +if (internal[prologues]>0)or(internal[mpprocset]>0) then @<Print the prologue@>; print("%%EndProlog"); print_nl("%%Page: 1 1"); print_ln; @<Print any pending specials@>; @@ -22296,22 +23092,397 @@ unknown_graphics_state(0); need_newpath:=true; p:=link(dummy_loc(h)); while p<>null do - begin fix_graphics_state(p); + begin if has_color(p) then + if (pre_script(p))<>null then begin + print_nl (pre_script(p)); print_ln; + end; + fix_graphics_state(p); case type(p) of @<Cases for translating graphical object~|p| into \ps@>@; start_bounds_code,stop_bounds_code: do_nothing; end; {all cases are enumerated} p:=link(p); end; -print("showpage"); print_ln; +print_cmd("showpage","P"); print_ln; print("%%EOF"); print_ln; a_close(ps_file); selector:=non_ps_setting; if internal[prologues]<=0 then clear_sizes; @<End progress report@>; +end; if internal[tracing_output]>0 then print_edges(h," (just shipped out)",true); end; +@ @<Print the procset@>= + begin + print_nl("/hlw{0 dtransform exch truncate exch idtransform pop setlinewidth}bd"); + print_nl("/vlw{0 exch dtransform truncate idtransform setlinewidth pop}bd"); + print_nl("/l{lineto}bd/r{rlineto}bd/c{curveto}bd/m{moveto}bd/p{closepath}bd/n{newpath}bd"); + print_nl("/C{setcmykcolor}bd/G{setgray}bd/R{setrgbcolor}bd/lj{setlinejoin}bd/ml{setmiterlimit}bd"); + print_nl("/lc{setlinecap}bd/S{stroke}bd/F{fill}bd/q{gsave}bd/Q{grestore}bd/s{scale}bd/t{concat}bd"); + print_nl("/sd{setdash}bd/rd{[] 0 setdash}bd/P{showpage}bd/B{q F Q}bd/W{clip}bd"); + end + + +@ +@d applied_reencoding(#)==((font_is_reencoded(#))and + ((not font_is_subsetted(#))or(internal[prologues]=two))) + +@d ps_print_defined_name(#)==ps_print(" /"); + if (font_is_subsetted(#))and(font_is_included(#))and(internal[prologues]=three) + then print(fm_font_subset_name(#)) + else print(font_ps_name[#]); + if applied_reencoding(#) then begin ps_print("-"); + ps_print(font_enc_name[#]); end; + if fm_font_slant(#)<>0 then begin + ps_print("-Slant_"); print_int(fm_font_slant(#)) end; + if fm_font_extend(#)<>0 then begin + ps_print("-Extend_"); print_int(fm_font_extend(#)) end + +@<Print the improved prologue and setup@>= +begin + list_used_resources; + list_supplied_resources; + list_needed_resources; + print_nl("%%EndComments"); + print_nl("%%BeginProlog"); + if internal[mpprocset]>0 then + print_nl("%%BeginResource: procset mpost") + else + print_nl("%%BeginResource: procset mpost-minimal"); + print_nl("/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd"); + if internal[mpprocset]>0 then @<Print the procset@>; + print_nl("/fcp{findfont dup length dict begin{1 index/FID ne{def}{pop pop}ifelse}forall}bd"); + print_nl("/fmc{FontMatrix dup length array copy dup dup}bd/fmd{/FontMatrix exch def}bd"); + print_nl("/Amul{4 -1 roll exch mul 1000 div}bd/ExtendFont{fmc 0 get Amul 0 exch put fmd}bd"); + print_nl("/SlantFont{fmc 2 get dup 0 eq{pop 1}if Amul FontMatrix 0 get mul 2 exch put fmd}bd"); + print_nl("%%EndResource"); + @<Include encodings and fonts for edge structure~|h|@>; + print_nl("%%EndProlog"); + print_nl("%%BeginSetup"); + print_ln; + for f:=null_font+1 to last_fnum do begin + if font_sizes[f]<>null then begin + if hasfmentry(f) then begin + @<Write font definition@>; + ps_name_out(font_name[f],true); + ps_print_defined_name(f); + ps_print(" def"); + end + else begin + begin_diagnostic; + {selector:=term_and_log;} + print_err("Warning: font "); + print(font_name[f]); + print(" cannot be found in any fontmapfile!"); + end_diagnostic(true); + ps_name_out(font_name[f],true); + ps_name_out(font_name[f],true); + ps_print(" def"); + end; + print_ln; + end; + end; + print_nl("%%EndSetup"); + print_nl("%%Page: 1 1"); + print_ln; +end + +@ @<Write font definition@>= +if (applied_reencoding(f))or(fm_font_slant(f)<>0)or(fm_font_extend(f)<>0) then begin + if (font_is_subsetted(f))and(font_is_included(f))and(internal[prologues]=three) + then ps_name_out(fm_font_subset_name(f),true) + else ps_name_out(font_ps_name[f],true); + ps_print(" fcp"); + print_ln; + if applied_reencoding(f) then begin + ps_print("/Encoding "); + ps_print(font_enc_name[f]); + ps_print(" def "); + end; + if fm_font_slant(f)<>0 then begin + print_int(fm_font_slant(f)); + ps_print(" SlantFont "); + end; + if fm_font_extend(f)<>0 then begin + print_int(fm_font_extend(f)); + ps_print(" ExtendFont "); + end; + ps_print("currentdict end"); + print_ln; + ps_print_defined_name(f); + ps_print(" exch definefont pop"); + print_ln; +end + +@ Included subset fonts do not need and encoding vector, make +sure we skip that case. + +@p procedure list_used_resources; +label found,found2; +var @!f,ff:font_number; {fonts used in a text node or as loop counters} +@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)} +firstitem:boolean; +begin +if internal[mpprocset]>0 then + print_nl("%%DocumentResources: procset mpost") +else + print_nl("%%DocumentResources: procset mpost-minimal"); +ldf:=null_font; +firstitem:=true; +for f:=null_font+1 to last_fnum do + if (font_sizes[f]<>null)and(font_is_reencoded(f)) then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_enc_name[f],font_enc_name[ff])=0 then + goto found; + if font_is_subsetted(f) then + goto found; + if ps_offset+1+length(font_enc_name[f])>max_print_line then + print_nl("%%+ encoding"); + if firstitem then begin + firstitem:=false; + print_nl("%%+ encoding"); + end; + print_char(" "); + print(font_enc_name[f]); + ldf:=f; + found: + end; +ldf:=null_font; +firstitem:=true; +for f:=null_font+1 to last_fnum do + if font_sizes[f]<>null then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_name[f],font_name[ff])=0 then + goto found2; + if ps_offset+1+length(font_ps_name[f])>max_print_line then + print_nl("%%+ font"); + if firstitem then begin + firstitem:=false; + print_nl("%%+ font"); + end; + print_char(" "); + if (internal[prologues]=three)and(font_is_subsetted(f)) then + print(fm_font_subset_name(f)) + else + print(font_ps_name[f]); + ldf:=f; + found2: + end; +print_ln; +end; + +@ +@p procedure list_supplied_resources; +label found,found2; +var @!f,ff:font_number; {fonts used in a text node or as loop counters} +@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)} +firstitem:boolean; +begin +if internal[mpprocset]>0 then + print_nl("%%DocumentSuppliedResources: procset mpost") +else + print_nl("%%DocumentSuppliedResources: procset mpost-minimal"); +ldf:=null_font; +firstitem:=true; +for f:=null_font+1 to last_fnum do + if (font_sizes[f]<>null)and(font_is_reencoded(f)) then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_enc_name[f],font_enc_name[ff])=0 then + goto found; + if (internal[prologues]=three)and(font_is_subsetted(f))then + goto found; + if ps_offset+1+length(font_enc_name[f])>max_print_line then + print_nl("%%+ encoding"); + if firstitem then begin + firstitem:=false; + print_nl("%%+ encoding"); + end; + print_char(" "); + print(font_enc_name[f]); + ldf:=f; + found: + end; +ldf:=null_font; +firstitem:=true; +if internal[prologues]=three then begin + for f:=null_font+1 to last_fnum do + if font_sizes[f]<>null then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_name[f],font_name[ff])=0 then + goto found2; + if not font_is_included(f) then + goto found2; + if ps_offset+1+length(font_ps_name[f])>max_print_line then + print_nl("%%+ font"); + if firstitem then begin + firstitem:=false; + print_nl("%%+ font"); + end; + print_char(" "); + if font_is_subsetted(f) then + print(fm_font_subset_name(f)) + else + print(font_ps_name[f]); + ldf:=f; + found2: + end; + print_ln; +end; +end; + + +@ +@p procedure list_needed_resources; +label found,found2; +var @!f,ff:font_number; {fonts used in a text node or as loop counters} +@!ldf:font_number; {the last \.{DocumentFont} listed (otherwise |null_font|)} +firstitem:boolean; +begin +ldf:=null_font; +firstitem:=true; +for f:=null_font+1 to last_fnum do + if font_sizes[f]<>null then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_name[f],font_name[ff])=0 then + goto found; + if(internal[prologues]=three)and(font_is_included(f)) then + goto found; + if ps_offset+1+length(font_ps_name[f])>max_print_line then + print_nl("%%+ font"); + if firstitem then begin + firstitem:=false; + print_nl("%%DocumentNeededResources: font"); + end; + print_char(" "); + print(font_ps_name[f]); + ldf:=f; + found: + end; +if not firstitem then begin + print_ln; + ldf:=null_font; + firstitem:=true; + for f:=null_font+1 to last_fnum do + if font_sizes[f]<>null then + begin + for ff:=ldf downto null_font do + if font_sizes[ff]<>null then + if str_vs_str(font_name[f],font_name[ff])=0 then + goto found2; + if(internal[prologues]=three)and(font_is_included(f)) then + goto found2; + print("%%IncludeResource: font "); + print(font_ps_name[f]); + print_ln; + ldf:=f; + found2: + end; +end; +end; + +@ +@<Print improved initial comment and bounding box for edge...@>= +print("%!PS-Adobe-3.0 EPSF-3.0"); +print_nl("%%BoundingBox: "); +set_bbox(h,true); +if minx_val(h)>maxx_val(h) then print("0 0 0 0") +else begin ps_pair_out(floor_scaled(minx_val(h)),floor_scaled(miny_val(h))); + ps_pair_out(-floor_scaled(-maxx_val(h)),-floor_scaled(-maxy_val(h))); + end; +print_nl("%%HiResBoundingBox: "); +if minx_val(h)>maxx_val(h) then print("0 0 0 0") +else begin + ps_pair_out(minx_val(h),miny_val(h)); + ps_pair_out(maxx_val(h),maxy_val(h)); + end; +print_nl("%%Creator: MetaPost "); +print(metapost_version); +print_nl("%%CreationDate: "); +print_int(round_unscaled(internal[year])); print_char("."); +print_dd(round_unscaled(internal[month])); print_char("."); +print_dd(round_unscaled(internal[day])); print_char(":");@/ +t:=round_unscaled(internal[time]); +print_dd(t div 60); print_dd(t mod 60);@/ +print_nl("%%Pages: 1");@/ + +@ + +@ @<Include encodings and fonts for edge structure~|h|@>= +mpfontencodings(last_fnum,(internal[prologues]=two)); +@<Embed fonts that are available@> + +@ @<Scan all the text nodes and mark the used ...@>= +for f:=null_font+1 to last_fnum do begin + if font_sizes[f]<>null then begin + unmark_font(f); + font_sizes[f]:=null; + end; + if font_enc_name[f]<>0 then + delete_str_ref(font_enc_name[f]); + font_enc_name[f] := 0; +end; +for f:=null_font+1 to last_fnum do begin + p:=link(dummy_loc(h)); + while p<>null do + begin if type(p)=text_code then + if font_n(p)<>null_font then begin + font_sizes[font_n(p)] := void; + mark_string_chars(font_n(p),text_p(p)); + if hasfmentry(font_n(p)) then + font_ps_name[font_n(p)] := fm_font_name(font_n(p)); + end; + p:=link(p); + end; +end + +@ @<Update encoding names@>= +for f:=null_font+1 to last_fnum do begin + p:=link(dummy_loc(h)); + while p<>null do + begin if type(p)=text_code then + if font_n(p)<>null_font then + if hasfmentry(font_n(p)) then + if font_enc_name[font_n(p)]=0 then + font_enc_name[font_n(p)] := fm_encoding_name(font_n(p)); + p:=link(p); + end; +end + +@ @<Embed fonts that are available@>= +begin next_size:=0; +@<Make |cur_fsize| a copy of the |font_sizes| array@>; +repeat done_fonts:=true; +for f:=null_font+1 to last_fnum do + begin if cur_fsize[f]<>null then begin + if internal[prologues]=three then + if not dopsfont(f) then + if hasfmentry(f) then begin + print_err("Font embedding failed"); + error; + end; + cur_fsize[f]:=link(cur_fsize[f]); + if cur_fsize[f]<>null then + begin unmark_font(f); done_fonts:=false; @+end + end; + end; + if not done_fonts then + @<Increment |next_size| and apply |mark_string_chars| to all text nodes with + that size index@>; + until done_fonts; +end + + @ These special comments described in the {\sl PostScript Language Reference Manual}, 2nd.~edition are understood by some \ps-reading programs. We can't normally output ``conforming'' \ps\ because @@ -22466,41 +23637,61 @@ trouble. @:prologues_}{\&{prologues} primitive@> @<Print the prologue@>= -begin if ldf<>null_font then - begin for f:=null_font+1 to last_fnum do +begin +if ldf<>null_font then begin + if internal[prologues]>0 then begin + for f:=null_font+1 to last_fnum do if font_sizes[f]<>null then begin ps_name_out(font_name[f],true); ps_name_out(font_ps_name[f],true); ps_print(" def"); print_ln; end; - print("/fshow {exch findfont exch scalefont setfont show}bind def"); + if internal[mpprocset]=0 then begin + print("/fshow {exch findfont exch scalefont setfont show}bind def"); + print_ln; + end; + end; + end; +if internal[mpprocset]>0 then begin + if (internal[prologues]>0)and(ldf<>null_font) then + print("/bd{bind def}bind def/fshow {exch findfont exch scalefont setfont show}bd") + else + print_nl("/bd{bind def}bind def"); + @<Print the procset@>; print_ln; end; end -@ Since we do not have a stack for the graphics state, it is considered -completely unknown after the \.{grestore} from a stop clip object. Procedure -|unknown_graphics_state| needs a negative argument in this case. - -@<Cases for translating graphical object~|p| into \ps@>= -start_clip_code:begin print_nl("gsave "); +@ @<Cases for translating graphical object~|p| into \ps@>= +start_clip_code:begin print_nl(""); print_cmd("gsave ","q "); ps_path_out(path_p(p)); - ps_print(" clip"); + ps_print_cmd(" clip"," W"); print_ln; + if internal[restore_clip_color]>0 then + unknown_graphics_state(1); end; -stop_clip_code:begin print_nl("grestore"); +stop_clip_code:begin print_nl(""); print_cmd("grestore","Q"); print_ln; - unknown_graphics_state(-1); + if internal[restore_clip_color]>0 then + unknown_graphics_state(2) + else + unknown_graphics_state(-1); end; @ @<Cases for translating graphical object~|p| into \ps@>= -fill_code: if pen_p(p)=null then ps_fill_out(path_p(p)) +fill_code: begin + if pen_p(p)=null then ps_fill_out(path_p(p)) else if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,true) else begin do_outer_envelope(copy_path(path_p(p)), p); do_outer_envelope(htap_ypoc(path_p(p)), p); end; -stroked_code: if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,false) + if (post_script(p))<>null then begin + print_nl (post_script(p)); print_ln; + end; + end; +stroked_code: begin + if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,false) else begin q:=copy_path(path_p(p)); t:=lcap_val(p); @<Break the cycle and set |t:=1| if path |q| is cyclic@>; @@ -22508,6 +23699,10 @@ stroked_code: if pen_is_elliptical(pen_p(p)) then stroke_ellipse(p,false) ps_fill_out(q); toss_knot_list(q); end; + if (post_script(p))<>null then begin + print_nl (post_script(p)); print_ln; + end; + end; @ The envelope of a cyclic path~|q| could be computed by calling |make_envelope| once for |q| and once for its reversal. We don't do this @@ -22523,7 +23718,8 @@ if left_type(q)<>endpoint then end @ @<Cases for translating graphical object~|p| into \ps@>= -text_code: if (font_n(p)<>null_font) and (length(text_p(p))>0) then +text_code: begin + if (font_n(p)<>null_font) and (length(text_p(p))>0) then begin if internal[prologues]>0 then scf:=choose_scale(p) else scf:=indexed_size(font_n(p), name_type(p)); @@ -22535,6 +23731,10 @@ text_code: if (font_n(p)<>null_font) and (length(text_p(p))>0) then @<Print the size information and \ps\ commands for text node~|p|@>; print_ln; end; + if (post_script(p))<>null then begin + print_nl (post_script(p)); print_ln; + end; + end; @ @<Print the size information and \ps\ commands for text node~|p|@>= ps_room(18); @@ -22548,15 +23748,15 @@ if transformed then ps_print(" grestore") transformed:=(txx_val(p)<>scf)or(tyy_val(p)<>scf)or@| (txy_val(p)<>0)or(tyx_val(p)<>0); if transformed then - begin print("gsave ["); + begin print_cmd("gsave [", "q ["); ps_pair_out(make_scaled(txx_val(p),scf),@|make_scaled(tyx_val(p),scf)); ps_pair_out(make_scaled(txy_val(p),scf),@|make_scaled(tyy_val(p),scf)); ps_pair_out(tx_val(p),ty_val(p));@/ - ps_print("] concat 0 0 moveto"); + ps_print_cmd("] concat 0 0 ","] t 0 0"); end else begin ps_pair_out(tx_val(p),ty_val(p)); - ps_print("moveto"); end; +ps_print_cmd("moveto","m"); print_ln @ Now that we've finished |ship_out|, let's look at the other commands @@ -22961,6 +24161,8 @@ tini@/ ready_already:=314159; start_of_MP: @<Initialize the output routines@>; @<Get the first line of input and prepare to start@>; +mp_init_map_file; +setjobid(internal[year],internal[month],internal[day],internal[time]); history:=spotless; {ready to go!} if start_sym>0 then {insert the `\&{everyjob}' symbol} begin cur_sym:=start_sym; back_input; @@ -23219,6 +24421,14 @@ for postprocessing. @<Character |k| is not allowed in PostScript output@>= (k<=" ")or(k>"~") +@ Saving the filename template + +@<Save the filename template@>= +begin if filename_template<>0 then delete_str_ref(filename_template); +if length(cur_exp)=0 then filename_template:=0 +else begin filename_template:=cur_exp; add_str_ref(filename_template); + end; +end @* \[48] System-dependent changes. This section should be replaced, if necessary, by any special modification of the program |