% a font devised for typesetting certain "Celtic paths"
% (see program CELTIC-PATHS for more details)
%                         --- Don Knuth, August 2010

mode_setup;
quad#:=13u#;
define_pixels(u,d);
font_size 13u#;

pickup pencircle scaled d;
thick_pen=savepen;

numeric s; s=1.5u*sqrt2;
z0l=(s,13u); z0=(0,13u); z0r=(0,13u-s);
z1l=(8u,13u); z1=(6.5u,13u); z1r=(5u,13u);
z2l=(13u,13u-s); z2=(13u,13u); z2r=(13u-s,13u);
z3l=(13u,5u); z3=(13u,6.5u); z3r=(13u,8u);
z4l=(13u-s,0); z4=(13u,0); z4r=(13u,s);
z5l=(5u,0); z5=(6.5u,0); z5r=(8u,0);
z6l=(0,s); z6=(0,0); z6r=(s,0);
z7l=(0,8u); z7=(0,6.5u); z7r=(0,5u);
z10=dir -45;
z11=down;
z12=dir -135;
z13=left;
z14=dir 135;
z15=up;
z16=dir 45;
z17=right;

path p[][];
for i=0 upto 7:
 for j=0 upto 7:
   if i<>j:
    if (i-j) mod 8 <> 1:
     if (j-i) mod 8 <> 1:
      if (i mod 2 = 1) or (j mod 2 = 1):
        p[i][j]=z[i]l{z[i+10]}...z[j]r{-z[j+10]};
      fi
     fi
    fi
   fi
 endfor
endfor

path p[][]l;
for j=0 step 2 until 6:
  p[j][(j+3)mod 8]l=p[j][(j+3)mod 8]--z[(j+2)mod 8]--cycle;
  p[j][(j+5)mod 8]l=p[j][(j+5)mod 8]--z[(j+4)mod 8]--z[(j+2)mod 8]--cycle;
  p[j+1][(j+3)mod 8]l=p[j+1][(j+3)mod 8]--z[(j+2)mod 8]--cycle;
  p[j+1][(j+4)mod 8]l=p[j+1][(j+4)mod 8]--z[(j+2)mod 8]--cycle;
  p[j+1][(j+5)mod 8]l=p[j+1][(j+5)mod 8]--z[(j+4)mod 8]--z[(j+2)mod 8]--cycle;
  p[j+1][(j+6)mod 8]l=p[j+1][(j+6)mod 8]--z[(j+4)mod 8]--z[(j+2)mod 8]--cycle;
  p[j+1][(j+7)mod 8]l=p[j+1][(j+7)mod 8]--z[(j+6)mod 8]
                         --z[(j+4)mod 8]--z[(j+2)mod 8]--cycle;
endfor

def filland(expr p,q) =
  begingroup picture regp,regq;
  regp:=nullpicture;
  addto regp contour p;
  addto regp doublepath p withpen currentpen;
  cull regp keeping (1,infinity);
%display regp inwindow currentwindow; errmessage "regp";
  regq:=nullpicture;
  addto regq contour q;
  addto regq doublepath q withpen currentpen;
  cull regq keeping (1,infinity);
%display regq inwindow currentwindow; errmessage "regq";
  addto regp also regq;
%display regp inwindow currentwindow; errmessage "regp";
  cull regp keeping (2,2);
%display regp inwindow currentwindow; errmessage "regp";
  addto currentpicture also regp;
  endgroup
enddef;
  

