Schmidt Algorithm

Author

Eric W. Weisstein
August 31, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/NumberTheory/SchmidtAlgorithm.nb.

For more information, see Eric's MathWorld entry https://mathworld.wolfram.com/SchmidtAlgorithm.

Copyright 2026 Wolfram Research, Inc. except for portions noted otherwise

Figure

A finite-resolution view of the Schmidt circle arrangement generated by the seven Mobius transformations used by the algorithm.

Module[{v1, v2, v3, e1, e2, e3, c, fraction, imageTriple, circleData, children, largeEnough, 
   nextGeneration, generations, matrices, circles}, v1 = {{1, I}, {0, 1}}; v2 = {{1, 0}, {-I, 1}}; 
   v3 = {{1 - I, I}, {-I, 1 + I}}; e1 = {{1, 0}, {1 - I, I}}; e2 = {{1, -1 + I}, {0, I}}; 
   e3 = {{I, 0}, {0, 1}}; c = {{1, -1 + I}, {1 - I, I}}; 
   fraction[a_, b_] := If[b === 0, ComplexInfinity, a/b]; 
   imageTriple[m_] := MapThread[fraction, m . {{1, 0, 1}, {0, 1, 1}}]; 
   circleData[m_] := Module[{z, p, matrix, center, radius}, z = imageTriple[m]; 
      If[MemberQ[z, ComplexInfinity], Return[Nothing, Module]]; p = ({Re[#1], Im[#1]} & ) /@ z; 
      matrix = 2*{p[[2]] - p[[1]], p[[3]] - p[[1]]}; If[Det[matrix] === 0, 
       Return[Nothing, Module]]; center = LinearSolve[matrix, {p[[2]] . p[[2]] - p[[1]] . p[[1]], 
         p[[3]] . p[[3]] - p[[1]] . p[[1]]}]; radius = Norm[center - p[[1]]]; {center, radius}]; 
   children[m_] := (m . #1 & ) /@ If[Re[Det[m]] =!= 0, {c, v1, v2, v3, e1, e2, e3}, 
      {c, v1, v2, v3}]; largeEnough[m_, cutoff_] := 
    Module[{data}, data = circleData[If[Re[Det[m]] =!= 0, m, m . c]]; 
      MatchQ[data, {_List, _}] && Last[data] >= cutoff]; nextGeneration[generation_, cutoff_] := 
    DeleteDuplicates[Select[Flatten[children /@ generation, 1], largeEnough[#1, cutoff] & ]]; 
   generations = NestWhileList[nextGeneration[#1, 1/80] & , {v3}, #1 =!= {} & , 1, 20]; 
   matrices = DeleteDuplicates[Flatten[generations, 1]]; 
   circles = DeleteDuplicates[Cases[(If[Re[Det[#1]] =!= 0, With[{data = circleData[#1]}, 
          If[MatchQ[data, {_List, _}], Circle @@ data, Nothing]], Nothing] & ) /@ matrices, 
      _Circle]]; Graphics[{LightDarkSwitched[Black, White], AbsoluteThickness[0.75], circles}]]