summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/metapost
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2009-08-17 23:52:56 +0000
committerKarl Berry <karl@freefriends.org>2009-08-17 23:52:56 +0000
commit2a0a733df59b5c7d85d190c433cbe0d6fdadc89d (patch)
treeb73fb3ed2b7fbcf0106e14b1e00af89038513158 /Master/texmf-dist/metapost
parent73a57d66da93b7244ac5b75526fd95a00005b050 (diff)
new metapost package suanpan (11aug09)
git-svn-id: svn://tug.org/texlive/trunk@14741 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/metapost')
-rw-r--r--Master/texmf-dist/metapost/suanpan/abacus.mp138
-rw-r--r--Master/texmf-dist/metapost/suanpan/suanpan.mp501
2 files changed, 639 insertions, 0 deletions
diff --git a/Master/texmf-dist/metapost/suanpan/abacus.mp b/Master/texmf-dist/metapost/suanpan/abacus.mp
new file mode 100644
index 00000000000..fbd23eed722
--- /dev/null
+++ b/Master/texmf-dist/metapost/suanpan/abacus.mp
@@ -0,0 +1,138 @@
+input suanpan
+
+setup_abacus(N=13,NBL=5,NBU=2,bead="suanpan",units=0);
+
+% initial value of a suanpan
+beginfig(1);
+ rod_numbers:=false;
+ reset_abacus;
+ draw_abacus;
+endfig;
+
+
+setup_abacus(N=13,NBL=4,NBU=1,bead="soroban",units=1);
+
+% initial value of a soroban
+beginfig(2);
+ rod_numbers:=false;
+ reset_abacus;
+ draw_abacus;
+endfig;
+
+setup_abacus(N=13,NBL=5,NBU=2,bead="suanpan",units=0);
+beginfig(3);
+ rod_numbers:=true;
+ reset_abacus;
+ valL[1]:=2;
+ valL[3]:=5;
+ valU[2]:=1;
+ valU[4]:=2;
+ draw_abacus;
+endfig;
+
+beginfig(4);
+ reset_abacus;
+ set_abacus_val("10552");
+ draw_abacus;
+endfig;
+
+beginfig(10);
+ reset_abacus;
+ valL[1]:=2;
+ valL[3]:=5;
+ valU[2]:=1;
+ valU[4]:=2;
+ draw_abacus;
+endfig;
+
+beginfig(20);
+ reset_abacus;
+ valL[1]:=3;
+ valL[3]:=5;
+ valU[2]:=1;
+ valU[4]:=2;
+ draw_abacus;
+endfig;
+
+% soroban?
+beginfig(30);
+ setup_abacus(N=13,NBL=4,NBU=1,bead="soroban",units=1);
+ set_abacus_val("651324");
+ set_abacus_gray(deck="lower",below="000011",
+ above="000010");
+ set_abacus_gray(deck="upper",below="000001",
+ above="000010");
+ draw_abacus;
+ mark_abacus(i=1,j=5)(btex 1 etex);
+ mark_abacus(i=2,j=2)(btex 2 etex);
+ mark_abacus(i=2,j=3)(btex 3 etex);
+endfig;
+
+
+%show_val;
+
+setup_abacus(N=13,NBL=4,NBU=1,bead="soroban",units=1);
+set_abacus_val("651324");
+reset_abacus_gray;
+add_val(v="82363456",iv=100,fig=true);
+%message "**********************************";
+%show_val;
+
+setup_abacus(N=13,NBL=5,NBU=2,bead="suanpan",units=0);
+
+% detailing one of the addition cases
+beginfig(200);
+ reset_abacus;
+ reset_abacus_gray;
+ set_abacus_val("82951324");
+ draw_abacus;
+endfig;
+
+beginfig(201);
+ set_abacus_val("82951324");
+ add_val(v="60000",iv=100,fig=false);
+ draw_abacus;
+endfig;
+
+%-------------------------------------------
+
+beginfig(202);
+ reset_abacus;
+ reset_abacus_gray;
+ set_abacus_val("82951324");
+ set_abacus_gray(deck="lower",below="1010000",
+ above="0400000");
+ set_abacus_gray(deck="upper",below="0110000",
+ above="0000000");
+ draw_abacus;
+endfig;
+
+beginfig(203);
+ reset_abacus_gray;
+ add_val(v="60000",iv=100,fig=false);
+ set_abacus_gray(deck="lower",below="0400000",
+ above="1010000");
+ set_abacus_gray(deck="upper",below="0000000",
+ above="0110000");
+ draw_abacus;
+ mark_abacus(i=5,j=5)(btex 1 etex);
+endfig;
+
+% the following two commands enable a base-8 abacus
+vbu:=4; % value of a bead in the upper deck
+setup_abacus(N=13,NBL=3,NBU=1,bead="suanpan",units=0);
+
+beginfig(300);
+ reset_abacus;
+ reset_abacus_gray;
+ set_abacus_val("3401256");
+ draw_abacus;
+endfig;
+
+beginfig(301);
+ add_val(v="1234",iv=100,fig=false);
+ draw_abacus;
+endfig;
+
+end
+
diff --git a/Master/texmf-dist/metapost/suanpan/suanpan.mp b/Master/texmf-dist/metapost/suanpan/suanpan.mp
new file mode 100644
index 00000000000..37745ea3a78
--- /dev/null
+++ b/Master/texmf-dist/metapost/suanpan/suanpan.mp
@@ -0,0 +1,501 @@
+% modeling of a suanpan (Chinese abacus)
+% D. Roegel 9 September - 12 October 2008
+%
+% These macros provide basic functions for producing suanpan (Chinese abacus)
+% figures as well as soroban ones (Japanese abacus)
+
+numeric u;
+u=1cm;
+
+% key-val mechanism (from LGC2, p. 59-60)
+vardef executekeyval(text k)=
+ save _equals;
+ let _equals= =;
+ tertiarydef _ll_ _assign _rr_ =
+ hide(_ll_ _equals _rr_ ) 1
+ enddef;
+ save =;
+ let = _equals _assign ;
+ for _xx_ _equals k:endfor;
+enddef;
+
+numeric n; % number of digits
+numeric nbl,vbu,nbu; % number of beads (lower/upper)
+ % vbu=value of a bead in the upper deck
+numeric hsep,vsep,beadw,thframe,beadsp,wdvline,hlwindow,huwindow;
+numeric wdframe,huwindow;
+
+numeric beadtype;
+boolean rod_numbers;
+rod_numbers=true; % default
+
+boolean overflow;
+
+numeric abacus_units;
+abacus_units=0; % a value of 1 marks every third rod by a dot
+ % other values may be used in the future
+
+n=13; % default
+vbu=5; % value of a bead in the upper deck
+nbl=5; % total beads below (lower deck)
+nbu=2; % total beads above (upper deck)
+hsep=.8u; % distance between lines of beads
+ihsep=.5hsep; % initial hsep
+vsep=.5u; % smallest distance between bead centers
+beadw=.4hsep; % bead width
+thframe=.3u; % frame thickness
+beadsp=u; % bead spacing
+wdvline=.1u; % thickness of bamboo lines
+beadtype=1; % 1=round (suanpan), 2=biconal (soroban)
+
+vardef setup_abacus(text kv)=
+ save N,NBL,NBU,bead,units; % key names
+ numeric N,NBL,NBU,units;
+ string bead;
+ executekeyval(kv);
+ n:=N;
+ nbl:=NBL;
+ nbu:=NBU;
+ abacus_units:=units;
+ wdframe:=(n-1)*hsep+2ihsep+2thframe;
+ htframe:=3thframe+(nbl+nbu-2)*vsep+vsep+vsep+2beadsp;
+ hlwindow:=(nbl-1)*vsep+vsep+beadsp; % height of lower window
+ huwindow:=htframe-3thframe-hlwindow; % height of upper window
+ if bead="suanpan":
+ beadtype:=1;
+ elseif bead="soroban":
+ beadtype:=2;
+ fi;
+enddef;
+
+vardef draw_abacus_frame=
+ save P;pair P[];
+ % -------------- outer frame --------------
+ P0=origin;
+ P1-P0=P2-P3=wdframe*right;
+ P2-P1=htframe*up;
+ draw P0--P1--P2--P3--cycle;
+ %--------- lower inner frame --------------
+ P4-P0=(thframe,thframe);
+ P5-P1=(-thframe,thframe);
+ P9=P0+(1.5thframe+hlwindow)*up;
+ P10-P9=P1-P0;
+ P7=P9+(thframe,-.5thframe);
+ P6-P7=P5-P4;
+ draw P4--P5--P6--P7--cycle;
+ %--------- upper inner frame --------------
+ P14-P9=(thframe,.5thframe);
+ P15-P10=(-thframe,.5thframe);
+ P16-P2=(-thframe,-thframe);
+ P17-P3=(thframe,-thframe);
+ draw P14--P15--P16--P17--cycle;
+enddef;
+
+vardef draw_abacus_rods=
+ save h,ha,hb,savep;
+ savep=savepen;
+ ha=hlwindow;
+ hb=huwindow;
+ h=ha+hb+thframe;
+ for i=1 upto n:
+ draw (thframe+ihsep+(i-1)*hsep-.5wdvline,thframe)
+ --(thframe+ihsep+(i-1)*hsep-.5wdvline,thframe+ha);
+ draw (thframe+ihsep+(i-1)*hsep+.5wdvline,thframe)
+ --(thframe+ihsep+(i-1)*hsep+.5wdvline,thframe+ha);
+ draw (thframe+ihsep+(i-1)*hsep-.5wdvline,thframe+h-hb)
+ --(thframe+ihsep+(i-1)*hsep-.5wdvline,thframe+h);
+ draw (thframe+ihsep+(i-1)*hsep+.5wdvline,thframe+h-hb)
+ --(thframe+ihsep+(i-1)*hsep+.5wdvline,thframe+h);
+ if rod_numbers:
+ label.bot(decimal i,(thframe+ihsep+(n-i)*hsep,0));
+ label.top(decimal i,(thframe+ihsep+(n-i)*hsep,2thframe+h));
+ fi
+ endfor;
+ pickup pencircle scaled 3pt;
+ if abacus_units=1:
+ for i=3 step 3 until n:
+ draw (thframe+ihsep+(n-i)*hsep,thframe+ha+.5thframe);
+ endfor;
+ fi;
+ pickup savep;
+enddef;
+
+numeric valU[],valL[],vl; % stores the abacus values and the number of digits
+numeric valUMu[],valUMs[],valLMs[],valLMu[]; % moved values will be in gray
+
+def reset_abacus=
+ for i=1 upto n:
+ valU[i]:=0;
+ valL[i]:=0;
+ endfor;
+ reset_abacus_gray_above;
+ reset_abacus_gray_below;
+enddef;
+
+def reset_abacus_gray_above=
+ for i=1 upto n:
+ valUMs[i]:=0;valUMu[i]:=0;
+ endfor;
+enddef;
+
+def reset_abacus_gray_below=
+ for i=1 upto n:
+ valLMu[i]:=0;valLMs[i]:=0;
+ endfor;
+enddef;
+
+def suanpan_bead(expr X,Y)=
+ fullcircle xscaled 2beadw yscaled vsep shifted (X,Y)
+enddef;
+
+def draw_suanpan_bead(expr X,Y) text options=
+ fill suanpan_bead(X,Y) options;
+enddef;
+
+def draw_suanpan_gray_bead(expr X,Y) text options=
+ fill suanpan_bead(X,Y) options;
+ draw suanpan_bead(X,Y);
+enddef;
+
+def draw_suanpan_bead_contour(expr X,Y) text options=
+ draw_suanpan_gray_bead(X,Y) withcolor white;
+enddef;
+
+def define_soroban_bead_points(expr X,Y)=
+ save p,pa;pair p[];path pa;
+ p0=(X,Y);p1=p0+(beadw,.5wdvline);p2=p0+(.5wdvline,.5vsep);
+ p3=p0+(-.5wdvline,.5vsep);p4=p0+(-beadw,.5wdvline);
+ p5=p0+(-beadw,-.5wdvline);p6=p0+(-.5wdvline,-.5vsep);
+ p7=p0+(.5wdvline,-.5vsep);p8=p0+(beadw,-.5wdvline);
+ pa=p1--p2--p3--p4--p5--p6--p7--p8--cycle;
+enddef;
+
+% this macro draws a biconal bead, like on a soroban
+vardef draw_soroban_bead(expr X,Y) text options=
+ define_soroban_bead_points(X,Y);
+ unfill pa;
+ draw pa;draw p1--p4;draw p5--p8;
+enddef;
+
+% this macro draws a biconal bead, like on a soroban
+vardef draw_soroban_gray_bead(expr X,Y) text options=
+ define_soroban_bead_points(X,Y);
+ fill pa withcolor .7white;
+ draw pa;draw p1--p4;draw p5--p8;
+enddef;
+
+vardef draw_soroban_bead_contour(expr X,Y)=
+ define_soroban_bead_points(X,Y);
+ unfill pa;
+ draw pa;
+enddef;
+
+def draw_bead_contour(expr X,Y) text options=
+ if beadtype=1:
+ draw_suanpan_bead_contour(X,Y);
+ else:
+ draw_soroban_bead_contour(X,Y);
+ fi;
+enddef;
+
+def draw_bead(expr X,Y) text options=
+ if beadtype=1:
+ draw_suanpan_bead(X,Y) options;
+ elseif beadtype=2:
+ draw_soroban_bead(X,Y) options;
+ fi;
+enddef;
+
+def draw_gray_bead(expr X,Y)=
+ if beadtype=1:
+ draw_suanpan_gray_bead(X,Y) withcolor .7white;
+ elseif beadtype=2:
+ draw_soroban_gray_bead(X,Y) withcolor .7white;
+ fi;
+enddef;
+
+vardef draw_abacus_beads=
+ save na,nb,X,Y;
+ % we go through every bead line:
+ for i=1 upto n:
+ X:=thframe+ihsep+(n-i)*hsep;
+ % first, we handle the lower beads:
+ na:=nbl-valL[i];
+ nb:=valL[i];
+ % ------------------------------------------------------------
+ % these are the lower beads which have not been raised (unset)
+ for j=1 upto na:
+ Y:=thframe+.5vsep+(j-1)*vsep;
+ draw_bead(X,Y);
+ endfor;
+ % some of the previous ones are in gray:
+ for j=na downto na-(valLMu[i]-1):
+ Y:=thframe+.5vsep+(j-1)*vsep;
+ draw_gray_bead(X,Y);
+
+ endfor;
+ %-------------------------------------------------------------
+ % these are the lower beads which have been raised (set)
+ for j=1 upto nb:
+ Y:=thframe+hlwindow-(.5vsep+(j-1)*vsep);
+ draw_bead(X,Y);
+ endfor;
+ % some of the previous ones are in gray:
+ for j=nb downto nb-(valLMs[i]-1):
+ Y:=thframe+hlwindow-(.5vsep+(j-1)*vsep);
+ draw_gray_bead(X,Y);
+ endfor;
+ %-------------------------------------------------------------
+ % then we handle the upper beads:
+ na:=nbu-valU[i];
+ nb:=valU[i];
+ %--------------------------------------------------------------
+ % these are the upper beads which have not been lowered (unset)
+ for j=1 upto na:
+ Y:=htframe-(thframe+.5vsep+(j-1)*vsep);
+ draw_bead(X,Y);
+ endfor;
+ for j=na downto na-(valUMu[i]-1):
+ Y:=htframe-(thframe+.5vsep+(j-1)*vsep);
+ draw_gray_bead(X,Y);
+ endfor;
+ %--------------------------------------------------------------
+ % these are the upper beads which have been lowered (set)
+ for j=1 upto nb:
+ Y:=2thframe+hlwindow+(.5vsep+(j-1)*vsep);
+ draw_bead(X,Y);
+ endfor;
+ for j=nb downto nb-(valUMs[i]-1):
+ Y:=2thframe+hlwindow+(.5vsep+(j-1)*vsep);
+ draw_gray_bead(X,Y);
+ endfor;
+ %--------------------------------------------------------------
+ endfor;
+enddef;
+
+def draw_abacus=
+ draw_abacus_frame;
+ draw_abacus_rods;
+ draw_abacus_beads;
+enddef;
+
+% v must be a string
+vardef set_abacus_val(expr v)=
+ save vx;
+ numeric vx[];
+ reset_abacus;
+ vl:=min(length(v),n)-1; % handle overflows in the input
+ for i=0 upto length(v)-1:
+ vx[i]=ASCII(substring(i,i+1) of v)-ASCII("0");
+ endfor;
+ for i=1 upto length(v):
+ valL[i]:=vx[length(v)-i];
+ if valL[i]>vbu-1: % we must use vbu and not nbl, although
+ % they are usually the same
+ valU[i]:=1;
+ valL[i]:=valL[i]-vbu; % same remark
+ fi;
+ endfor;
+enddef;
+
+vardef reset_abacus_gray=
+ save s;
+ string s;
+ s="";
+ for i=1 upto n:s:=s & "0";endfor;
+ set_abacus_gray(deck="lower",below=s,above=s);
+ set_abacus_gray(deck="upper",below=s,above=s);
+enddef;
+
+vardef set_abacus_gray_below=
+ save vx;
+ numeric vx[];
+ reset_abacus_gray_below;
+ % reading the first string, for the lower part (which beads are gray)
+ for i=0 upto length(below)-1:
+ vx[i]:=ASCII(substring(i,i+1) of below)-ASCII("0");
+ endfor;
+ for i=1 upto length(below):
+ valLMu[i]:=vx[length(below)-i];
+ endfor;
+ % reading the second string, for the upper part (which beads are gray)
+ for i=0 upto length(above)-1:
+ vx[i]:=ASCII(substring(i,i+1) of above)-ASCII("0");
+ endfor;
+ for i=1 upto length(above):
+ valLMs[i]:=vx[length(above)-i];
+ endfor;
+ % we check that there is no conflict in the graying of beads:
+ % a bead can only be grayed if it exists
+ for i=1 upto n:
+ % lower beads ...............................
+ na:=nbl-valL[i];
+ nb:=valL[i];
+ % we force threshholds if necessary:
+ if valLMs[i]>valL[i]:valLMs[i]:=valL[i];fi
+ if valLMu[i]>na:valLMu[i]:=na;fi
+ endfor;
+enddef;
+
+vardef set_abacus_gray_above=
+ save vx;
+ numeric vx[];
+ reset_abacus_gray_above;
+ % reading the first string, for the lower part (which beads are gray)
+ for i=0 upto length(below)-1:
+ vx[i]:=ASCII(substring(i,i+1) of below)-ASCII("0");
+ endfor;
+ for i=1 upto length(below):
+ valUMs[i]:=vx[length(below)-i];
+ endfor;
+ % reading the second string, for the upper part (which beads are gray)
+ for i=0 upto length(above)-1:
+ vx[i]:=ASCII(substring(i,i+1) of above)-ASCII("0");
+ endfor;
+ for i=1 upto length(above):
+ valUMu[i]:=vx[length(above)-i];
+ endfor;
+ % we check that there is no conflict in the graying of beads:
+ % a bead can only be grayed if it exists
+ for i=1 upto n:
+ % upper beads ...............................
+ na:=nbu-valU[i];
+ nb:=valU[i];
+ % we force threshholds if necessary:
+ if valUMs[i]>valU[i]:valUMs[i]:=valU[i];fi
+ if valUMu[i]>na:valUMu[i]:=na;fi
+ endfor;
+enddef;
+
+vardef set_abacus_gray(text kv)=
+ save deck,below,above; % key names
+ string deck,below,above;
+ executekeyval(kv);
+ if deck="lower":
+ set_abacus_gray_below;
+ elseif deck="upper":
+ set_abacus_gray_above;
+ fi;
+enddef;
+
+% put the label `lab' on the j-th bead on row i (i=1 at the right)
+vardef mark_abacus(text kv)(expr lab)=
+ save i,j; % key names
+ numeric i,j;
+ executekeyval(kv);
+
+ save X,Y,na,nb,ju;
+ X:=thframe+ihsep+(n-i)*hsep;
+ if j<=nbl: % the bead to mark is below:
+ % first, we handle the lower beads:
+ na:=nbl-valL[i];
+ nb:=valL[i];
+ % ------------------------------------------------------------
+ if j<=na:
+ % these are the lower beads which have not been raised (unset)
+ Y:=thframe+.5vsep+(j-1)*vsep;
+ else:
+ %-------------------------------------------------------------
+ % these are the lower beads which have been raised (set)
+ Y:=thframe+hlwindow-(.5vsep+(nb-(j-na))*vsep);
+ fi
+ else: % the bead to mark is above:
+ ju=j-nbl;
+ %-------------------------------------------------------------
+ % then we handle the upper beads:
+ na:=nbu-valU[i];
+ nb:=valU[i];
+ if ju>nb:
+ %--------------------------------------------------------------
+ % these are the upper beads which have not been lowered (unset)
+ Y:=htframe-(thframe+.5vsep+(na-(ju-nb))*vsep);
+ else:
+ %--------------------------------------------------------------
+ % these are the upper beads which have been lowered (set)
+ Y:=2thframe+hlwindow+(.5vsep+(ju-1)*vsep);
+ fi;
+ fi;
+ draw_bead_contour(X,Y);
+ draw thelabel(lab,(X,Y)); % withcolor white;
+enddef;
+
+def show_val=
+ for i=1 upto vl+1:
+ message "valU[" & decimal i & "]=" & decimal (valU[i]);
+ message "valL[" & decimal i & "]=" & decimal (valL[i]);
+ endfor;
+enddef;
+
+% v=value, iv=image view
+def add_val(text kv)=
+ save v,iv,fig; % key names
+ string v;numeric iv;boolean fig;
+ executekeyval(kv);
+ save vx,VL,VU,carry;
+ numeric vx[],vL[],vU[],vx.len;
+ overflow:=false;
+ % we store the new value to add in one array
+ vx.len=min(length(v),n)-1; % we consider at most n digits
+ %message "vx.len=" & decimal vx.len;
+ for i=0 upto vx.len:
+ vx[i]=ASCII(substring(i,i+1) of v)-ASCII("0");
+ endfor;
+ for i=1 upto length(v):
+ vL[i]:=vx[length(v)-i];
+ endfor;
+
+ % if necessary, we modify the size of the first number:
+ if vx.len>vl:vl:=vx.len;fi
+ % the result will be either this wide, or will have one more digit
+ % to the left
+
+ if fig:
+ % the initial configuration:
+ beginfig(iv);
+ draw_abacus;
+ endfig;
+ fi
+
+ % we add the digits from left to right:
+ for i=vx.len+1 downto 1:
+ valL[i]:=valL[i]+vL[i];
+ % if there would be too many beads below, we adjust the upper ones:
+ forever:
+ if valL[i]>vbu-1:
+ valL[i]:=valL[i]-vbu;
+ valU[i]:=valU[i]+1;
+ fi
+ exitif valL[i]<vbu;
+ endfor;
+ % then, we propagate a carry if necessary:
+ carry:=0;
+ if valU[i]>1: % valU[i]=2 or 3 are possible values
+ carry:=1;
+ % propagate carry
+ valU[i]:=valU[i]-2;
+ for j=i+1 upto vl+1:
+ valL[j]:=valL[j]+carry;
+ if valL[j]>4:valL[j]:=0;valU[j]:=valU[j]+1;fi
+ if valU[j]>1:carry:=1;valU[j]:=valU[j]-2;else:carry:=0;fi
+ exitif carry=0; % no need to go all the way through,
+ % if the carry becomes 0
+ endfor;
+ if carry=1:
+ % we increment vl and we add the carry:
+ vl:=vl+1;
+ valL[vl+1]:=1;
+ if vl+1>n:overflow:=true;fi
+ fi
+ fi
+ %message "adding " & decimal vL[i] & " at position " & decimal i
+ % & " and generating view " & decimal (iv+(vx.len+1-i)+1);
+ if fig:
+ beginfig(iv+(vx.len+1-i)+1);
+ draw_abacus;
+ endfig;
+ fi
+ endfor;
+
+enddef;
+
+endinput