def begincchar(expr c) =
  beginchar(c,quad#,quad#,0);
  pickup thick_pen;
  z0l=(s,13u); z0=(0,13u); z0r=(0,13u-s);
  z1l=(8u,13u); z1=(6.5u,13u); z1r=(5u,13u);
  z2l=(13u,13u-s); z2=(13u,13u); z2r=(13u-s,13u);
  z3l=(13u,5u); z3=(13u,6.5u); z3r=(13u,8u);
  z4l=(13u-s,0); z4=(13u,0); z4r=(13u,s);
  z5l=(5u,0); z5=(6.5u,0); z5r=(8u,0);
  z6l=(0,s); z6=(0,0); z6r=(s,0);
  z7l=(0,8u); z7=(0,6.5u); z7r=(0,5u);
  z10=dir -45;
  z11=down;
  z12=dir -135;
  z13=left;
  z14=dir 135;
  z15=up;
  z16=dir 45;
  z17=right;
enddef;

boolean charstopping;
charstopping:=false;

def endcchar =
  if charstopping:
    showit;
    errmessage decimal charcode;
  fi
  endchar;
enddef;

begincchar(oct"40");
fill z0--z2--z4--z6--cycle;
draw z0--z2--z4--z6--cycle;
endcchar;

def singlechar(expr c,i,j) = % "white" is on left of p[i][j]
  begincchar(c);
  draw p[i][j]l;
  fill p[i][j]l;
  draw p[j][i]l;
  fill p[j][i]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  endcchar;
  begincchar(c+1);
  draw p[i][j];
  filldraw p[j][i]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  endcchar;
enddef;

singlechar(oct"44",3,0);
singlechar(oct"46",5,0);
singlechar(oct"50",1,3);
singlechar(oct"52",1,4);
singlechar(oct"54",1,5);
singlechar(oct"56",1,6);
singlechar(oct"60",1,7);
singlechar(oct"62",2,5);
singlechar(oct"64",2,7);
singlechar(oct"66",3,5);
singlechar(oct"70",3,6);
singlechar(oct"72",3,7);
singlechar(oct"74",4,7);
singlechar(oct"76",5,7);

def doublecharwbw(expr c,i,j,ii,jj) = % two arcs, no overlap, middle black
  begincchar(c);
  fill p[i][j]l;
  draw p[i][j]l;
  filland(p[j][i]l,p[jj][ii]l);
  fill p[ii][jj]l;
  draw p[ii][jj]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+1);
  draw p[i][j];
  filland(p[j][i]l,p[jj][ii]l);
  fill p[ii][jj]l;
  draw p[ii][jj]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+2);
  fill p[i][j]l;
  draw p[i][j]l;
  filland(p[j][i]l,p[jj][ii]l);
  draw p[ii][jj];
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+3);
  draw p[i][j];
  filland(p[j][i]l,p[jj][ii]l);
  draw p[ii][jj];
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
enddef;

def doublecharbwb(expr c,i,j,ii,jj) = % two arcs, no overlap, middle white
  begincchar(c);
  draw p[j][i]l;
  fill p[j][i]l;
  filland(p[i][j]l,p[ii][jj]l);
  draw p[jj][ii]l;
  fill p[jj][ii]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+3);
  draw p[j][i]l;
  fill p[j][i]l;
  draw p[i][j];
  draw p[ii][jj];
  draw p[jj][ii]l;
  fill p[jj][ii]l;
  if j mod 2 = 0: draw z[j]l--z[j]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
enddef;

doublecharwbw(oct"100",5,7,1,3);
doublecharbwb(oct"104",1,7,5,3);
doublecharwbw(oct"110",5,0,1,3);
doublecharbwb(oct"114",2,7,5,3);
doublecharwbw(oct"120",5,7,1,4);
doublecharbwb(oct"124",1,7,6,3);
doublecharbwb(oct"130",3,0,7,5);
doublecharbwb(oct"134",1,7,5,2);
doublecharwbw(oct"140",4,7,1,3);
doublecharbwb(oct"144",1,6,5,3);
doublecharwbw(oct"150",5,0,1,3);
doublecharbwb(oct"154",2,7,6,3);
doublecharbwb(oct"160",3,0,7,4);
doublecharbwb(oct"164",1,6,5,2);

path cuttings;  % what got cut off

tertiarydef a cutbefore b =  % tries to cut as little as possible
  begingroup save t;
  (t, whatever) = a intersectiontimes b;
  if t<0:
    cuttings:=point 0 of a;
    a
  else: cuttings:= subpath (0,t) of a;
    subpath (t,length a) of a
  fi
  endgroup
enddef;

tertiarydef a cutafter b =
  reverse (reverse a  cutbefore  b)
  hide(cuttings:=reverse cuttings)
enddef;

