texlive-metapost 2009-15 / usr / share / texmf-texlive / metapost / mpattern / mpattern.mp

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% This file is part of the MPATTERN package
%
% mpattern.mp: MetaPost macros for pattern defining and filling
%
% Author: Piotr Bolek
% version 0.5: (Jun 25, 2001)
%
% $Id: mpattern.mp,v 1.3 2001/06/25 07:28:14 piotrek Exp $
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

boolean P_dict_;
boolean P_used_already_;
% Record all numbers (charcode) of pictures
extra_beginfig := extra_beginfig
  & "numeric Pwritten_[]; Pcharcode_[charcode]=1; P_used_already_:=false; P_dict_:=false;";

% Working variables to store fragments of Pattern definition
string PBBox_, PHead_, PTail_, PPaintProc_, Pname_, Pdefs_;
string Pmatrix_;

PHead_="<< /PaintType 1 /PatternType 1 /TilingType 1 ";
% 11.08.98 PPaintProc_="/PaintProc { begin ";
PPaintProc_="/PaintProc {  pop ";
% 11.08.98 PTail_=" end } >>"; % matrix makepattern";
PTail_="  } >>"; % matrix makepattern";
Pdefs_="";
   
% New line string
string Pnl_; Pnl_=char 13;

% Number of defined patterns
numeric Pnum_; Pnum_=0;

% Split string defining pattern on new line chars
% and use each piece as argument to special
vardef Psplit_and_write_(expr s)=
   save Pfirst_, Plast_;
   Pfirst_:=0; Plast_:=0;
   for i=0 upto length(s):
      if ( substring (i,i+1) of s = Pnl_ ):
	 Plast_:=i;
	 special substring (Pfirst_,Plast_) of s;
	 Pfirst_:=i+1;
      fi;
   endfor;
enddef;

% Find maximum charcode not used for picture yet
vardef Pmax_charcode_=
   save Pn_;
   for i=999 downto 1:
      Pn_:=i;
      exitif unknown Pcharcode_[i];
   endfor;
   Pn_
enddef;

def PmakeBB_=
   PBBox_ := "/BBox [" & decimal Plft_ & " " & decimal Plow_ & " "
   & decimal Prt_ & " " & decimal Pup_ & "]" & Pnl_;
enddef;

def Psteps_=
   PBBox_ := PBBox_ & "/XStep " & decimal
   if unknown PXStep_: (Prt_-Plft_) else: PXStep_ fi & Pnl_
   & "/YStep " & decimal
   if unknown PYStep_:  (Pup_-Plow_) else: PYStep_ fi;
enddef;
   
vardef Pfindbounds_=
%   save Plow_, Plft_, Pup_, Prt_;
%   numeric Plow_, Plft_, Pup_, Prt_;

   Plow_ = ypart (llcorner currentpicture);
   Plft_ = xpart (llcorner currentpicture);
   Pup_ = ypart (urcorner currentpicture);
   Prt_ = xpart (urcorner currentpicture);
   
   PmakeBB_;
enddef;

% Read file in which the body of patterns PaintProc is stored
vardef PReadFile_=
   save Pfile_, Pline_, Pall_;
   string Pfile_, Pline_, Pall_;
   Pline_=Pall_="";
   Pfile_:=jobname & "." & decimal charcode;
   forever:
      Pline_ := readfrom Pfile_;
      exitif Pline_ = EOF;
      if (substring(length Pline_-3,length Pline_) of Pline_ = "def")
	  and (substring (0,6) of Pline_ <> "/fshow"):
	 Pdefs_ := Pdefs_ & Pline_ & Pnl_;
      else:
	   if (substring (0,2) of Pline_ = "%%")
	      or (substring (0,8) of Pline_ = "showpage")
	      or (substring (0,4) of Pline_ = "%!PS")
	      or (substring (0,6) of Pline_ = "/fshow"):
	   else:
		Pall_:=Pall_ & Pline_ & Pnl_;
	   fi;
      fi;
   endfor;
   Pall_
enddef;

% Join all parts of pattern definition 
vardef PmakePattern_(expr name)=
   save Pread_;
   string Pread_;

   Pread_ = PReadFile_;
   
   % Write string used later to identify pattern
%   batchmode;
%   message "Defining pattern " & name & "->" & decimal (Pnum_*epsilon);
%   errorstopmode;
   "% Pattern:" &
      if (not known PColor_):
          decimal (Pnum_*epsilon)
      else:
          decimal (PColor_)
      fi
      & ":" & name & Pnl_
      & PHead_ & Pnl_
      & PBBox_ & Pnl_
      & Pdefs_
      & PPaintProc_ & Pnl_
      & Pread_ 
      & PTail_ & Pnl_
      & Pmatrix_ & " makepattern" & Pnl_
      & "/" & name & " exch def" & Pnl_
      & "MPP " &
      if (not known PColor_):
	decimal (Pnum_*epsilon)
      else:
	decimal (PColor_)
      fi
      & " " & name & " put"  & Pnl_
