%%%
% Multiplication Japonaise
%%%
\def\filedateMulJap{2025/12/21}%
\def\fileversionMulJap{0.1c}%
\message{-- \filedateMulJap\space v\fileversionMulJap}%
%
\setKVdefault[MulJap]{Couleur=Orange,DessinSeul=false,CalculSeul=false,CouleurBloc={},Echelle=1,ListeCouleurs={green,red,blue,Purple,Orange,Olive},Baguettes=false}%

\newtoks\toksmuljap%
\def\UpdatetoksMulJap#1\nil{\addtotok\toksmuljap{"#1",#1,}}%

\makeatletter
\NewDocumentCommand\MulJaponaise{om}{%
  \useKVdefault[MulJap]%
  \setKV[MulJap]{#1}%
  \setsepchar{x}\ignoreemptyitems%
  \readlist*\PfC@MulJap{#2}%
  \toksmuljap{}%
  \foreachitem\compteur\in\PfC@MulJap{\expandafter\UpdatetoksMulJap\compteur\nil}%
  \ifboolKV[MulJap]{Baguettes}{%
    \ifboolKV[MulJap]{CalculSeul}{}{%
      \PfC@BuildMulJapBaguettes{\the\toksmuljap}%
    }%
    \ifboolKV[MulJap]{DessinSeul}{}{%
      \PfC@BuildMulJapBaguettesFinal%
    }%
  }{%
    \PfC@BuildMulJap{\the\toksmuljap}%
  }%
  \reademptyitems%
}%

\NewDocumentCommand\PfC@BuildMulJap{m}{%
  \mplibforcehmode%
  \mplibnumbersystem{double}%
  \begin{mplibcode}
    u:=\useKV[MulJap]{Echelle}*u;
    boolean Bloc,DessinSeul;
    \ifemptyKV[MulJap]{CouleurBloc}{Bloc=false;}{Bloc=true;color CouleurBloc;
      CouleurBloc=\useKV[MulJap]{CouleurBloc};}
    DessinSeul=\useKV[MulJap]{DessinSeul};
    color CoulTraits;
    CoulTraits=\useKV[MulJap]{Couleur};
    % On lit les string et les nombres
    string Sfacteur[];
    numeric facteur[];
    vardef LectureDonnees(text t)=
      n=1;
      for p_=t:
        if (n mod 2)=1:
          Sfacteur[(n+1) div 2]=p_;
        else:
          facteur[n div 2]=p_;
        fi;
        n:=n+1;
      endfor;
    enddef;
    numeric chiffrea[],chiffreb[];
    vardef ExtraireChiffre=
      Reste=facteur[1];
      for k=length(Sfacteur[1]) downto 1:
        Diviseur:=1;
        for l=1 upto k-1:
          Diviseur:=Diviseur*10;
        endfor;
        chiffrea[length(Sfacteur[1])+1-k]=Reste div Diviseur;
        Reste:=Reste mod Diviseur;
      endfor;
      Reste:=facteur[2];
      for k=length(Sfacteur[2]) downto 1:
        Diviseur:=1;
        for l=1 upto k-1:
          Diviseur:=Diviseur*10;
        endfor;
        chiffreb[length(Sfacteur[2])+1-k]=Reste div Diviseur;
        Reste:=Reste mod Diviseur;
      endfor;
    enddef;
    LectureDonnees(#1);
    ExtraireChiffre;
    pair ta,basei,basej;
    ta=u*(1,5);
    basei=u*(1,1);
    basej=u*(1,-1);
    ecart=2.5;
    vardef TraitsI(expr nb, lieu)=
      label.ulft(TEX(decimal(nb)),lieu shifted(-1*basej));
      if (nb mod 2)=1:%le nombre de traits est impair
        p:=(nb-1) div 2;
        for k=-p upto p:
          trace ((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.1*basei) withcolor CoulTraits;
        endfor;
      else:%le nombre de traits est pair
        p:=nb div 2;
        if nb=0:
          trace ((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) withcolor red;
        else:
          for k=-p upto -1:
          trace ((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.1*basei+0.05*basei) withcolor CoulTraits;
          endfor;
          for k=1 upto p:
          trace ((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.1*basei-0.05*basei) withcolor CoulTraits;
          endfor;
        fi;
      fi;
    enddef;
    vardef TraitsJ(expr nb, lieu)=
      label.urt(TEX(decimal(nb)),lieu shifted((length(Sfacteur[1])-0.5)*ecart*basei));
      if (nb mod 2)=1:%le nombre de traits est impair
        p:=(nb-1) div 2;
        for k=-p upto p:
          trace ((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.1*basej) withcolor CoulTraits;
        endfor;
      else:%le nombre de traits est pair
        p:=nb div 2;
        if nb=0:
          trace ((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) withcolor red;
        else:
%          label(TEX("ici"),lieu);
          for k=-p upto -1:
          trace ((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.1*basej+0.05*basej) withcolor CoulTraits;
          endfor;
          for k=1 upto p:
          trace ((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.1*basej-0.05*basej) withcolor CoulTraits;
          endfor;
        fi;
      fi;
    enddef;
    % drawoptions(withpen pencircle scaled 1.25 withcolor Orange);
    for k=1 upto length(Sfacteur[1]):
      TraitsI(chiffrea[k],ta+ecart*(k-1)*basei);
    endfor;
    % drawoptions(withcolor blue);
    for k=1 upto length(Sfacteur[2]):
      TraitsJ(chiffreb[k],ta+ecart*(k-1)*basej);
    endfor;
    % Les blocs ?
    pair testi[],testj[];
    numeric rt,st;
    rt:=0;st:=0;
    for k=0 upto (length(Sfacteur[1])-1):
      rt:=rt+1;
      testi[rt]=ta shifted(k*ecart*basei);
    endfor;
    for k=1 upto (length(Sfacteur[2])-1):
      rt:=rt+1;
      testi[rt]=testi[rt-1] shifted(ecart*basej);
    endfor;
    % 
    for k=0 upto (length(Sfacteur[2])-1):
      st:=st+1;
      testj[st]=ta shifted(k*ecart*basej);
    endfor;
    for k=1 upto (length(Sfacteur[1])-1):
      st:=st+1;
      testj[st]=testj[st-1] shifted(ecart*basei);
    endfor;
    if Bloc:
      for k=1 upto rt:
        draw polygone(testi[k]+u*0.5*ecart*(-cosd(45),sind(45)),testi[k]+u*0.5*ecart*(cosd(45),sind(45)),testj[k]+u*0.5*ecart*(cosd(45),-sind(45)),testj[k]+u*0.5*ecart*(-cosd(45),-sind(45)));
      endfor;
    fi;
    % On détaille le calcul
    for k=1 upto 50:
      RetiensDecimal[k]=0;
    endfor;
    for k=1 upto length(Sfacteur[1]):
      for l=1 upto length(Sfacteur[2]):
        RetiensDecimal[k+l]:=RetiensDecimal[k+l]+chiffrea[k]*chiffreb[l];
      endfor;
    endfor;
    % 
    miny=4000;
    for k=1 upto st:
      if ypart(testj[k])<miny:
        miny:=ypart(testj[k]);
      fi;
    endfor;
    pair PointBasea[],PointBaseb[],PointBasec[];
    for k=1 upto rt:
      PointBasea[k]=(xpart(testj[k]),miny-ecart*u);
      PointBaseb[k]=PointBasea[k]+u*ecart*(0,-1);
      PointBasec[k]=PointBasea[k]+(0,-7.5*0.1u);
    endfor;
    numeric NouveauNombre[];
    if DessinSeul=false:
      for k=1 upto rt:
        label(decimal(RetiensDecimal[k+1]),PointBasea[k]);
      endfor;
      % Affichage des retenues, des nombres, des unités...
      Retenue[rt+1]:=0;
      for k=rt downto 1:
        NouveauNombre[k]=RetiensDecimal[k+1]+Retenue[k+1];
        Retenue[k]:=NouveauNombre[k] div 10;
      endfor;
      %fleche haut -> bas
      for k=rt downto 1:
        drawarrow (PointBasea[k]--PointBaseb[k]) cutbefore cercles(PointBasea[k],if k=rt:5*0.1u else: 10*0.1u fi) cutafter cercles(PointBaseb[k],5*0.1u);
      endfor;
      % fleche diag
      for k=rt downto 2:
        if Retenue[k]>0:
          if k=rt:
            drawarrow (PointBasea[k]--PointBasea[k-1]) cutbefore cercles(PointBasea[k],5*0.1u) cutafter cercles(PointBasea[k-1],5*0.1u);
          else:
            drawarrow (PointBasec[k]--PointBasea[k-1]) cutbefore cercles(PointBasec[k],5*0.1u) cutafter cercles(PointBasea[k-1],5*0.1u);
          fi;
        fi;
      endfor;
      for k=rt downto 1:
        if k>1:
          label(decimal(NouveauNombre[k] mod 10),PointBaseb[k]);
        else:
          label(decimal(NouveauNombre[k]),PointBaseb[k]);
        fi;
        if k>1:
          if Retenue[k]>0:
            if k=rt:
              fill cercles(iso(PointBasea[k],PointBasea[k-1]),5*0.1u) withcolor white;
              label(TEX("$+"&decimal(Retenue[k])&"$"),iso(PointBasea[k],PointBasea[k-1]));
            else:
              fill cercles(iso(PointBasec[k],PointBasea[k-1]),5*0.1u) withcolor white;
              label(TEX("$+"&decimal(Retenue[k])&"$"),iso(PointBasec[k],PointBasea[k-1]));
            fi;
            draw pointarc(cercles(PointBasea[k-1],3*0.1u),45)--pointarc(cercles(PointBasea[k-1],3*0.1u),225);
          fi;
          if k<rt:
            if Retenue[k+1]>0:
              label(TEX("$"&decimal(NouveauNombre[k])&"$"),PointBasec[k]);
            fi;
          fi;
        elseif k=1:
          if Retenue[k]>0:
            draw pointarc(cercles(PointBasea[k],3*0.1u),45)--pointarc(cercles(PointBasea[k],3*0.1u),225);
            label(TEX("$"&decimal(NouveauNombre[k])&"$"),PointBasec[k]);
          fi;
        fi;
      endfor;
    fi;
  \end{mplibcode}%
  \mplibnumbersystem{scaled}%
}%

\NewDocumentCommand\PfC@BuildMulJapBaguettes{m}{%
  \mplibforcehmode%
  \mplibnumbersystem{double}%
  \begin{mplibcode}
    u:=\useKV[MulJap]{Echelle}*u;
    boolean DessinSeul;
    DessinSeul=\useKV[MulJap]{DessinSeul};
    color CoulTraits;
    CoulTraits=\useKV[MulJap]{Couleur};
    % On lit les string et les nombres
    string Sfacteur[];
    numeric facteur[];
    vardef LectureDonnees(text t)=
      n=1;
      for p_=t:
        if (n mod 2)=1:
          Sfacteur[(n+1) div 2]=p_;
        else:
          facteur[n div 2]=p_;
        fi;
        n:=n+1;
      endfor;
    enddef;
    color CoulPoints[],CoulFin[];
    vardef DetermineCouleurs=
      nb:=0;
      for p_=\useKV[MulJap]{ListeCouleurs}:
        nb:=nb+1;
        CoulPoints[nb]=p_;
      endfor;
      totalaretenir:=(length(Sfacteur[1])+length(Sfacteur[2]));
      for k=2 upto totalaretenir:
        CoulFin[k]=CoulPoints[(length(Sfacteur[1])+length(Sfacteur[2]))+1-k];
      endfor;
    enddef;
    %
    numeric chiffrea[],chiffreb[];
    vardef ExtraireChiffre=
      Reste=facteur[1];
      for k=length(Sfacteur[1]) downto 1:
        Diviseur:=1;
        for l=1 upto k-1:
          Diviseur:=Diviseur*10;
        endfor;
        chiffrea[length(Sfacteur[1])+1-k]=Reste div Diviseur;
        Reste:=Reste mod Diviseur;
      endfor;
      Reste:=facteur[2];
      for k=length(Sfacteur[2]) downto 1:
        Diviseur:=1;
        for l=1 upto k-1:
          Diviseur:=Diviseur*10;
        endfor;
        chiffreb[length(Sfacteur[2])+1-k]=Reste div Diviseur;
        Reste:=Reste mod Diviseur;
      endfor;
    enddef;
    LectureDonnees(#1);
    DetermineCouleurs;
    ExtraireChiffre;
    pair ta,basei,basej;
    ta=u*(1,5);
    basei=u*(1,0);
    basej=u*(0,-1);
    ecart=1.5;
    numeric NbI,NbJ;
    numeric NbTraitsI[],NbTraitsJ[];
    path RetiensTraitsI[][],RetiensTraitsJ[][];
    %
    NbI:=0;
    NbJ:=0;
    vardef TraitsI(expr nb, lieu)=
      NbI:=NbI+1;
      nbtr:=0;
      label.top(TEX(decimal(nb)),lieu shifted(-1*basej));
      if (nb mod 2)=1:%le nombre de traits est impair
        p:=(nb-1) div 2;
        for k=-p upto p:
          nbtr:=nbtr+1;
          RetiensTraitsI[NbI][nbtr]=((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.2*basei);
          trace RetiensTraitsI[NbI][nbtr] withcolor CoulTraits;
        endfor;
      else:%le nombre de traits est pair
        p:=nb div 2;
        if nb>0:
          %nbtr:=nbtr+1;
          %RetiensTraitsI[NbI][nbtr]=((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej)));
          %trace RetiensTraitsI[NbI][nbtr] withcolor CoulTraits;
%        else:
          for k=-p upto -1:
            nbtr:=nbtr+1;
            RetiensTraitsI[NbI][nbtr]=((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.2*basei+0.1*basei);
            trace RetiensTraitsI[NbI][nbtr] withcolor CoulTraits;
          endfor;
          for k=1 upto p:
            nbtr:=nbtr+1;
            RetiensTraitsI[NbI][nbtr]=((lieu shifted(-1*basej))--(lieu shifted ((length(Sfacteur[2])-0.5)*ecart*basej))) shifted(k*0.2*basei-0.1*basei);
            trace RetiensTraitsI[NbI][nbtr] withcolor CoulTraits;
          endfor;
        fi;
      fi;
      NbTraitsI[NbI]=nbtr;
    enddef;
    vardef TraitsJ(expr nb, lieu)=
      NbJ:=NbJ+1;
      nbtr:=0;
      label.rt(TEX(decimal(nb)),lieu shifted((length(Sfacteur[1])-0.5)*ecart*basei));
      if (nb mod 2)=1:%le nombre de traits est impair
        p:=(nb-1) div 2;
        for k=-p upto p:
          nbtr:=nbtr+1;
          RetiensTraitsJ[NbJ][nbtr]=((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.2*basej);
          trace RetiensTraitsJ[NbJ][nbtr] withcolor CoulTraits;
        endfor;
      else:%le nombre de traits est pair
        p:=nb div 2;
        if nb>0:
          %nbtr:=nbtr+1;
          %RetiensTraitsJ[NbJ][nbtr]=((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei)));
          %trace RetiensTraitsJ[NbJ][nbtr] withcolor CoulTraits;
%        else:
%          label(TEX("ici"),lieu);
          for k=-p upto -1:
            nbtr:=nbtr+1;
            RetiensTraitsJ[NbJ][nbtr]=((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.2*basej+0.1*basej);
            trace RetiensTraitsJ[NbJ][nbtr] withcolor CoulTraits;
          endfor;
          for k=1 upto p:
            nbtr:=nbtr+1;
            RetiensTraitsJ[NbJ][nbtr]=((lieu shifted(-1*basei))--(lieu shifted ((length(Sfacteur[1])-0.5)*ecart*basei))) shifted(k*0.2*basej-0.1*basej);
            trace RetiensTraitsJ[NbJ][nbtr] withcolor CoulTraits;
          endfor;
        fi;
      fi;
      NbTraitsJ[NbJ]=nbtr;  
    enddef;
    % drawoptions(withpen pencircle scaled 1.25 withcolor Orange);
    for k=1 upto length(Sfacteur[1]):
      TraitsI(chiffrea[k],ta+ecart*(k-1)*basei);
    endfor;
    for k=1 upto length(Sfacteur[2]):
      TraitsJ(chiffreb[k],ta+ecart*(k-1)*basej);
    endfor;
    for k=1 upto length(Sfacteur[1]):
      for l=1 upto length(Sfacteur[2]):
        if unknown CoulFin[k+l]:
          drawoptions(withcolor black);
        else:
          drawoptions(withcolor CoulFin[k+l]);
        fi;
        for p=1 upto NbTraitsI[k]:
          for r=1 upto NbTraitsJ[l]:
            dotlabel("",RetiensTraitsI[k][p] intersectionpoint RetiensTraitsJ[l][r]);
          endfor;
        endfor;
      endfor;
    endfor;
    drawoptions();  
  \end{mplibcode}%
  \mplibnumbersystem{scaled}%
}%

\NewDocumentCommand\PfC@ExporteChiffres{m}{%
  % #1 le contenu de la liste.
  \expandafter\xdef\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname{\fpeval{\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname+#1}}%
}%

\NewDocumentCommand\PfC@BuildMulJapBaguettesFinal{}{%
  \edef\PfC@ChiffresFacteurA{}%
  \StrLen{\PfC@MulJap[1]}[\PfC@LongueurFA]%
  \xintFor* ##1 in{\xintSeq{\PfC@LongueurFA}{1}}\do{%
    \StrChar{\PfC@MulJap[1]}{##1}[\PfC@ChiffreRetenu]%
    \edef\PfC@ChiffresFacteurA{\PfC@ChiffresFacteurA,\PfC@ChiffreRetenu}%
  }%
%  Facteur A : \PfC@MulJap[1] -- Chiffres : \PfC@ChiffresFacteurA
  \edef\PfC@ChiffresFacteurB{}%
  \StrLen{\PfC@MulJap[2]}[\PfC@LongueurFB]%
  \xintFor* ##1 in{\xintSeq{\PfC@LongueurFB}{1}}\do{%
    \StrChar{\PfC@MulJap[2]}{##1}[\PfC@ChiffreRetenu]%
    \edef\PfC@ChiffresFacteurB{\PfC@ChiffresFacteurB,\PfC@ChiffreRetenu}%
  }%
%  Facteur B : \PfC@MulJap[1] -- Chiffres : \PfC@ChiffresFacteurB
  \setsepchar{,}\ignoreemptyitems%
  \readlist*\ListeChiffresFA{\PfC@ChiffresFacteurA}%
  \readlist*\ListeChiffresFB{\PfC@ChiffresFacteurB}%
  \edef\PfC@ListeCouleursAv{\useKV[MulJap]{ListeCouleurs}}%
  \readlist*\PfC@ListeRetiensCouleurs{\PfC@ListeCouleursAv}%
  \reademptyitems%
%  \par\showitems\PfC@ListeRetiensCouleurs[]
  \xintFor* ##1 in{\xintSeq{1}{\PfC@LongueurFA}}\do{%
    \xintFor* ##2 in{\xintSeq{1}{\PfC@LongueurFB}}\do{%
      \setcounter{PfCenumi}{\fpeval{##1+##2}}%
      \expandafter\xdef\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname{0}%
    }%
  }%
  \xintFor* ##1 in{\xintSeq{1}{\PfC@LongueurFA}}\do{%
    \xintFor* ##2 in{\xintSeq{1}{\PfC@LongueurFB}}\do{%
      \setcounter{PfCenumi}{\fpeval{##1+##2}}%
      \PfC@ExporteChiffres{\fpeval{\ListeChiffresFA[##1]*\ListeChiffresFB[##2]}}%
    }%
  }%
  \[
    \setlength{\arraycolsep}{0pt}
    \begin{array}{rl}
      \xintFor* ##1 in{\xintSeq{2}{\fpeval{\PfC@LongueurFA+\PfC@LongueurFB}}}\do{%
      \setcounter{PfCenumi}{##1}%
      \ifnum\fpeval{\thePfCenumi-1}>\PfC@ListeRetiensCouleurslen\relax\num{\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname}\else\mathcolor{\PfC@ListeRetiensCouleurs[\fpeval{\thePfCenumi-1}]}{\num{\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname}}\fi\times\num{\fpeval{10**(\thePfCenumi-2)}}&{}=\num{\fpeval{\csname PfC@ListeRetiensProduit\Roman{PfCenumi}\endcsname*(10**(\thePfCenumi-2))}}\\
      }%
      \hline
      \num{\PfC@MulJap[1]}\times\num{\PfC@MulJap[2]}&{}=\num{\fpeval{\PfC@MulJap[1]*\PfC@MulJap[2]}}\\
    \end{array}
  \]
}%
\makeatother