def doublechar(expr c,i,j,ii,jj) = % i j under ii jj; (i ii j jj) ctrclkwise
  begincchar(c);
  filland(p[i][j]l,p[jj][ii]l);
  filland(p[i][j]l,p[ii][jj]l);
  filland(p[j][i]l,p[jj][ii]l);
  filland(p[j][i]l,p[ii][jj]l);
  draw p[ii][jj];
  draw p[jj][ii];
  if ii mod 2 = 0: draw z[ii]l--z[ii]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+1);
  draw p[i][j] cutafter p[jj][ii];
  filland(p[i][j]l,p[ii][jj]l);
  filland(p[j][i]l,p[jj][ii]l);
  filland(p[j][i]l,p[ii][jj]l);
  draw p[ii][jj];
  draw p[jj][ii];
  if ii mod 2 = 0: draw z[ii]l--z[ii]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+2);
  filland(p[i][j]l,p[jj][ii]l);
  filland(p[i][j]l,p[ii][jj]l);
  filland(p[j][i]l,p[jj][ii]l);
  draw p[j][i] cutafter p[ii][jj];
  draw p[ii][jj];
  draw p[jj][ii];
  if ii mod 2 = 0: draw z[ii]l--z[ii]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
  begincchar(c+3);
  draw p[i][j] cutafter p[jj][ii];
  filland(p[i][j]l,p[ii][jj]l);
  filland(p[j][i]l,p[jj][ii]l);
  draw p[j][i] cutafter p[ii][jj];
  draw p[ii][jj];
  draw p[jj][ii];
  if ii mod 2 = 0: draw z[ii]l--z[ii]r; fi
  if jj mod 2 = 0: draw z[jj]l--z[jj]r; fi
  endcchar;
enddef;


doublechar(oct"170",4,1,0,3);
doublechar(oct"174",5,2,6,3);
doublechar(oct"200",7,4,0,5);
doublechar(oct"204",6,1,7,2);
doublechar(oct"210",5,1,0,3);
doublechar(oct"214",5,2,7,3);
doublechar(oct"220",5,1,7,4);
doublechar(oct"224",6,1,7,3);
doublechar(oct"230",7,3,0,5);
doublechar(oct"234",5,1,7,2);
doublechar(oct"240",4,1,7,3);
doublechar(oct"244",5,1,6,3);
doublechar(oct"250",6,1,0,3);
doublechar(oct"254",5,2,0,3);
doublechar(oct"260",5,2,7,4);
doublechar(oct"264",6,1,7,4);
doublechar(oct"270",7,1,0,5);
doublechar(oct"274",4,1,7,2);
doublechar(oct"300",4,1,6,3);
doublechar(oct"304",6,3,0,5);
doublechar(oct"310",7,1,0,3);
doublechar(oct"314",3,1,5,2);
doublechar(oct"320",5,3,7,4);
doublechar(oct"324",6,1,7,5);
doublechar(oct"330",7,1,0,5);
doublechar(oct"334",3,1,7,2);
doublechar(oct"340",4,1,5,3);
doublechar(oct"344",6,3,7,5);
doublechar(oct"350",6,1,0,5);
doublechar(oct"354",7,2,0,3);
doublechar(oct"360",4,1,5,2);
doublechar(oct"364",6,3,7,4);

def lambdachar(expr a,b,c,d) =
  begincchar(8a+4b+2c+d);
  draw p[3][7]; draw p[7][3];
  if a=0: filland(p[1][5]l,p[3][7]l); else: draw p[1][5] cutbefore p[3][7]; fi
  if b=0: filland(p[3][7]l,p[5][1]l); else: draw p[5][1] cutafter p[3][7]; fi
  if c=0: filland(p[5][1]l,p[7][3]l); else: draw p[5][1] cutbefore p[7][3]; fi
  if d=0: filland(p[7][3]l,p[1][5]l); else: draw p[1][5] cutafter p[7][3]; fi
  endcchar;
enddef;

lambdachar(0,0,0,0);
lambdachar(0,0,0,1);
lambdachar(0,0,1,0);
lambdachar(0,0,1,1);
lambdachar(0,1,0,0);
lambdachar(0,1,0,1);
lambdachar(0,1,1,0);
lambdachar(0,1,1,1);
lambdachar(1,0,0,0);
lambdachar(1,0,0,1);
lambdachar(1,0,1,0);
lambdachar(1,0,1,1);
lambdachar(1,1,0,0);
lambdachar(1,1,0,1);
lambdachar(1,1,1,0);
lambdachar(1,1,1,1);

font_quad:=13u#;
font_normal_space:=13u#;
font_normal_stretch:=0;
font_normal_shrink:=0;
font_identifier:="CELTICB";
font_coding_scheme:="bizarre";

bye.
showit; errmessage "blank";
charstopping:=true;


secondarydef p then q =
  begingroup pair t; t=p intersectiontimes q;
  subpath (0,xpart t) of p & subpath(ypart t,1) of q
  endgroup
enddef;