enddef;

% find PatternColor -- color which will be replaced by pattern
vardef Pfindcolor_(expr s)=
   save Pfirst_, Plast_;
   numeric Pfirst_, Plast_;
   Pfirst_=Plast_=0;
   for i=0 upto 255:
      if substring(i,i+1) of s=":":
	 if Pfirst_=0:
	    Pfirst_:=i+1;
	 else:
	      Plast_:=i;
	 fi;
      fi;
      exitif Plast_<>0;
   endfor;
   scantokens (substring (Pfirst_,Plast_) of s)
enddef;

%%%%%%%%%%%%%% User interface macros

% Define BoundingBox of pattern
vardef patternbbox(expr a)(text b)=
%   save Plft_, Plow_, Prt_, Pup_, Pi_, Pz_;
%   numeric Plft_, Plow_, Prt_, Pup_, Pi_, Pz_[];
   save Pi_, Pz_;
   numeric Pi_, Pz_[];
   if pair a:
      Plft_:=min(xpart(a),xpart(b)); Plow_:=min(ypart(a),ypart(b));
      Prt_:=max(xpart(a),xpart(b));  Pup_:=max(ypart(a),ypart(b));
   else:
      Pi_=1;
      for t=b:
	 Pz_[Pi_]=t;
	 Pi_:=Pi_+1;
      endfor;
      Plft_:=min(a,Pz_2);   Plow_:=min(Pz_1,Pz_3);
      Prt_:=max(a,Pz_2); Pup_:=max(Pz_1,Pz_3);
   fi;

   PmakeBB_;
enddef;

def beginpattern(suffix name)=
   numeric PXStep_, PYStep_;
   numeric Plow_, Plft_, Pup_, Prt_;
   numeric PColor_;
   Pmatrix_:=" matrix ";

   % Declare variable in which the pattern definition will be stored
   string name;
   Pname_:=str name;

   Pnum_:=Pnum_+1;
   
   % Use the largest available picture number (charcode)
   % for storing the body od patten PaintProc
   beginfig(Pmax_charcode_);
enddef;

def endpattern=
   if unknown PBBox_:
      Pfindbounds_;
   fi;
   endfig;
   Psteps_;

   begingroup;
   save Punknown_, Ppattern_;
   string Punknown_, Ppattern_;

   Ppattern_=PmakePattern_(Pname_);
   % free used charcode
   Pcharcode_[charcode]:=whatever;
   PBBox_:=Punknown_;
   Pdefs_:="";
   % Assign pattern to string variable
   scantokens(Pname_ & "=Ppattern_;");
   endgroup;
enddef;

primarydef p withpattern s=
   hide(
     if not P_dict_:       
       special "/MPP 100 dict def";
       special "/MPPshow {exch findfont exch scalefont setfont show}bind def";
       special "/fill { MPP currentgray known " & char 10 
       & "      { MPP currentgray get setpattern fill } { fill } " & char 10
       & "        ifelse } bind def";
       special "/fshow { MPP currentgray known " & char 10 
       & "      { MPP currentgray get setpattern MPPshow } { MPPshow } " & char 10
       & "        ifelse } bind def";
       P_dict_:=true;
     fi;
      Pc_:=Pfindcolor_(s);
	% write definition of pattern used in picture
	% but not yet written to output file;
	if unknown Pwritten_[Pc_]:
	   Psplit_and_write_(s);
	   Pwritten_[Pc_]:=1;
	fi;
	if not P_used_already_:
           batchmode;
           message "Pattern:" & decimal charcode;
           errorstopmode;
	   P_used_already_:=true;
	fi;
      %show p;
	)
   p withcolor Pc_*white
enddef;
   
def patterntransform expr t=
   Pmatrix_ := "[ " & decimal xxpart t
              & " " & decimal yxpart t
              & " " & decimal xypart t
              & " " & decimal yypart t
              & " " & decimal xpart t
              & " " & decimal ypart t & " ]";
%   show Pmatrix_;
enddef;

def patternxstep expr t=
   show t;
   PXStep_ = t;
enddef;

def patternystep expr t=
   show t;
   PYStep_ = t;
enddef;

def patternstep text t=
   show t;
   if pair t:
      PXStep_ = xpart t;
      PYStep_ = ypart t;
   else:
      (PXStep_,PYStep_)=t;
   fi;
enddef;

def patterncolor expr t=
   show t;
   PColor_ = t;
enddef;